higherkindness/mu-haskell
1
1
Fork 0
mirror of https://github.com/higherkindness/mu-haskell.git synced 2024-09-11 14:36:01 +03:00
Code Issues Projects Releases Wiki Activity

Support default values in GraphQL schemas (#129)

Browse Source
This commit is contained in:
Alejandro Serrano 2020-03-06 16:46:39 +01:00 committed by GitHub
parent 01ca1363e4
commit f9b1c9b4ce
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
15 changed files with 178 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
adapter/avro/src/Mu/Quasi/Avro.hs
View File

@ -183,7 +183,7 @@ avroMethodToType schemaName m
where
argToType :: A.Argument -> Q Type
argToType (A.Argument (A.NamedType a) _)
= [t| 'ArgSingle 'Nothing ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
= [t| 'ArgSingle 'Nothing '[] ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
argToType (A.Argument _ _)
= fail "only named types may be used as arguments"

4
adapter/protobuf/src/Mu/Quasi/GRpc.hs
View File

@ -84,9 +84,9 @@ pbMethodToType s (P.Method nm vr v rr r _)
argToType P.Single (P.TOther ["google","protobuf","Empty"])
= [t| '[ ] |]
argToType P.Single (P.TOther a)
= [t| '[ 'ArgSingle 'Nothing ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
= [t| '[ 'ArgSingle 'Nothing '[] ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
argToType P.Stream (P.TOther a)
= [t| '[ 'ArgStream 'Nothing ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
= [t| '[ 'ArgStream 'Nothing '[] ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
argToType _ _
= fail "only message types may be used as arguments"

6
core/rpc/src/Mu/Rpc.hs
View File

@ -96,9 +96,11 @@ data TypeRef serviceName where
-- | Defines the way in which arguments are handled.
data Argument serviceName argName where
-- | Use a single value.
ArgSingle :: Maybe argName -> TypeRef serviceName -> Argument serviceName argName
ArgSingle :: Maybe argName -> [ServiceAnnotation]
-> TypeRef serviceName -> Argument serviceName argName
-- | Consume a stream of values.
ArgStream :: Maybe argName -> TypeRef serviceName -> Argument serviceName argName
ArgStream :: Maybe argName -> [ServiceAnnotation]
-> TypeRef serviceName -> Argument serviceName argName
-- | Defines the different possibilities for returning
-- information from a method.

6
core/rpc/src/Mu/Rpc/Examples.hs
View File

@ -47,13 +47,13 @@ type QuickStartService
= 'Package ('Just "helloworld")
'[ 'Service "Greeter" '[]
'[ 'Method "SayHello" '[]
'[ 'ArgSingle 'Nothing ('SchemaRef QuickstartSchema "HelloRequest") ]
'[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest") ]
('RetSingle ('SchemaRef QuickstartSchema "HelloResponse"))
, 'Method "SayHi" '[]
'[ 'ArgSingle 'Nothing ('SchemaRef QuickstartSchema "HiRequest")]
'[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HiRequest")]
('RetStream ('SchemaRef QuickstartSchema "HelloResponse"))
, 'Method "SayManyHellos" '[]
'[ 'ArgStream 'Nothing ('SchemaRef QuickstartSchema "HelloRequest")]
'[ 'ArgStream 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest")]
('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ]
newtype HelloRequest f = HelloRequest { name :: f T.Text } deriving (Generic)

4
core/rpc/src/Mu/Server.hs
View File

@ -197,10 +197,10 @@ instance (FromRef w chn ref t, Maybe t ~ s) => FromRef w chn ('OptionalRef ref)
-- Arguments
instance (FromRef w chn ref t, Handles w chn args ret m h,
handler ~ (t -> h))
=> Handles w chn ('ArgSingle aname ref ': args) ret m handler
=> Handles w chn ('ArgSingle aname anns ref ': args) ret m handler
instance (MonadError ServerError m, FromRef w chn ref t, Handles w chn args ret m h,
handler ~ (ConduitT () t m () -> h))
=> Handles w chn ('ArgStream aname ref ': args) ret m handler
=> Handles w chn ('ArgStream aname anns ref ': args) ret m handler
-- Result with exception
instance (MonadError ServerError m, handler ~ m ())
=> Handles w chn '[] 'RetNothing m handler

1
examples/with-persistent/src/Server.hs
View File

@ -3,6 +3,7 @@
{-# language PartialTypeSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
module Main where

1
graphql/mu-graphql.cabal
View File

@ -18,6 +18,7 @@ build-type: Simple
library
exposed-modules:
Mu.GraphQL.Annotations
Mu.GraphQL.Query.Definition
Mu.GraphQL.Query.Parse
Mu.GraphQL.Query.Run

100
graphql/src/Mu/GraphQL/Annotations.hs Normal file
View File

@ -0,0 +1,100 @@
{-# language DataKinds #-}
{-# language FlexibleInstances #-}
{-# language PolyKinds #-}
{-# language ScopedTypeVariables #-}
{-# language TupleSections #-}
{-# language TypeApplications #-}
{-# language TypeOperators #-}
{-# language ViewPatterns #-}
module Mu.GraphQL.Annotations (
ValueConst(..)
, DefaultValue
, ReflectValueConst(..)
, fromGQLValueConst
) where
import Control.Applicative (Alternative (..))
import Data.Coerce
import Data.Proxy
import qualified Data.Text as T
import GHC.TypeLits
import qualified Language.GraphQL.Draft.Syntax as GQL
-- | Specifies the default value of an argument.
-- To be used as an annotation.
data DefaultValue (v :: ValueConst Nat Symbol)
-- Our own constants
data ValueConst nat symbol
= VCInt nat
| VCString symbol
| VCBoolean Bool
| VCNull
| VCEnum symbol
| VCList [ValueConst nat symbol]
| VCObject [(symbol, ValueConst nat symbol)]
-- | Turn a 'GQL.ValueConst' coming from parsing
-- in the annotation data type. Mostly used
-- internally to generate Mu schemas from GraphQL schemas.
fromGQLValueConst :: forall f. Alternative f
=> GQL.ValueConst -> f (ValueConst Integer String)
fromGQLValueConst (GQL.VCInt n)
= pure $ VCInt (fromIntegral n)
fromGQLValueConst (GQL.VCString (coerce -> s))
= pure $ VCString $ T.unpack s
fromGQLValueConst (GQL.VCBoolean b)
= pure $ VCBoolean b
fromGQLValueConst GQL.VCNull
= pure VCNull
fromGQLValueConst (GQL.VCEnum (coerce -> s))
= pure $ VCEnum $ T.unpack s
fromGQLValueConst (GQL.VCList (coerce -> xs))
= VCList <$> traverse fromGQLValueConst xs
fromGQLValueConst (GQL.VCObject (coerce -> o))
= VCObject <$> traverse fromGQLField o
where fromGQLField :: GQL.ObjectFieldG GQL.ValueConst
-> f (String, ValueConst Integer String)
fromGQLField (GQL.ObjectFieldG (coerce -> n) v)
= (T.unpack n,) <$> fromGQLValueConst v
fromGQLValueConst _ = empty
class ReflectValueConst (v :: ValueConst nat symbol) where
-- | Obtain the GraphQL constant corresponding
-- to a type-level constant.
reflectValueConst :: proxy v -> GQL.ValueConst
instance KnownNat n => ReflectValueConst ('VCInt n) where
reflectValueConst _ = GQL.VCInt $ fromInteger $ natVal (Proxy @n)
instance KnownSymbol s => ReflectValueConst ('VCString s) where
reflectValueConst _ = GQL.VCString $ coerce $ T.pack $ symbolVal (Proxy @s)
instance ReflectValueConst ('VCBoolean 'True) where
reflectValueConst _ = GQL.VCBoolean True
instance ReflectValueConst ('VCBoolean 'False) where
reflectValueConst _ = GQL.VCBoolean False
instance ReflectValueConst 'VCNull where
reflectValueConst _ = GQL.VCNull
instance KnownSymbol e => ReflectValueConst ('VCEnum e) where
reflectValueConst _ = GQL.VCString $ coerce $ T.pack $ symbolVal (Proxy @e)
instance ReflectValueConstList xs => ReflectValueConst ('VCList xs) where
reflectValueConst _ = GQL.VCList $ coerce $ reflectValueConstList (Proxy @xs)
instance ReflectValueConstObject xs => ReflectValueConst ('VCObject xs) where
reflectValueConst _ = GQL.VCObject $ coerce $ reflectValueConstObject (Proxy @xs)
class ReflectValueConstList xs where
reflectValueConstList :: proxy xs -> [GQL.ValueConst]
instance ReflectValueConstList '[] where
reflectValueConstList _ = []
instance (ReflectValueConst x, ReflectValueConstList xs)
=> ReflectValueConstList (x ': xs) where
reflectValueConstList _
= reflectValueConst (Proxy @x) : reflectValueConstList (Proxy @xs)
class ReflectValueConstObject xs where
reflectValueConstObject :: proxy xs -> [GQL.ObjectFieldG GQL.ValueConst]
instance ReflectValueConstObject '[] where
reflectValueConstObject _ = []
instance (KnownSymbol a, ReflectValueConst x, ReflectValueConstObject xs)
=> ReflectValueConstObject ( '(a, x) ': xs) where
reflectValueConstObject _
= GQL.ObjectFieldG (coerce $ T.pack $ symbolVal (Proxy @a)) (reflectValueConst (Proxy @x))
: reflectValueConstObject (Proxy @xs)

2
graphql/src/Mu/GraphQL/Query/Definition.hs
View File

@ -36,7 +36,7 @@ data ChosenMethodQuery (p :: Package snm mnm anm) (m :: Method snm mnm anm) wher
-> ChosenMethodQuery p ('Method mname anns args ('RetSingle r))
data ArgumentValue (p :: Package snm mnm anm) (a :: Argument snm anm) where
ArgumentValue :: ArgumentValue' p r -> ArgumentValue p ('ArgSingle aname r)
ArgumentValue :: ArgumentValue' p r -> ArgumentValue p ('ArgSingle aname anns r)
data ArgumentValue' (p :: Package snm mnm anm) (r :: TypeRef snm) where
ArgPrimitive :: t -> ArgumentValue' p ('PrimitiveRef t)

28
graphql/src/Mu/GraphQL/Query/Parse.hs
View File

@ -17,6 +17,7 @@ import Control.Applicative
import Data.Functor.Identity
import qualified Data.HashMap.Strict as HM
import Data.Int (Int32)
import Data.Kind
import Data.List (find)
import Data.Maybe
import Data.Proxy
@ -25,6 +26,7 @@ import qualified Data.Text as T
import GHC.TypeLits
import qualified Language.GraphQL.Draft.Syntax as GQL
import Mu.GraphQL.Annotations
import Mu.GraphQL.Query.Definition
import Mu.Rpc
import Mu.Schema
@ -135,7 +137,6 @@ parseQuery pp ps vmap frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm
parseQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported
= empty
shouldSkip :: VariableMap -> GQL.Directive -> Bool
shouldSkip vmap (GQL.Directive (GQL.unName -> nm) [GQL.Argument (GQL.unName -> ifn) v])
| nm == "skip", ifn == "if"
@ -181,13 +182,30 @@ class ParseArgs (p :: Package') (args :: [Argument']) where
instance ParseArgs p '[] where
parseArgs _ _ = pure Nil
instance (KnownName aname, ParseArg p a, ParseArgs p as)
=> ParseArgs p ('ArgSingle aname a ': as) where
instance (KnownName aname, ParseArg p a, ParseArgs p as, FindDefaultArgValue aanns)
=> ParseArgs p ('ArgSingle aname aanns a ': as) where
parseArgs vmap args
= case find ((== nameVal (Proxy @aname)) . T.unpack . GQL.unName . GQL._aName) args of
Just (GQL.Argument _ x)
-> (:*) <$> (ArgumentValue <$> parseArg' vmap x) <*> parseArgs vmap args
Nothing -> empty
-> (:*) <$> (ArgumentValue <$> parseArg' vmap x)
<*> parseArgs vmap args
Nothing -> case findDefaultArgValue (Proxy @aanns) of
Just x -> (:*) <$> (ArgumentValue <$> parseArg' vmap (constToValue x))
<*> parseArgs vmap args
Nothing -> empty
class FindDefaultArgValue (vs :: [Type]) where
findDefaultArgValue :: Alternative f
=> Proxy vs
-> f GQL.ValueConst
instance FindDefaultArgValue '[] where
findDefaultArgValue _ = empty
instance {-# OVERLAPPABLE #-} FindDefaultArgValue xs
=> FindDefaultArgValue (x ': xs) where
findDefaultArgValue _ = findDefaultArgValue (Proxy @xs)
instance {-# OVERLAPS #-} ReflectValueConst v
=> FindDefaultArgValue (DefaultValue v ': xs) where
findDefaultArgValue _ = pure $ reflectValueConst (Proxy @v)
parseArg' :: (ParseArg p a, Alternative f)
=> VariableMap

2
graphql/src/Mu/GraphQL/Query/Run.hs
View File

@ -165,7 +165,7 @@ class Handles Identity chn args ('RetSingle r) ServerErrorIO h
-> WriterT [GraphQLError] IO (Maybe Aeson.Value)
instance (ArgumentConversion chn ref t, RunHandler p whole chn rest r h)
=> RunHandler p whole chn ('ArgSingle aname ref ': rest) r (t -> h) where
=> RunHandler p whole chn ('ArgSingle aname aanns ref ': rest) r (t -> h) where
runHandler whole h (ArgumentValue one :* rest)
= runHandler whole (h (convertArg (Proxy @chn) one)) rest
instance (ResultConversion p whole chn r l)

15
grpc/client/src/Mu/GRpc/Client/Internal.hs
View File

@ -183,7 +183,8 @@ instance ( KnownName name
instance ( KnownName name
, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ()
, handler ~ (v -> IO (GRpcReply ())) )
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname vref ] 'RetNothing) handler where
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]
'RetNothing) handler where
gRpcMethodCall rpc _ client x
= simplifyResponse $
buildGRpcReply1 <$>
@ -192,7 +193,8 @@ instance ( KnownName name
instance ( KnownName name
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
, handler ~ (v -> IO (GRpcReply r)) )
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname vref ] ('RetSingle rref)) handler where
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]
('RetSingle rref)) handler where
gRpcMethodCall rpc _ client x
= fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $
simplifyResponse $
@ -203,7 +205,8 @@ instance ( KnownName name
instance ( KnownName name
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
, handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply r))) )
=> GRpcMethodCall p ('Method name anns '[ 'ArgStream aname vref ] ('RetSingle rref)) handler where
=> GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns vref ]
('RetSingle rref)) handler where
gRpcMethodCall rpc _ client compress
= do -- Create a new TMChan
chan <- newTMChanIO :: IO (TMChan v)
@ -229,7 +232,8 @@ instance ( KnownName name
instance ( KnownName name
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
, handler ~ (v -> IO (ConduitT () (GRpcReply r) IO ())) )
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname vref ] ('RetStream rref)) handler where
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]
('RetStream rref)) handler where
gRpcMethodCall rpc _ client x
= do -- Create a new TMChan
chan <- newTMChanIO :: IO (TMChan r)
@ -258,7 +262,8 @@ instance ( KnownName name
instance ( KnownName name
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
, handler ~ (CompressMode -> IO (ConduitT v (GRpcReply r) IO ())) )
=> GRpcMethodCall p ('Method name anns '[ 'ArgStream aname vref ] ('RetStream rref)) handler where
=> GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aans vref ]
('RetStream rref)) handler where
gRpcMethodCall rpc _ client compress
= do -- Create a new TMChan
inchan <- newTMChanIO :: IO (TMChan (GRpcReply r))

30
grpc/client/src/Mu/GRpc/Client/Optics.hs
View File

@ -130,36 +130,36 @@ instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) ann
, t ~ IO (ConduitT () (GRpcReply (Term w sch (sch :/: r))) IO ()) )
=> MethodOptic p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t
-- Simple arguments
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) aname anns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname ('SchemaRef sch v) ] 'RetNothing) t
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) aname anns aanns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] 'RetNothing) t
, ProtocolWrapper p w
, t ~ (Term w sch (sch :/: v) -> IO (GRpcReply ())) )
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname ('SchemaRef sch v) ] 'RetNothing) t
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] 'RetNothing) t
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
, ProtocolWrapper p w
, t ~ (Term w sch (sch :/: v)
-> IO (GRpcReply (Term w sch (sch :/: r))) ) )
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
, ProtocolWrapper p w
, t ~ (Term w sch (sch :/: v)
-> IO (ConduitT () (GRpcReply (Term Maybe sch (sch :/: r))) IO ()) ) )
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
-- Stream arguments
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
, ProtocolWrapper p w
, t ~ (CompressMode
-> IO (ConduitT (Term w sch (sch :/: v))
Void IO
(GRpcReply (Term w sch (sch :/: r))))) )
=> MethodOptic p ('Method name anns '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
=> MethodOptic p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p w.
( GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
, ProtocolWrapper p w
, t ~ (CompressMode
-> IO (ConduitT (Term w sch (sch :/: v))
(GRpcReply (Term w sch (sch :/: r))) IO ())) )
=> MethodOptic p ('Method name anns '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
=> MethodOptic p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t

18
grpc/client/src/Mu/GRpc/Client/Record.hs
View File

@ -128,15 +128,15 @@ computeMethodType _ [] RetNothing
= [t|IO (GRpcReply ())|]
computeMethodType n [] (RetSingle r)
= [t|IO (GRpcReply $(typeRefToType n r))|]
computeMethodType n [ArgSingle _ v] RetNothing
computeMethodType n [ArgSingle _ _ v] RetNothing
= [t|$(typeRefToType n v) -> IO (GRpcReply ())|]
computeMethodType n [ArgSingle _ v] (RetSingle r)
computeMethodType n [ArgSingle _ _ v] (RetSingle r)
= [t|$(typeRefToType n v) -> IO (GRpcReply $(typeRefToType n r))|]
computeMethodType n [ArgStream _ v] (RetSingle r)
computeMethodType n [ArgStream _ _ v] (RetSingle r)
= [t|CompressMode -> IO (ConduitT $(typeRefToType n v) Void IO (GRpcReply $(typeRefToType n r)))|]
computeMethodType n [ArgSingle _ v] (RetStream r)
computeMethodType n [ArgSingle _ _ v] (RetStream r)
= [t|$(typeRefToType n v) -> IO (ConduitT () (GRpcReply $(typeRefToType n r)) IO ())|]
computeMethodType n [ArgStream _ v] (RetStream r)
computeMethodType n [ArgStream _ _ v] (RetStream r)
= [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|]
computeMethodType _ _ _ = fail "method signature not supported"
@ -184,10 +184,10 @@ typeToServiceDef toplevelty
typeToArgDef :: Type -> Maybe (Argument String String)
typeToArgDef ty
= (do (n, t) <- tyD2 'ArgSingle ty
ArgSingle <$> tyMaybeString n <*> typeToTypeRef t)
<|> (do (n, t) <- tyD2 'ArgStream ty
ArgStream <$> tyMaybeString n <*> typeToTypeRef t)
= (do (n, _, t) <- tyD3 'ArgSingle ty
ArgSingle <$> tyMaybeString n <*> pure [] <*> typeToTypeRef t)
<|> (do (n, _, t) <- tyD3 'ArgStream ty
ArgStream <$> tyMaybeString n <*> pure [] <*> typeToTypeRef t)
typeToRetDef :: Type -> Maybe (Return String)
typeToRetDef ty

10
grpc/server/src/Mu/GRpc/Server.hs
View File

@ -311,7 +311,7 @@ instance (GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r, MonadIO m)
-----
instance (GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ())
=> GRpcMethodHandler p m '[ 'ArgSingle aname vref ] 'RetNothing (v -> m ()) where
=> GRpcMethodHandler p m '[ 'ArgSingle aname anns vref ] 'RetNothing (v -> m ()) where
gRpcMethodHandler f _ _ _ rpc h
= unary @_ @(GRpcIWTy p vref v) @()
rpc (\_ -> raiseErrors . f . h . unGRpcIWTy (Proxy @p) (Proxy @vref))
@ -319,7 +319,7 @@ instance (GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ())
-----
instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r)
=> GRpcMethodHandler p m '[ 'ArgSingle aname vref ] ('RetSingle rref) (v -> m r) where
=> GRpcMethodHandler p m '[ 'ArgSingle aname anns vref ] ('RetSingle rref) (v -> m r) where
gRpcMethodHandler f _ _ _ rpc h
= unary @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r)
rpc (\_ -> (buildGRpcOWTy (Proxy @p) (Proxy @rref) <$>)
@ -329,7 +329,7 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r)
-----
instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
=> GRpcMethodHandler p m '[ 'ArgStream aname vref ] ('RetSingle rref)
=> GRpcMethodHandler p m '[ 'ArgStream aname anns vref ] ('RetSingle rref)
(ConduitT () v m () -> m r) where
gRpcMethodHandler f _ _ _ rpc h
= clientStream @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r)
@ -354,7 +354,7 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
-----
instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
=> GRpcMethodHandler p m '[ 'ArgSingle aname vref ] ('RetStream rref)
=> GRpcMethodHandler p m '[ 'ArgSingle aname anns vref ] ('RetStream rref)
(v -> ConduitT r Void m () -> m ()) where
gRpcMethodHandler f _ _ _ rpc h
= serverStream @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r)
@ -379,7 +379,7 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
-----
instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
=> GRpcMethodHandler p m '[ 'ArgStream aname vref ] ('RetStream rref)
=> GRpcMethodHandler p m '[ 'ArgStream aname anns vref ] ('RetStream rref)
(ConduitT () v m () -> ConduitT r Void m () -> m ()) where
gRpcMethodHandler f _ _ _ rpc h
= generalStream @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r)