mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Support default values in GraphQL schemas (#129)
This commit is contained in:
parent
01ca1363e4
commit
f9b1c9b4ce
@ -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"
|
||||
|
||||
|
@ -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"
|
||||
|
||||
|
@ -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.
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -3,6 +3,7 @@
|
||||
{-# language PartialTypeSignatures #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
|
||||
|
||||
module Main where
|
||||
|
||||
|
@ -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
100
graphql/src/Mu/GraphQL/Annotations.hs
Normal 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)
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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))
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user