mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-08-17 02:10:22 +03:00
New API to support GraphQL resolvers as services (#111)
Co-authored-by: Flavio Corpa <flavio.corpa@47deg.com>
This commit is contained in:
parent
551b777b87
commit
c1c23326ef
@ -197,7 +197,7 @@ instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t))
|
||||
fromAvro v = TSimple <$> A.fromAvro v
|
||||
|
||||
instance A.FromAvro (FieldValue f sch 'TNull) where
|
||||
fromAvro AVal.Null = return FNull
|
||||
fromAvro AVal.Null = pure FNull
|
||||
fromAvro v = A.badValue v "null"
|
||||
instance A.FromAvro t => A.FromAvro (FieldValue f sch ('TPrimitive t)) where
|
||||
fromAvro v = FPrimitive <$> A.fromAvro v
|
||||
@ -228,7 +228,7 @@ class FromAvroEnum (vs :: [ChoiceDef fn]) where
|
||||
instance FromAvroEnum '[] where
|
||||
fromAvroEnum v _ = A.badValue v "element not found"
|
||||
instance FromAvroEnum vs => FromAvroEnum (v ': vs) where
|
||||
fromAvroEnum _ 0 = return (Z Proxy)
|
||||
fromAvroEnum _ 0 = pure (Z Proxy)
|
||||
fromAvroEnum v n = S <$> fromAvroEnum v (n-1)
|
||||
|
||||
class FromAvroUnion f sch choices where
|
||||
@ -246,7 +246,7 @@ instance (A.FromAvro (FieldValue f sch u), FromAvroUnion f sch us)
|
||||
class FromAvroFields f sch (fs :: [FieldDef Symbol Symbol]) where
|
||||
fromAvroF :: HM.HashMap T.Text (AVal.Value ASch.Schema) -> A.Result (NP (Field f sch) fs)
|
||||
instance FromAvroFields f sch '[] where
|
||||
fromAvroF _ = return Nil
|
||||
fromAvroF _ = pure Nil
|
||||
instance (Applicative f, KnownName name, A.FromAvro (FieldValue f sch t), FromAvroFields f sch fs)
|
||||
=> FromAvroFields f sch ('FieldDef name t ': fs) where
|
||||
fromAvroF v = case HM.lookup fieldName v of
|
||||
|
@ -88,13 +88,15 @@ avdlToDecls schemaName serviceName protocol
|
||||
serviceName' = mkName serviceName
|
||||
schemaDec <- tySynD schemaName' [] (schemaFromAvro $ S.toList (A.types protocol))
|
||||
serviceDec <- tySynD serviceName' []
|
||||
[t| 'Service $(textToStrLit (A.pname protocol)) $(pkgType (A.ns protocol))
|
||||
$(typesToList <$> mapM (avroMethodToType schemaName') (S.toList $ A.messages protocol)) |]
|
||||
return [schemaDec, serviceDec]
|
||||
[t| 'Package $(pkgType (A.ns protocol))
|
||||
'[ 'Service $(textToStrLit (A.pname protocol)) '[]
|
||||
$(typesToList <$> mapM (avroMethodToType schemaName')
|
||||
(S.toList $ A.messages protocol)) ] |]
|
||||
pure [schemaDec, serviceDec]
|
||||
where
|
||||
pkgType Nothing = [t| '[] |]
|
||||
pkgType Nothing = [t| 'Nothing |]
|
||||
pkgType (Just (A.Namespace p))
|
||||
= [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]
|
||||
= [t| 'Just $(textToStrLit (T.intercalate "." p)) |]
|
||||
|
||||
schemaFromAvro :: [A.Schema] -> Q Type
|
||||
schemaFromAvro =
|
||||
@ -181,7 +183,7 @@ avroMethodToType schemaName m
|
||||
where
|
||||
argToType :: A.Argument -> Q Type
|
||||
argToType (A.Argument (A.NamedType a) _)
|
||||
= [t| 'ArgSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |]
|
||||
= [t| 'ArgSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
|
||||
argToType (A.Argument _ _)
|
||||
= fail "only named types may be used as arguments"
|
||||
|
||||
@ -189,7 +191,7 @@ avroMethodToType schemaName m
|
||||
retToType A.Null
|
||||
= [t| 'RetNothing |]
|
||||
retToType (A.NamedType a)
|
||||
= [t| 'RetSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |]
|
||||
= [t| 'RetSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
|
||||
retToType _
|
||||
= fail "only named types may be used as results"
|
||||
|
||||
@ -197,4 +199,4 @@ typesToList :: [Type] -> Type
|
||||
typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||
|
||||
textToStrLit :: T.Text -> Q Type
|
||||
textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s
|
||||
textToStrLit s = litT $ strTyLit $ T.unpack s
|
||||
|
@ -225,7 +225,7 @@ instance ProtoBridgeTerm w sch ('DRecord name args)
|
||||
t <- PBDec.embedded (protoToTerm @_ @_ @w @sch @('DRecord name args))
|
||||
case t of
|
||||
Nothing -> PBDec.Parser (\_ -> Left (PBDec.WireTypeError "expected message"))
|
||||
Just v -> return v
|
||||
Just v -> pure v
|
||||
embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @w @sch @('DRecord name args))
|
||||
|
||||
-- ENUMERATIONS
|
||||
@ -256,7 +256,7 @@ instance (KnownNat (FindProtoBufId sch ty c), ProtoBridgeEnum sch ty cs)
|
||||
where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))
|
||||
enumToProto fid (S v) = enumToProto @_ @_ @sch @ty fid v
|
||||
protoToEnum n
|
||||
| n == enumValue = return (Z Proxy)
|
||||
| n == enumValue = pure (Z Proxy)
|
||||
| otherwise = S <$> protoToEnum @_ @_ @sch @ty n
|
||||
where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))
|
||||
|
||||
|
@ -28,11 +28,11 @@ import Mu.Schema
|
||||
|
||||
-- | Specifies that a type is turned into a Protocol Buffers
|
||||
-- message by using the schema as intermediate representation.
|
||||
newtype ViaToProtoBufTypeRef (ref :: TypeRef) t
|
||||
newtype ViaToProtoBufTypeRef (ref :: TypeRef snm) t
|
||||
= ViaToProtoBufTypeRef { unViaToProtoBufTypeRef :: t }
|
||||
-- | Specifies that a type can be parsed from a Protocol Buffers
|
||||
-- message by using the schema as intermediate representation.
|
||||
newtype ViaFromProtoBufTypeRef (ref :: TypeRef) t
|
||||
newtype ViaFromProtoBufTypeRef (ref :: TypeRef snm) t
|
||||
= ViaFromProtoBufTypeRef { unViaFromProtoBufTypeRef :: t }
|
||||
|
||||
instance ToProtoBufTypeRef ref t
|
||||
@ -46,29 +46,29 @@ instance FromProtoBufTypeRef ref t
|
||||
|
||||
instance Proto3WireEncoder () where
|
||||
proto3WireEncode _ = mempty
|
||||
proto3WireDecode = return ()
|
||||
proto3WireDecode = pure ()
|
||||
|
||||
-- | Types which can be parsed from a Protocol Buffers message.
|
||||
class FromProtoBufTypeRef (ref :: TypeRef) t where
|
||||
class FromProtoBufTypeRef (ref :: TypeRef snm) t where
|
||||
fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t
|
||||
-- | Types which can be turned into a Protocol Buffers message.
|
||||
class ToProtoBufTypeRef (ref :: TypeRef) t where
|
||||
class ToProtoBufTypeRef (ref :: TypeRef snm) t where
|
||||
toProtoBufTypeRef :: Proxy ref -> t -> PBEnc.MessageBuilder
|
||||
|
||||
instance (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty t)
|
||||
=> FromProtoBufTypeRef ('ViaSchema sch sty) t where
|
||||
=> FromProtoBufTypeRef ('SchemaRef sch sty) t where
|
||||
fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch
|
||||
instance (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty t)
|
||||
=> ToProtoBufTypeRef ('ViaSchema sch sty) t where
|
||||
=> ToProtoBufTypeRef ('SchemaRef sch sty) t where
|
||||
toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @sch
|
||||
|
||||
instance ( FromProtoBufRegistry r t
|
||||
, IsProtoSchema Maybe (MappingRight r last) sty
|
||||
, FromSchema Maybe (MappingRight r last) sty t )
|
||||
=> FromProtoBufTypeRef ('ViaRegistry r t last) t where
|
||||
=> FromProtoBufTypeRef ('RegistryRef r t last) t where
|
||||
fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r
|
||||
instance ( FromProtoBufRegistry r t
|
||||
, IsProtoSchema Maybe (MappingRight r last) sty
|
||||
, ToSchema Maybe (MappingRight r last) sty t )
|
||||
=> ToProtoBufTypeRef ('ViaRegistry r t last) t where
|
||||
=> ToProtoBufTypeRef ('RegistryRef r t last) t where
|
||||
toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last)
|
||||
|
@ -60,7 +60,7 @@ grpcToDecls schemaName servicePrefix p@P.ProtoBuf { P.package = pkg, P.services
|
||||
= do let schemaName' = mkName schemaName
|
||||
schemaDec <- protobufToDecls schemaName p
|
||||
serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs
|
||||
return (schemaDec ++ serviceTy)
|
||||
pure (schemaDec ++ serviceTy)
|
||||
|
||||
pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec
|
||||
pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)
|
||||
@ -69,11 +69,12 @@ pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)
|
||||
|
||||
pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type
|
||||
pbServiceDeclToType pkg schema (P.Service nm _ methods)
|
||||
= [t| 'Service $(textToStrLit nm) $(pkgType pkg)
|
||||
$(typesToList <$> mapM (pbMethodToType schema) methods) |]
|
||||
= [t| 'Package $(pkgType pkg)
|
||||
'[ 'Service $(textToStrLit nm) '[]
|
||||
$(typesToList <$> mapM (pbMethodToType schema) methods) ] |]
|
||||
where
|
||||
pkgType Nothing = [t| '[] |]
|
||||
pkgType (Just p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]
|
||||
pkgType Nothing = [t| 'Nothing |]
|
||||
pkgType (Just p) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]
|
||||
|
||||
pbMethodToType :: Name -> P.Method -> Q Type
|
||||
pbMethodToType s (P.Method nm vr v rr r _)
|
||||
@ -83,27 +84,27 @@ 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 ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||
= [t| '[ 'ArgSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||
argToType P.Stream (P.TOther a)
|
||||
= [t| '[ 'ArgStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||
= [t| '[ 'ArgStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||
argToType _ _
|
||||
= fail "only message types may be used as arguments"
|
||||
|
||||
retToType P.Single (P.TOther ["google","protobuf","Empty"])
|
||||
= [t| 'RetNothing |]
|
||||
retToType P.Single (P.TOther a)
|
||||
= [t| 'RetSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]
|
||||
= [t| 'RetSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |]
|
||||
retToType P.Stream (P.TOther a)
|
||||
= [t| 'RetStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]
|
||||
= [t| 'RetStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |]
|
||||
retToType _ _
|
||||
= fail "only message types may be used as results"
|
||||
|
||||
schemaTy :: Name -> Q Type
|
||||
schemaTy schema = return $ ConT schema
|
||||
schemaTy schema = pure $ ConT schema
|
||||
|
||||
typesToList :: [Type] -> Type
|
||||
typesToList
|
||||
= foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||
textToStrLit :: T.Text -> Q Type
|
||||
textToStrLit s
|
||||
= return $ LitT $ StrTyLit $ T.unpack s
|
||||
= pure $ LitT $ StrTyLit $ T.unpack s
|
||||
|
@ -26,8 +26,8 @@ import Language.ProtocolBuffers.Parser
|
||||
import qualified Language.ProtocolBuffers.Types as P
|
||||
|
||||
import Mu.Adapter.ProtoBuf
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Annotations
|
||||
import Mu.Schema.Definition
|
||||
|
||||
-- | Reads a @.proto@ file and generates a 'Mu.Schema.Definition.Schema'
|
||||
-- with all the message types, using the name given
|
||||
@ -46,22 +46,22 @@ protobufToDecls :: String -> P.ProtoBuf -> Q [Dec]
|
||||
protobufToDecls schemaName p
|
||||
= do let schemaName' = mkName schemaName
|
||||
(schTy, annTy) <- schemaFromProtoBuf p
|
||||
schemaDec <- tySynD schemaName' [] (return schTy)
|
||||
schemaDec <- tySynD schemaName' [] (pure schTy)
|
||||
#if MIN_VERSION_template_haskell(2,15,0)
|
||||
annDec <- tySynInstD (tySynEqn Nothing
|
||||
[t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |]
|
||||
(return annTy))
|
||||
(pure annTy))
|
||||
#else
|
||||
annDec <- tySynInstD ''AnnotatedSchema
|
||||
(tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (return annTy))
|
||||
(tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (pure annTy))
|
||||
#endif
|
||||
return [schemaDec, annDec]
|
||||
pure [schemaDec, annDec]
|
||||
|
||||
schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type)
|
||||
schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do
|
||||
let decls = flattenDecls tys
|
||||
(schTys, anns) <- unzip <$> mapM pbTypeDeclToType decls
|
||||
return (typesToList schTys, typesToList (concat anns))
|
||||
pure (typesToList schTys, typesToList (concat anns))
|
||||
|
||||
flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration]
|
||||
flattenDecls = concatMap flattenDecl
|
||||
@ -73,7 +73,7 @@ flattenDecls = concatMap flattenDecl
|
||||
pbTypeDeclToType :: P.TypeDeclaration -> Q (Type, [Type])
|
||||
pbTypeDeclToType (P.DEnum name _ fields) = do
|
||||
(tys, anns) <- unzip <$> mapM pbChoiceToType fields
|
||||
(,) <$> [t|'DEnum $(textToStrLit name) $(return $ typesToList tys)|] <*> pure anns
|
||||
(,) <$> [t|'DEnum $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns
|
||||
where
|
||||
pbChoiceToType :: P.EnumField -> Q (Type, Type)
|
||||
pbChoiceToType (P.EnumField nm number _)
|
||||
@ -138,7 +138,7 @@ typesToList :: [Type] -> Type
|
||||
typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||
|
||||
textToStrLit :: T.Text -> Q Type
|
||||
textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s
|
||||
textToStrLit s = pure $ LitT $ StrTyLit $ T.unpack s
|
||||
|
||||
intToLit :: Int -> Q Type
|
||||
intToLit n = return $ LitT $ NumTyLit $ toInteger n
|
||||
intToLit n = pure $ LitT $ NumTyLit $ toInteger n
|
||||
|
2
cabal-fmt.sh
Normal file → Executable file
2
cabal-fmt.sh
Normal file → Executable file
@ -1 +1 @@
|
||||
find . -name '*.cabal' -exec sh -c 'cabal-fmt $0 > output.tmp; mv output.tmp $0' {} ';'
|
||||
find . -name '*.cabal' -exec sh -c 'cabal-fmt -i $0' {} ';'
|
||||
|
@ -16,3 +16,4 @@ packages: compendium-client/
|
||||
grpc/common/
|
||||
grpc/client/
|
||||
grpc/server/
|
||||
graphql/
|
||||
|
@ -79,8 +79,8 @@ obtainProtoBuf m url ident = do
|
||||
r <- transformation m url ident Protobuf
|
||||
case r of
|
||||
Left e
|
||||
-> return $ Left (OPEClient e)
|
||||
-> pure $ Left (OPEClient e)
|
||||
Right p
|
||||
-> case parseProtoBuf p of
|
||||
Left e -> return $ Left (OPEParse e)
|
||||
Right pb -> return $ Right pb
|
||||
Left e -> pure $ Left (OPEParse e)
|
||||
Right pb -> pure $ Right pb
|
||||
|
@ -14,9 +14,10 @@ RPC-like microservices independently of the transport
|
||||
and protocol.
|
||||
-}
|
||||
module Mu.Rpc (
|
||||
Service', Service(..)
|
||||
, ServiceAnnotation, Package, FindPackageName
|
||||
, Method(..), (:-->:)
|
||||
Package', Package(..)
|
||||
, Service', Service(..), Object
|
||||
, ServiceAnnotation, Method(..), ObjectField
|
||||
, LookupService, LookupMethod
|
||||
, TypeRef(..), Argument(..), Return(..)
|
||||
) where
|
||||
|
||||
@ -27,66 +28,82 @@ import qualified Language.Haskell.TH as TH
|
||||
import Mu.Schema
|
||||
import Mu.Schema.Registry
|
||||
|
||||
-- | Packages whose names are given by type-level strings.
|
||||
type Package' = Package Symbol Symbol
|
||||
-- | Services whose names are given by type-level strings.
|
||||
type Service' = Service Symbol Symbol
|
||||
-- | Annotations for services. At this moment, such
|
||||
-- annotations can be of any type.
|
||||
type ServiceAnnotation = Type
|
||||
|
||||
-- | A package is a set of services.
|
||||
data Package serviceName methodName
|
||||
= Package (Maybe serviceName)
|
||||
[Service serviceName methodName]
|
||||
|
||||
-- | A service is a set of methods.
|
||||
data Service serviceName methodName
|
||||
= Service serviceName [ServiceAnnotation] [Method methodName]
|
||||
|
||||
-- | An annotation to define a package name.
|
||||
-- This is used by some handlers, like gRPC.
|
||||
data Package (s :: Symbol)
|
||||
|
||||
-- | Find the 'Package' for a service, to be found
|
||||
-- as part of the annotations.
|
||||
type family FindPackageName (anns :: [ServiceAnnotation]) :: Symbol where
|
||||
FindPackageName '[] = TypeError ('Text "Cannot find package name for the service")
|
||||
FindPackageName (Package s ': rest) = s
|
||||
FindPackageName (other ': rest) = FindPackageName rest
|
||||
= Service serviceName
|
||||
[ServiceAnnotation]
|
||||
[Method serviceName methodName]
|
||||
|
||||
-- | A method is defined by its name, arguments, and return type.
|
||||
data Method methodName
|
||||
= Method methodName [ServiceAnnotation] [Argument] Return
|
||||
data Method serviceName methodName
|
||||
= Method methodName [ServiceAnnotation]
|
||||
[Argument serviceName]
|
||||
(Return serviceName)
|
||||
|
||||
-- Synonyms for GraphQL
|
||||
-- | An object is a set of fields, in GraphQL lingo.
|
||||
type Object = 'Service
|
||||
-- | A field in an object takes some input objects,
|
||||
-- and returns a value or some other object,
|
||||
-- in GraphQL lingo.
|
||||
type ObjectField = 'Method
|
||||
|
||||
type family LookupService (ss :: [Service snm mnm]) (s :: snm) :: Service snm mnm where
|
||||
LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s)
|
||||
LookupService ('Service s anns ms ': ss) s = 'Service s anns ms
|
||||
LookupService (other ': ss) s = LookupService ss s
|
||||
|
||||
-- | Look up a method in a service definition using its name.
|
||||
-- Useful to declare handlers like @HandlerIO (MyService :-->: "MyMethod")@.
|
||||
type family (:-->:) (s :: Service snm mnm) (m :: mnm) :: Method mnm where
|
||||
'Service sname anns methods :-->: m = LookupMethod methods m
|
||||
|
||||
type family LookupMethod (s :: [Method mnm]) (m :: snm) :: Method snm where
|
||||
type family LookupMethod (s :: [Method snm mnm]) (m :: mnm) :: Method snm mnm where
|
||||
LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m)
|
||||
LookupMethod ('Method m anns args r ': ms) m = 'Method m anns args r
|
||||
LookupMethod (other ': ms) m = LookupMethod ms m
|
||||
|
||||
-- | Defines how to handle the type
|
||||
data TypeRef where
|
||||
ViaSchema :: Schema typeName fieldName -> typeName -> TypeRef
|
||||
data TypeRef serviceName where
|
||||
-- | A primitive type.
|
||||
PrimitiveRef :: Type -> TypeRef serviceName
|
||||
-- | Chain with another service.
|
||||
ObjectRef :: serviceName -> TypeRef serviceName
|
||||
-- | Point to schema.
|
||||
SchemaRef :: Schema typeName fieldName -> typeName -> TypeRef serviceName
|
||||
-- | Registry subject, type to convert to, and preferred serialization version
|
||||
ViaRegistry :: Registry -> Type -> Nat -> TypeRef
|
||||
RegistryRef :: Registry -> Type -> Nat -> TypeRef serviceName
|
||||
-- | To be used only during TH generation!
|
||||
ViaTH :: TH.Type -> TypeRef
|
||||
THRef :: TH.Type -> TypeRef serviceName
|
||||
-- Combinators found in the gRPC and GraphQL languages.
|
||||
-- | Represents a list of values.
|
||||
ListRef :: TypeRef serviceName -> TypeRef serviceName
|
||||
-- | Represents a possibly-missing value.
|
||||
OptionalRef :: TypeRef serviceName -> TypeRef serviceName
|
||||
|
||||
-- | Defines the way in which arguments are handled.
|
||||
data Argument where
|
||||
data Argument serviceName where
|
||||
-- | Use a single value.
|
||||
ArgSingle :: TypeRef -> Argument
|
||||
ArgSingle :: TypeRef serviceName -> Argument serviceName
|
||||
-- | Consume a stream of values.
|
||||
ArgStream :: TypeRef -> Argument
|
||||
ArgStream :: TypeRef serviceName -> Argument serviceName
|
||||
|
||||
-- | Defines the different possibilities for returning
|
||||
-- information from a method.
|
||||
data Return where
|
||||
data Return serviceName where
|
||||
-- | Fire and forget.
|
||||
RetNothing :: Return
|
||||
RetNothing :: Return serviceName
|
||||
-- | Return a single value.
|
||||
RetSingle :: TypeRef -> Return
|
||||
-- | Return a value or an error
|
||||
-- (this can be found in Avro IDL).
|
||||
RetThrows :: TypeRef -> TypeRef -> Return
|
||||
-- | Return a stream of values
|
||||
-- (this can be found in gRPC).
|
||||
RetStream :: TypeRef -> Return
|
||||
RetSingle :: TypeRef serviceName -> Return serviceName
|
||||
-- | Return a stream of values.
|
||||
RetStream :: TypeRef serviceName -> Return serviceName
|
||||
-- | Return a value or an error.
|
||||
RetThrows :: TypeRef serviceName -> TypeRef serviceName -> Return serviceName
|
||||
|
@ -36,24 +36,25 @@ import Mu.Server
|
||||
|
||||
type QuickstartSchema
|
||||
= '[ 'DRecord "HelloRequest"
|
||||
'[ 'FieldDef "name" ('TPrimitive T.Text) ]
|
||||
'[ 'FieldDef "name" ('TPrimitive T.Text) ]
|
||||
, 'DRecord "HelloResponse"
|
||||
'[ 'FieldDef "message" ('TPrimitive T.Text) ]
|
||||
'[ 'FieldDef "message" ('TPrimitive T.Text) ]
|
||||
, 'DRecord "HiRequest"
|
||||
'[ 'FieldDef "number" ('TPrimitive Int) ]
|
||||
'[ 'FieldDef "number" ('TPrimitive Int) ]
|
||||
]
|
||||
|
||||
type QuickStartService
|
||||
= 'Service "Greeter" '[Package "helloworld"]
|
||||
'[ 'Method "SayHello" '[]
|
||||
'[ 'ArgSingle ('ViaSchema QuickstartSchema "HelloRequest") ]
|
||||
('RetSingle ('ViaSchema QuickstartSchema "HelloResponse"))
|
||||
, 'Method "SayHi" '[]
|
||||
'[ 'ArgSingle ('ViaSchema QuickstartSchema "HiRequest")]
|
||||
('RetStream ('ViaSchema QuickstartSchema "HelloResponse"))
|
||||
, 'Method "SayManyHellos" '[]
|
||||
'[ 'ArgStream ('ViaSchema QuickstartSchema "HelloRequest")]
|
||||
('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) ]
|
||||
= 'Package ('Just "helloworld")
|
||||
'[ 'Service "Greeter" '[]
|
||||
'[ 'Method "SayHello" '[]
|
||||
'[ 'ArgSingle ('SchemaRef QuickstartSchema "HelloRequest") ]
|
||||
('RetSingle ('SchemaRef QuickstartSchema "HelloResponse"))
|
||||
, 'Method "SayHi" '[]
|
||||
'[ 'ArgSingle ('SchemaRef QuickstartSchema "HiRequest")]
|
||||
('RetStream ('SchemaRef QuickstartSchema "HelloResponse"))
|
||||
, 'Method "SayManyHellos" '[]
|
||||
'[ 'ArgStream ('SchemaRef QuickstartSchema "HelloRequest")]
|
||||
('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ]
|
||||
|
||||
newtype HelloRequest f = HelloRequest { name :: f T.Text } deriving (Generic)
|
||||
deriving instance Functor f => ToSchema f QuickstartSchema "HelloRequest" (HelloRequest f)
|
||||
@ -69,21 +70,62 @@ deriving instance Functor f => FromSchema f QuickstartSchema "HiRequest" (HiRequ
|
||||
|
||||
quickstartServer :: forall m f.
|
||||
(MonadServer m, Applicative f, MaybeLike f)
|
||||
=> ServerT f QuickStartService m _
|
||||
=> ServerT f '[] QuickStartService m _
|
||||
quickstartServer
|
||||
= Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)
|
||||
where sayHello :: HelloRequest f -> m (HelloResponse f)
|
||||
sayHello (HelloRequest nm)
|
||||
= return (HelloResponse (("hi, " <>) <$> nm))
|
||||
sayHi :: HiRequest f
|
||||
-> ConduitT (HelloResponse f) Void m ()
|
||||
-> m ()
|
||||
sayHi (HiRequest (likeMaybe -> Just n)) sink
|
||||
= runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink
|
||||
sayHi (HiRequest _) sink
|
||||
= runConduit $ return () .| sink
|
||||
sayManyHellos :: ConduitT () (HelloRequest f) m ()
|
||||
-> ConduitT (HelloResponse f) Void m ()
|
||||
-> m ()
|
||||
sayManyHellos source sink
|
||||
= runConduit $ source .| C.mapM sayHello .| sink
|
||||
where
|
||||
sayHello :: HelloRequest f -> m (HelloResponse f)
|
||||
sayHello (HelloRequest nm)
|
||||
= pure (HelloResponse (("hi, " <>) <$> nm))
|
||||
sayHi :: HiRequest f
|
||||
-> ConduitT (HelloResponse f) Void m ()
|
||||
-> m ()
|
||||
sayHi (HiRequest (likeMaybe -> Just n)) sink
|
||||
= runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink
|
||||
sayHi (HiRequest _) sink
|
||||
= runConduit $ pure () .| sink
|
||||
sayManyHellos :: ConduitT () (HelloRequest f) m ()
|
||||
-> ConduitT (HelloResponse f) Void m ()
|
||||
-> m ()
|
||||
sayManyHellos source sink
|
||||
= runConduit $ source .| C.mapM sayHello .| sink
|
||||
|
||||
{-
|
||||
From https://www.apollographql.com/docs/apollo-server/schema/schema/
|
||||
|
||||
type Book {
|
||||
title: String
|
||||
author: Author
|
||||
}
|
||||
|
||||
type Author {
|
||||
name: String
|
||||
books: [Book]
|
||||
}
|
||||
-}
|
||||
|
||||
type ApolloService
|
||||
= 'Package ('Just "apollo")
|
||||
'[ Object "Book" '[]
|
||||
'[ ObjectField "title" '[] '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))
|
||||
]
|
||||
, Object "Author" '[]
|
||||
'[ ObjectField "name" '[] '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
|
||||
]
|
||||
]
|
||||
|
||||
type ApolloBookAuthor = '[
|
||||
"Book" ':-> (String, Integer)
|
||||
, "Author" ':-> Integer
|
||||
]
|
||||
|
||||
apolloServer :: forall m. (MonadServer m) => ServerT Maybe ApolloBookAuthor ApolloService m _
|
||||
apolloServer
|
||||
= Services $ (pure . fst :<||>: pure . snd :<||>: H0) :<&>: (authorName :<||>: authorBooks :<||>: H0) :<&>: S0
|
||||
where
|
||||
authorName :: Integer -> m String
|
||||
authorName _ = pure "alex" -- this would run in the DB
|
||||
authorBooks :: Integer -> m [(String, Integer)]
|
||||
authorBooks _ = pure []
|
||||
|
@ -5,11 +5,13 @@
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PatternSynonyms #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language ViewPatterns #-}
|
||||
{-|
|
||||
Description : Protocol-independent declaration of servers.
|
||||
|
||||
@ -34,13 +36,18 @@ We recommend you to catch exceptions and return custom
|
||||
-}
|
||||
module Mu.Server (
|
||||
-- * Servers and handlers
|
||||
MonadServer, ServerT(..), HandlersT(..)
|
||||
MonadServer
|
||||
, SingleServerT
|
||||
, ServerT(.., Server), ServicesT(..), HandlersT(.., (:<|>:))
|
||||
, ServiceChain, noContext
|
||||
-- ** Simple servers using only IO
|
||||
, ServerErrorIO, ServerIO
|
||||
-- * Errors which might be raised
|
||||
, serverError, ServerError(..), ServerErrorCode(..)
|
||||
-- ** Useful when you do not want to deal with errors
|
||||
, alwaysOk
|
||||
-- * For internal use
|
||||
, Handles, FromRef, ToRef
|
||||
) where
|
||||
|
||||
import Control.Monad.Except
|
||||
@ -54,8 +61,10 @@ import Mu.Schema
|
||||
type MonadServer m = (MonadError ServerError m, MonadIO m)
|
||||
-- | Simplest monad which satisfies 'MonadServer'.
|
||||
type ServerErrorIO = ExceptT ServerError IO
|
||||
-- | Simple 'ServerT' which uses only 'IO' and errors.
|
||||
type ServerIO w srv = ServerT w srv ServerErrorIO
|
||||
|
||||
-- | Simple 'ServerT' which uses only 'IO' and errors,
|
||||
-- and whose service has no back-references.
|
||||
type ServerIO w srv = ServerT w '[] srv ServerErrorIO
|
||||
|
||||
-- | Stop the current handler,
|
||||
-- returning an error to the client.
|
||||
@ -70,6 +79,11 @@ alwaysOk :: (MonadIO m)
|
||||
=> IO a -> m a
|
||||
alwaysOk = liftIO
|
||||
|
||||
-- | To declare that the function doesn't use
|
||||
-- its context.
|
||||
noContext :: b -> a -> b
|
||||
noContext = const
|
||||
|
||||
-- | Errors raised in a handler.
|
||||
data ServerError
|
||||
= ServerError ServerErrorCode String
|
||||
@ -87,11 +101,40 @@ data ServerErrorCode
|
||||
| NotFound
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Definition of a complete server for a service.
|
||||
data ServerT (w :: Type -> Type) (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where
|
||||
Server :: HandlersT w methods m hs -> ServerT w ('Service sname anns methods) m hs
|
||||
-- | Defines a mapping between outcome of
|
||||
-- a service, and its representation as
|
||||
-- Haskell type.
|
||||
type ServiceChain snm = Mappings snm Type
|
||||
|
||||
infixr 5 :<|>:
|
||||
-- | A server for a single service,
|
||||
-- like most RPC ones.
|
||||
type SingleServerT w = ServerT w '[]
|
||||
|
||||
-- | Definition of a complete server
|
||||
-- for a set of services, with possible
|
||||
-- references between them.
|
||||
data ServerT (w :: Type -> Type) -- wrapper for data types
|
||||
(chn :: ServiceChain snm) (s :: Package snm mnm)
|
||||
(m :: Type -> Type) (hs :: [[Type]]) where
|
||||
Services :: ServicesT w chn s m hs
|
||||
-> ServerT w chn ('Package pname s) m hs
|
||||
|
||||
pattern Server :: (MappingRight chn sname ~ ())
|
||||
=> HandlersT w chn () methods m hs
|
||||
-> ServerT w chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs]
|
||||
pattern Server svr = Services (svr :<&>: S0)
|
||||
|
||||
infixr 3 :<&>:
|
||||
-- | Definition of a complete server for a service.
|
||||
data ServicesT (w :: Type -> Type)
|
||||
(chn :: ServiceChain snm) (s :: [Service snm mnm])
|
||||
(m :: Type -> Type) (hs :: [[Type]]) where
|
||||
S0 :: ServicesT w chn '[] m '[]
|
||||
(:<&>:) :: HandlersT w chn (MappingRight chn sname) methods m hs
|
||||
-> ServicesT w chn rest m hss
|
||||
-> ServicesT w chn ('Service sname anns methods ': rest) m (hs ': hss)
|
||||
|
||||
infixr 4 :<||>:
|
||||
-- | 'HandlersT' is a sequence of handlers.
|
||||
-- Note that the handlers for your service
|
||||
-- must appear __in the same order__ as they
|
||||
@ -111,36 +154,59 @@ infixr 5 :<|>:
|
||||
-- * Output streams turn into an __additional argument__
|
||||
-- of type @Conduit t Void m ()@. This stream should
|
||||
-- be connected to a source to get the elements.
|
||||
data HandlersT (w :: Type -> Type) (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where
|
||||
H0 :: HandlersT w '[] m '[]
|
||||
(:<|>:) :: Handles w args ret m h => h -> HandlersT w ms m hs
|
||||
-> HandlersT w ('Method name anns args ret ': ms) m (h ': hs)
|
||||
data HandlersT (w :: Type -> Type) (chn :: ServiceChain snm)
|
||||
(inh :: *) (methods :: [Method snm mnm])
|
||||
(m :: Type -> Type) (hs :: [Type]) where
|
||||
H0 :: HandlersT w chn inh '[] m '[]
|
||||
(:<||>:) :: Handles w chn args ret m h
|
||||
=> (inh -> h) -> HandlersT w chn inh ms m hs
|
||||
-> HandlersT w chn inh ('Method name anns args ret ': ms) m (h ': hs)
|
||||
|
||||
infixr 4 :<|>:
|
||||
pattern (:<|>:) :: (Handles w chn args ret m h)
|
||||
=> h -> HandlersT w chn () ms m hs
|
||||
-> HandlersT w chn () ('Method name anns args ret ': ms) m (h ': hs)
|
||||
pattern x :<|>: xs <- (($ ()) -> x) :<||>: xs where
|
||||
x :<|>: xs = noContext x :<||>: xs
|
||||
|
||||
-- Define a relation for handling
|
||||
class Handles (w :: Type -> Type) (args :: [Argument]) (ret :: Return)
|
||||
class Handles (w :: Type -> Type)
|
||||
(chn :: ServiceChain snm)
|
||||
(args :: [Argument snm]) (ret :: Return snm)
|
||||
(m :: Type -> Type) (h :: Type)
|
||||
class ToRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type)
|
||||
class FromRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type)
|
||||
class ToRef (w :: Type -> Type) (chn :: ServiceChain snm)
|
||||
(ref :: TypeRef snm) (t :: Type)
|
||||
class FromRef (w :: Type -> Type) (chn :: ServiceChain snm)
|
||||
(ref :: TypeRef snm) (t :: Type)
|
||||
|
||||
-- Type references
|
||||
instance ToSchema w sch sty t => ToRef w ('ViaSchema sch sty) t
|
||||
instance ToRef w ('ViaRegistry subject t last) t
|
||||
instance FromSchema w sch sty t => FromRef w ('ViaSchema sch sty) t
|
||||
instance FromRef w ('ViaRegistry subject t last) t
|
||||
instance t ~ s => ToRef w chn ('PrimitiveRef t) s
|
||||
instance ToSchema w sch sty t => ToRef w chn ('SchemaRef sch sty) t
|
||||
instance MappingRight chn ref ~ t => ToRef w chn ('ObjectRef ref) t
|
||||
instance t ~ s => ToRef w chn ('RegistryRef subject t last) s
|
||||
instance (ToRef w chn ref t, [t] ~ s) => ToRef w chn ('ListRef ref) s
|
||||
instance (ToRef w chn ref t, Maybe t ~ s) => ToRef w chn ('OptionalRef ref) s
|
||||
|
||||
instance t ~ s => FromRef w chn ('PrimitiveRef t) s
|
||||
instance FromSchema w sch sty t => FromRef w chn ('SchemaRef sch sty) t
|
||||
instance MappingRight chn ref ~ t => FromRef w chn ('ObjectRef ref) t
|
||||
instance t ~ s => FromRef w chn ('RegistryRef subject t last) s
|
||||
instance (FromRef w chn ref t, [t] ~ s) => FromRef w chn ('ListRef ref) s
|
||||
instance (FromRef w chn ref t, Maybe t ~ s) => FromRef w chn ('OptionalRef ref) s
|
||||
|
||||
-- Arguments
|
||||
instance (FromRef w ref t, Handles w args ret m h,
|
||||
instance (FromRef w chn ref t, Handles w chn args ret m h,
|
||||
handler ~ (t -> h))
|
||||
=> Handles w ('ArgSingle ref ': args) ret m handler
|
||||
instance (MonadError ServerError m, FromRef w ref t, Handles w args ret m h,
|
||||
=> Handles w chn ('ArgSingle 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 ('ArgStream ref ': args) ret m handler
|
||||
=> Handles w chn ('ArgStream ref ': args) ret m handler
|
||||
-- Result with exception
|
||||
instance (MonadError ServerError m, handler ~ m ())
|
||||
=> Handles w '[] 'RetNothing m handler
|
||||
instance (MonadError ServerError m, ToRef w eref e, ToRef w vref v, handler ~ m (Either e v))
|
||||
=> Handles w '[] ('RetThrows eref vref) m handler
|
||||
instance (MonadError ServerError m, ToRef w ref v, handler ~ m v)
|
||||
=> Handles w '[] ('RetSingle ref) m handler
|
||||
instance (MonadError ServerError m, ToRef w ref v, handler ~ (ConduitT v Void m () -> m ()))
|
||||
=> Handles w '[] ('RetStream ref) m handler
|
||||
=> Handles w chn '[] 'RetNothing m handler
|
||||
instance (MonadError ServerError m, ToRef w chn eref e, ToRef w chn vref v, handler ~ m (Either e v))
|
||||
=> Handles w chn '[] ('RetThrows eref vref) m handler
|
||||
instance (MonadError ServerError m, ToRef w chn ref v, handler ~ m v)
|
||||
=> Handles w chn '[] ('RetSingle ref) m handler
|
||||
instance (MonadError ServerError m, ToRef w chn ref v, handler ~ (ConduitT v Void m () -> m ()))
|
||||
=> Handles w chn '[] ('RetStream ref) m handler
|
||||
|
@ -72,7 +72,7 @@ instance (KnownName name, ToJSON (FieldValue Identity sch t), ToJSONFields sch f
|
||||
class FromJSONFields w sch fields where
|
||||
parseJSONFields :: Object -> Parser (NP (Field w sch) fields)
|
||||
instance FromJSONFields w sch '[] where
|
||||
parseJSONFields _ = return Nil
|
||||
parseJSONFields _ = pure Nil
|
||||
instance (Applicative w, KnownName name, FromJSON (FieldValue w sch t), FromJSONFields w sch fs)
|
||||
=> FromJSONFields w sch ('FieldDef name t ': fs) where
|
||||
parseJSONFields v = (:*) <$> (Field <$> (pure <$> v .: key)) <*> parseJSONFields v
|
||||
@ -100,7 +100,7 @@ instance FromJSONEnum '[] where
|
||||
instance (KnownName c, FromJSONEnum cs)
|
||||
=> FromJSONEnum ('ChoiceDef c ': cs) where
|
||||
parseJSONEnum v
|
||||
| v == key = return (Z Proxy)
|
||||
| v == key = pure (Z Proxy)
|
||||
| otherwise = S <$> parseJSONEnum v
|
||||
where key = T.pack (nameVal (Proxy @c))
|
||||
|
||||
@ -142,7 +142,7 @@ instance (ToJSON (FieldValue w sch u), ToJSONUnion w sch us)
|
||||
unionToJSON (S r) = unionToJSON r
|
||||
|
||||
instance FromJSON (FieldValue w sch 'TNull) where
|
||||
parseJSON Null = return FNull
|
||||
parseJSON Null = pure FNull
|
||||
parseJSON _ = fail "expected null"
|
||||
instance FromJSON t => FromJSON (FieldValue w sch ('TPrimitive t)) where
|
||||
parseJSON v = FPrimitive <$> parseJSON v
|
||||
|
@ -59,7 +59,7 @@ typeDefToDecl _schemaTy namer (DRecord name [f])
|
||||
[pure (DerivClause Nothing [ConT ''Generic])]
|
||||
_wTy <- VarT <$> newName "w"
|
||||
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete [f])
|
||||
return [d] -- , hsi]
|
||||
pure [d] -- , hsi]
|
||||
-- Records with more than one field
|
||||
typeDefToDecl _schemaTy namer (DRecord name fields)
|
||||
= do let complete = completeName namer name
|
||||
@ -72,7 +72,7 @@ typeDefToDecl _schemaTy namer (DRecord name fields)
|
||||
[pure (DerivClause Nothing [ConT ''Generic])]
|
||||
_wTy <- VarT <$> newName "w"
|
||||
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete fields)
|
||||
return [d] -- , hsi]
|
||||
pure [d] -- , hsi]
|
||||
-- Enumerations
|
||||
typeDefToDecl _schemaTy namer (DEnum name choices)
|
||||
= do let complete = completeName namer name
|
||||
@ -86,7 +86,7 @@ typeDefToDecl _schemaTy namer (DEnum name choices)
|
||||
[pure (DerivClause Nothing [ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic])]
|
||||
_wTy <- VarT <$> newName "w"
|
||||
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (choiceMapping complete choices)
|
||||
return [d] --, hsi]
|
||||
pure [d] --, hsi]
|
||||
-- Simple things
|
||||
typeDefToDecl _ _ (DSimple _)
|
||||
= fail "DSimple is not supported"
|
||||
|
@ -159,8 +159,11 @@ type Mappings a b = [Mapping a b]
|
||||
-- | Finds the corresponding right value of @v@
|
||||
-- in a mapping @ms@. When the kinds are 'Symbol',
|
||||
-- return the same value if not found.
|
||||
-- When the return type is 'Type', return ' ()'
|
||||
-- if the value is not found.
|
||||
type family MappingRight (ms :: Mappings a b) (v :: a) :: b where
|
||||
MappingRight '[] (v :: Symbol) = v
|
||||
MappingRight '[] (v :: Symbol) = (v :: Symbol)
|
||||
MappingRight '[] (v :: Symbol) = (() :: Type)
|
||||
MappingRight '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v)
|
||||
MappingRight ((x ':-> y) ': rest) x = y
|
||||
MappingRight (other ': rest) x = MappingRight rest x
|
||||
@ -168,8 +171,11 @@ type family MappingRight (ms :: Mappings a b) (v :: a) :: b where
|
||||
-- | Finds the corresponding left value of @v@
|
||||
-- in a mapping @ms@. When the kinds are 'Symbol',
|
||||
-- return the same value if not found.
|
||||
-- When the return type is 'Type', return ' ()'
|
||||
-- if the value is not found.
|
||||
type family MappingLeft (ms :: Mappings a b) (v :: b) :: a where
|
||||
MappingLeft '[] (v :: Symbol) = v
|
||||
MappingLeft '[] (v :: Symbol) = (v :: Symbol)
|
||||
MappingLeft '[] (v :: Symbol) = (() :: Type)
|
||||
MappingLeft '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v)
|
||||
MappingLeft ((x ':-> y) ': rest) y = x
|
||||
MappingLeft (other ': rest) y = MappingLeft rest y
|
||||
|
@ -135,7 +135,7 @@ instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest)
|
||||
Field _ v <- find (\(Field fieldName _) -> fieldName == name) fs
|
||||
v' <- traverse checkSchemaValue v
|
||||
r' <- checkSchemaFields @_ @_ @s @rest fs
|
||||
return (S.Field v' :* r')
|
||||
pure (S.Field v' :* r')
|
||||
|
||||
instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm choices) where
|
||||
checkSchema' (TEnum n) = S.TEnum <$> checkSchemaEnumInt n
|
||||
|
@ -17,6 +17,7 @@ in {
|
||||
mu-example-seed-protobuf = hnPkgs.mu-example-seed-protobuf.components.all;
|
||||
mu-example-todolist = hnPkgs.mu-example-todolist.components.all;
|
||||
mu-example-with-persistent = hnPkgs.mu-example-with-persistent.components.all;
|
||||
mu-graphql = hnPkgs.mu-graphql.components.library;
|
||||
mu-grpc-client = hnPkgs.mu-grpc-client.components.library;
|
||||
mu-grpc-common = hnPkgs.mu-grpc-common.components.library;
|
||||
mu-grpc-server = hnPkgs.mu-grpc-server.components.all;
|
||||
|
@ -26,7 +26,7 @@ data HealthCall = HealthCall
|
||||
} deriving (Generic)
|
||||
|
||||
buildHealthCall :: GrpcClient -> HealthCall
|
||||
buildHealthCall = buildService @'MsgAvro @HealthCheckService @""
|
||||
buildHealthCall = buildService @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @""
|
||||
|
||||
main :: IO ()
|
||||
main = do -- Setup the client
|
||||
|
@ -31,22 +31,22 @@ simple client who = do
|
||||
let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
||||
rknown :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @'MsgAvro @HealthCheckService @"check" client hcm
|
||||
<- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
||||
update client who "SERVING"
|
||||
r <- gRpcCall @'MsgAvro @HealthCheckService @"clearStatus" client hcm
|
||||
r <- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"clearStatus" client hcm
|
||||
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
||||
runknown :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @'MsgAvro @HealthCheckService @"check" client hcm
|
||||
<- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
||||
|
||||
update :: GrpcClient -> String -> String -> IO ()
|
||||
update client who newstatus = do
|
||||
let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
||||
r <- gRpcCall @'MsgAvro @HealthCheckService @"setStatus" client
|
||||
r <- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"setStatus" client
|
||||
(HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus)))
|
||||
putStrLn ("UNARY: Was setting successful? " <> show r)
|
||||
rstatus :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @'MsgAvro @HealthCheckService @"check" client hcm
|
||||
<- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
||||
|
@ -53,7 +53,7 @@ checkH_ m (HealthCheckMsg nm) = alwaysOk $ do
|
||||
putStr "check: " >> print nm
|
||||
ss <- atomically $ M.lookup nm m
|
||||
print ss
|
||||
return $ ServerStatusMsg (fromMaybe "<unknown>" ss)
|
||||
pure $ ServerStatusMsg (fromMaybe "<unknown>" ss)
|
||||
|
||||
clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ()
|
||||
clearStatus_ m (HealthCheckMsg nm) = alwaysOk $ do
|
||||
|
@ -28,7 +28,7 @@ data HealthCall = HealthCall
|
||||
} deriving (Generic)
|
||||
|
||||
buildHealthCall :: GrpcClient -> HealthCall
|
||||
buildHealthCall = buildService @'MsgProtoBuf @HealthCheckService @""
|
||||
buildHealthCall = buildService @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @""
|
||||
|
||||
main :: IO ()
|
||||
main = do -- Setup the client
|
||||
|
@ -34,28 +34,28 @@ simple client who = do
|
||||
let hcm = HealthCheckMsg $ Just (T.pack who)
|
||||
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
||||
rknown :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"check" client hcm
|
||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
||||
update client who "SERVING"
|
||||
r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"clearStatus" client hcm
|
||||
r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"clearStatus" client hcm
|
||||
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
||||
runknown :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"check" client hcm
|
||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
||||
|
||||
update :: GrpcClient -> String -> String -> IO ()
|
||||
update client who newstatus = do
|
||||
let hcm = HealthCheckMsg $ Just (T.pack who)
|
||||
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
||||
r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"setStatus" client
|
||||
r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"setStatus" client
|
||||
(HealthStatusMsg (Just hcm) (Just $ ServerStatusMsg (Just $ T.pack newstatus)))
|
||||
putStrLn ("UNARY: Was setting successful? " <> show r)
|
||||
rstatus :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"check" client hcm
|
||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
||||
|
||||
watching :: GrpcClient -> String -> IO ()
|
||||
watching client who = do
|
||||
let hcm = HealthCheckMsg $ Just (T.pack who)
|
||||
replies <- gRpcCall @'MsgProtoBuf @HealthCheckService @"watch" client hcm
|
||||
replies <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"watch" client hcm
|
||||
runConduit $ replies .| C.mapM_ (print :: GRpcReply ServerStatusMsg -> IO ())
|
||||
|
@ -48,14 +48,14 @@ checkH_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ServerStatusMsg
|
||||
checkH_ m (HealthCheckMsg (Just nm)) = alwaysOk $ do
|
||||
putStr "check: " >> print nm
|
||||
ss <- atomically $ M.lookup nm m
|
||||
return $ ServerStatusMsg ss
|
||||
pure $ ServerStatusMsg ss
|
||||
checkH_ _ _ = serverError (ServerError Invalid "no server name given")
|
||||
|
||||
clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ()
|
||||
clearStatus_ m (HealthCheckMsg (Just nm)) = alwaysOk $ do
|
||||
putStr "clearStatus: " >> print nm
|
||||
atomically $ M.delete nm m
|
||||
clearStatus_ _ _ = return ()
|
||||
clearStatus_ _ _ = pure ()
|
||||
|
||||
checkAll_ :: StatusMap -> ServerErrorIO AllStatusMsg
|
||||
checkAll_ m = alwaysOk $ do
|
||||
@ -87,4 +87,4 @@ watch_ upd hcm@(HealthCheckMsg nm) sink = do
|
||||
case x of
|
||||
Just (Just y) -> yield y >> catMaybesC
|
||||
Just Nothing -> catMaybesC
|
||||
Nothing -> return ()
|
||||
Nothing -> pure ()
|
||||
|
@ -73,7 +73,7 @@ server f m = Server
|
||||
(getFeature f :<|>: listFeatures f :<|>: recordRoute f :<|>: routeChat m :<|>: H0)
|
||||
|
||||
getFeature :: Features -> Point -> ServerErrorIO Feature
|
||||
getFeature fs p = return $ fromMaybe nilFeature (findFeatureIn fs p)
|
||||
getFeature fs p = pure $ fromMaybe nilFeature (findFeatureIn fs p)
|
||||
where nilFeature = Feature (Just "") (Just (Point (Just 0) (Just 0)))
|
||||
|
||||
listFeatures :: Features -> Rectangle
|
||||
@ -103,7 +103,7 @@ recordRoute fs ps = do
|
||||
((update_feature_count +) <$> feature_count summary)
|
||||
((+) <$> distance summary <*> new_distance)
|
||||
(Just $ floor new_elapsed)
|
||||
return (new_summary, Just point, startTime)
|
||||
pure (new_summary, Just point, startTime)
|
||||
|
||||
routeChat :: TBMChan RouteNote
|
||||
-> ConduitT () RouteNote ServerErrorIO ()
|
||||
@ -117,7 +117,7 @@ routeChat notesMap inS outS = do
|
||||
readStmMap (\l1 (RouteNote _ l2)-> Just l1 == l2) toWatch notesMap .| outS
|
||||
res <- liftIO $ concurrently inA outA
|
||||
case res of
|
||||
(Right _, Right _) -> return ()
|
||||
(Right _, Right _) -> pure ()
|
||||
(Left e, _) -> serverError e
|
||||
(_, Left e) -> serverError e
|
||||
where
|
||||
@ -126,7 +126,7 @@ routeChat notesMap inS outS = do
|
||||
_ <- tryTakeTMVar toWatch
|
||||
putTMVar toWatch loc
|
||||
writeTBMChan notesMap newNote
|
||||
addNoteToMap _toWatch _ = return ()
|
||||
addNoteToMap _toWatch _ = pure ()
|
||||
|
||||
readStmMap :: (MonadIO m, Show b) => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b m ()
|
||||
readStmMap p toWatch m = go
|
||||
@ -134,6 +134,6 @@ readStmMap p toWatch m = go
|
||||
go = do
|
||||
v <- liftIO $ atomically $ (,) <$> readTBMChan m <*> tryReadTMVar toWatch
|
||||
case v of
|
||||
(Nothing, _) -> return ()
|
||||
(Nothing, _) -> pure ()
|
||||
(Just v', Just e') | p e' v' -> liftIO (print v') >> yield v' >> go
|
||||
_ -> go
|
||||
|
@ -31,7 +31,7 @@ main = do
|
||||
-- Server implementation
|
||||
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
||||
|
||||
server :: (MonadServer m, MonadLogger m) => ServerT Identity PeopleService m _
|
||||
server :: (MonadServer m, MonadLogger m) => SingleServerT Identity PeopleService m _
|
||||
server = Server (getPerson :<|>: H0)
|
||||
|
||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||
|
@ -50,7 +50,7 @@ main = do
|
||||
-- Server implementation
|
||||
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
||||
|
||||
server :: (MonadServer m, MonadLogger m) => ServerT Maybe PeopleService m _
|
||||
server :: (MonadServer m, MonadLogger m) => SingleServerT Maybe PeopleService m _
|
||||
server = Server (getPerson :<|>: getPersonStream :<|>: H0)
|
||||
|
||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||
|
@ -34,7 +34,7 @@ main = do
|
||||
-- Server implementation
|
||||
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
||||
|
||||
server :: (MonadServer m, MonadLogger m) => ServerT Maybe PeopleService m _
|
||||
server :: (MonadServer m, MonadLogger m) => SingleServerT Maybe PeopleService m _
|
||||
server = Server (getPerson :<|>: getPersonStream :<|>: H0)
|
||||
|
||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||
|
@ -41,7 +41,7 @@ reset i t = alwaysOk $ do
|
||||
atomically $ do
|
||||
writeTVar i 0
|
||||
writeTVar t []
|
||||
pure $ MessageId Nothing -- returns nothing
|
||||
pure $ MessageId Nothing
|
||||
|
||||
insert :: Id -> TodoList -> TodoListRequest -> ServerErrorIO TodoListResponse
|
||||
insert oldId t (TodoListRequest titl tgId) = alwaysOk $ do
|
||||
@ -89,5 +89,5 @@ destroy t (MessageId (Just idMsg)) = do
|
||||
modifyTVar t $ filter (/=todo)
|
||||
pure $ Just (MessageId (Just idMsg)) -- OK ✅
|
||||
Nothing -> pure Nothing -- did nothing
|
||||
maybe (serverError $ ServerError NotFound "unknown message id") return r
|
||||
maybe (serverError $ ServerError NotFound "unknown message id") pure r
|
||||
destroy _ _ = serverError $ ServerError Invalid "missing message id"
|
||||
|
@ -30,7 +30,7 @@ get client idPerson = do
|
||||
let req = MPersonRequest $ readMaybe idPerson
|
||||
putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?"
|
||||
response :: GRpcReply MPerson
|
||||
<- gRpcCall @'MsgProtoBuf @PersistentService @"getPerson" client req
|
||||
<- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"getPerson" client req
|
||||
putStrLn $ "GET: response was: " ++ show response
|
||||
|
||||
add :: GrpcClient -> String -> String -> IO ()
|
||||
@ -38,10 +38,10 @@ add client nm ag = do
|
||||
let p = MPerson Nothing (Just $ T.pack nm) (readMaybe ag)
|
||||
putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag
|
||||
response :: GRpcReply MPersonRequest
|
||||
<- gRpcCall @'MsgProtoBuf @PersistentService @"newPerson" client p
|
||||
<- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"newPerson" client p
|
||||
putStrLn $ "ADD: was creating successful? " ++ show response
|
||||
|
||||
watching :: GrpcClient -> IO ()
|
||||
watching client = do
|
||||
replies <- gRpcCall @'MsgProtoBuf @PersistentService @"allPeople" client
|
||||
replies <- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"allPeople" client
|
||||
runConduit $ replies .| C.mapM_ (print :: GRpcReply MPerson -> IO ())
|
||||
|
@ -1,11 +1,13 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language OverloadedLabels #-}
|
||||
{-# language TypeApplications #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import qualified Data.Text as T
|
||||
import GHC.OverloadedLabels
|
||||
import Mu.GRpc.Client.Optics
|
||||
import System.Environment
|
||||
import Text.Read (readMaybe)
|
||||
@ -26,17 +28,17 @@ get :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> IO ()
|
||||
get client idPerson = do
|
||||
let req = readMaybe idPerson
|
||||
putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?"
|
||||
response <- (client ^. #getPerson) (record1 req)
|
||||
response <- (client ^. (fromLabel @"PersistentService") % #getPerson) (record1 req)
|
||||
putStrLn $ "GET: response was: " ++ show response
|
||||
|
||||
add :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> String -> IO ()
|
||||
add client nm ag = do
|
||||
let p = record (Nothing, Just (T.pack nm), readMaybe ag)
|
||||
putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag
|
||||
response <- (client ^. #newPerson) p
|
||||
response <- (client ^. (fromLabel @"PersistentService") % #newPerson) p
|
||||
putStrLn $ "ADD: was creating successful? " ++ show response
|
||||
|
||||
watching :: GRpcConnection PersistentService 'MsgProtoBuf -> IO ()
|
||||
watching client = do
|
||||
replies <- client ^. #allPeople
|
||||
replies <- client ^. (fromLabel @"PersistentService") % #allPeople
|
||||
runConduit $ replies .| C.mapM_ print
|
||||
|
@ -25,7 +25,7 @@ main :: IO ()
|
||||
main = do
|
||||
let config = grpcClientConfigSimple "127.0.0.1" 1234 False
|
||||
Right grpcClient <- setupGrpcClient' config
|
||||
let client = buildService @'MsgProtoBuf @PersistentService @"" grpcClient
|
||||
let client = buildService @'MsgProtoBuf @PersistentService @"PersistentService" @"" grpcClient
|
||||
args <- getArgs
|
||||
case args of
|
||||
["watch"] -> watching client
|
||||
|
@ -25,7 +25,7 @@ main = do
|
||||
runDb conn $ runMigration migrateAll
|
||||
liftIO $ runGRpcApp msgProtoBuf 1234 (server conn)
|
||||
|
||||
server :: SqlBackend -> ServerT Maybe PersistentService ServerErrorIO _
|
||||
server :: SqlBackend -> SingleServerT Maybe PersistentService ServerErrorIO _
|
||||
server p = Server (getPerson p :<|>: newPerson p :<|>: allPeople p :<|>: H0)
|
||||
|
||||
getPerson :: SqlBackend -> MPersonRequest -> ServerErrorIO (Entity Person)
|
||||
|
@ -17,7 +17,7 @@ stack exec --no-ghc-package-path standalone-haddock -- -o ${DOCSDIR} \
|
||||
--hyperlink-source \
|
||||
core/schema core/rpc core/optics \
|
||||
adapter/avro adapter/protobuf adapter/persistent adapter/kafka \
|
||||
grpc/common grpc/client grpc/server
|
||||
grpc/common grpc/client grpc/server graphql
|
||||
|
||||
echo "Setting Linuwial theme on Haddock generated docs"
|
||||
find ${DOCSDIR} -name "ocean.css" -exec cp -rf docs/css/linuwial.css {} \;
|
||||
|
202
graphql/LICENSE
Normal file
202
graphql/LICENSE
Normal file
@ -0,0 +1,202 @@
|
||||
|
||||
Apache License
|
||||
Version 2.0, January 2004
|
||||
http://www.apache.org/licenses/
|
||||
|
||||
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
|
||||
|
||||
1. Definitions.
|
||||
|
||||
"License" shall mean the terms and conditions for use, reproduction,
|
||||
and distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
"Licensor" shall mean the copyright owner or entity authorized by
|
||||
the copyright owner that is granting the License.
|
||||
|
||||
"Legal Entity" shall mean the union of the acting entity and all
|
||||
other entities that control, are controlled by, or are under common
|
||||
control with that entity. For the purposes of this definition,
|
||||
"control" means (i) the power, direct or indirect, to cause the
|
||||
direction or management of such entity, whether by contract or
|
||||
otherwise, or (ii) ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or (iii) beneficial ownership of such entity.
|
||||
|
||||
"You" (or "Your") shall mean an individual or Legal Entity
|
||||
exercising permissions granted by this License.
|
||||
|
||||
"Source" form shall mean the preferred form for making modifications,
|
||||
including but not limited to software source code, documentation
|
||||
source, and configuration files.
|
||||
|
||||
"Object" form shall mean any form resulting from mechanical
|
||||
transformation or translation of a Source form, including but
|
||||
not limited to compiled object code, generated documentation,
|
||||
and conversions to other media types.
|
||||
|
||||
"Work" shall mean the work of authorship, whether in Source or
|
||||
Object form, made available under the License, as indicated by a
|
||||
copyright notice that is included in or attached to the work
|
||||
(an example is provided in the Appendix below).
|
||||
|
||||
"Derivative Works" shall mean any work, whether in Source or Object
|
||||
form, that is based on (or derived from) the Work and for which the
|
||||
editorial revisions, annotations, elaborations, or other modifications
|
||||
represent, as a whole, an original work of authorship. For the purposes
|
||||
of this License, Derivative Works shall not include works that remain
|
||||
separable from, or merely link (or bind by name) to the interfaces of,
|
||||
the Work and Derivative Works thereof.
|
||||
|
||||
"Contribution" shall mean any work of authorship, including
|
||||
the original version of the Work and any modifications or additions
|
||||
to that Work or Derivative Works thereof, that is intentionally
|
||||
submitted to Licensor for inclusion in the Work by the copyright owner
|
||||
or by an individual or Legal Entity authorized to submit on behalf of
|
||||
the copyright owner. For the purposes of this definition, "submitted"
|
||||
means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems,
|
||||
and issue tracking systems that are managed by, or on behalf of, the
|
||||
Licensor for the purpose of discussing and improving the Work, but
|
||||
excluding communication that is conspicuously marked or otherwise
|
||||
designated in writing by the copyright owner as "Not a Contribution."
|
||||
|
||||
"Contributor" shall mean Licensor and any individual or Legal Entity
|
||||
on behalf of whom a Contribution has been received by Licensor and
|
||||
subsequently incorporated within the Work.
|
||||
|
||||
2. Grant of Copyright License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the
|
||||
Work and such Derivative Works in Source or Object form.
|
||||
|
||||
3. Grant of Patent License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
(except as stated in this section) patent license to make, have made,
|
||||
use, offer to sell, sell, import, and otherwise transfer the Work,
|
||||
where such license applies only to those patent claims licensable
|
||||
by such Contributor that are necessarily infringed by their
|
||||
Contribution(s) alone or by combination of their Contribution(s)
|
||||
with the Work to which such Contribution(s) was submitted. If You
|
||||
institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work
|
||||
or a Contribution incorporated within the Work constitutes direct
|
||||
or contributory patent infringement, then any patent licenses
|
||||
granted to You under this License for that Work shall terminate
|
||||
as of the date such litigation is filed.
|
||||
|
||||
4. Redistribution. You may reproduce and distribute copies of the
|
||||
Work or Derivative Works thereof in any medium, with or without
|
||||
modifications, and in Source or Object form, provided that You
|
||||
meet the following conditions:
|
||||
|
||||
(a) You must give any other recipients of the Work or
|
||||
Derivative Works a copy of this License; and
|
||||
|
||||
(b) You must cause any modified files to carry prominent notices
|
||||
stating that You changed the files; and
|
||||
|
||||
(c) You must retain, in the Source form of any Derivative Works
|
||||
that You distribute, all copyright, patent, trademark, and
|
||||
attribution notices from the Source form of the Work,
|
||||
excluding those notices that do not pertain to any part of
|
||||
the Derivative Works; and
|
||||
|
||||
(d) If the Work includes a "NOTICE" text file as part of its
|
||||
distribution, then any Derivative Works that You distribute must
|
||||
include a readable copy of the attribution notices contained
|
||||
within such NOTICE file, excluding those notices that do not
|
||||
pertain to any part of the Derivative Works, in at least one
|
||||
of the following places: within a NOTICE text file distributed
|
||||
as part of the Derivative Works; within the Source form or
|
||||
documentation, if provided along with the Derivative Works; or,
|
||||
within a display generated by the Derivative Works, if and
|
||||
wherever such third-party notices normally appear. The contents
|
||||
of the NOTICE file are for informational purposes only and
|
||||
do not modify the License. You may add Your own attribution
|
||||
notices within Derivative Works that You distribute, alongside
|
||||
or as an addendum to the NOTICE text from the Work, provided
|
||||
that such additional attribution notices cannot be construed
|
||||
as modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and
|
||||
may provide additional or different license terms and conditions
|
||||
for use, reproduction, or distribution of Your modifications, or
|
||||
for any such Derivative Works as a whole, provided Your use,
|
||||
reproduction, and distribution of the Work otherwise complies with
|
||||
the conditions stated in this License.
|
||||
|
||||
5. Submission of Contributions. Unless You explicitly state otherwise,
|
||||
any Contribution intentionally submitted for inclusion in the Work
|
||||
by You to the Licensor shall be under the terms and conditions of
|
||||
this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify
|
||||
the terms of any separate license agreement you may have executed
|
||||
with Licensor regarding such Contributions.
|
||||
|
||||
6. Trademarks. This License does not grant permission to use the trade
|
||||
names, trademarks, service marks, or product names of the Licensor,
|
||||
except as required for reasonable and customary use in describing the
|
||||
origin of the Work and reproducing the content of the NOTICE file.
|
||||
|
||||
7. Disclaimer of Warranty. Unless required by applicable law or
|
||||
agreed to in writing, Licensor provides the Work (and each
|
||||
Contributor provides its Contributions) on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
|
||||
implied, including, without limitation, any warranties or conditions
|
||||
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. You are solely responsible for determining the
|
||||
appropriateness of using or redistributing the Work and assume any
|
||||
risks associated with Your exercise of permissions under this License.
|
||||
|
||||
8. Limitation of Liability. In no event and under no legal theory,
|
||||
whether in tort (including negligence), contract, or otherwise,
|
||||
unless required by applicable law (such as deliberate and grossly
|
||||
negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special,
|
||||
incidental, or consequential damages of any character arising as a
|
||||
result of this License or out of the use or inability to use the
|
||||
Work (including but not limited to damages for loss of goodwill,
|
||||
work stoppage, computer failure or malfunction, or any and all
|
||||
other commercial damages or losses), even if such Contributor
|
||||
has been advised of the possibility of such damages.
|
||||
|
||||
9. Accepting Warranty or Additional Liability. While redistributing
|
||||
the Work or Derivative Works thereof, You may choose to offer,
|
||||
and charge a fee for, acceptance of support, warranty, indemnity,
|
||||
or other liability obligations and/or rights consistent with this
|
||||
License. However, in accepting such obligations, You may act only
|
||||
on Your own behalf and on Your sole responsibility, not on behalf
|
||||
of any other Contributor, and only if You agree to indemnify,
|
||||
defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason
|
||||
of your accepting any such warranty or additional liability.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
APPENDIX: How to apply the Apache License to your work.
|
||||
|
||||
To apply the Apache License to your work, attach the following
|
||||
boilerplate notice, with the fields enclosed by brackets "[]"
|
||||
replaced with your own identifying information. (Don't include
|
||||
the brackets!) The text should be enclosed in the appropriate
|
||||
comment syntax for the file format. We also recommend that a
|
||||
file or class name and description of purpose be included on the
|
||||
same "printed page" as the copyright notice for easier
|
||||
identification within third-party archives.
|
||||
|
||||
Copyright © 2019-2020 47 Degrees. <http://47deg.com>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
2
graphql/Setup.hs
Normal file
2
graphql/Setup.hs
Normal file
@ -0,0 +1,2 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
1
graphql/hie.yaml
Normal file
1
graphql/hie.yaml
Normal file
@ -0,0 +1 @@
|
||||
cradle: { stack: { component: "mu-graphql:lib" } }
|
39
graphql/mu-graphql.cabal
Normal file
39
graphql/mu-graphql.cabal
Normal file
@ -0,0 +1,39 @@
|
||||
name: mu-graphql
|
||||
version: 0.1.0.0
|
||||
synopsis: GraphQL support for Mu
|
||||
cabal-version: >=1.10
|
||||
|
||||
-- description:
|
||||
-- bug-reports:
|
||||
license: Apache-2.0
|
||||
license-file: LICENSE
|
||||
author: Alejandro Serrano, Flavio Corpa
|
||||
maintainer: alejandro.serrano@47deg.com
|
||||
|
||||
-- copyright:
|
||||
category: Network
|
||||
build-type: Simple
|
||||
|
||||
-- extra-source-files: CHANGELOG.md
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Mu.GraphQL.Query.Definition
|
||||
Mu.GraphQL.Query.Parse
|
||||
Mu.GraphQL.Query.Run
|
||||
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.12 && <5
|
||||
, graphql-parser
|
||||
, mtl
|
||||
, mu-rpc
|
||||
, mu-schema
|
||||
, sop-core
|
||||
, text
|
||||
, unordered-containers
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fprint-potential-instances
|
56
graphql/src/Mu/GraphQL/Query/Definition.hs
Normal file
56
graphql/src/Mu/GraphQL/Query/Definition.hs
Normal file
@ -0,0 +1,56 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeOperators #-}
|
||||
module Mu.GraphQL.Query.Definition where
|
||||
|
||||
import Data.Functor.Identity
|
||||
import Data.SOP.NP
|
||||
import Data.SOP.NS
|
||||
import Data.Text
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
data Document (p :: Package snm mnm) (qr :: snm) (mut :: snm) where
|
||||
QueryDoc :: LookupService ss qr ~ 'Service qr qanns qms
|
||||
=> ServiceQuery ('Package pname ss) (LookupService ss qr)
|
||||
-> Document ('Package pname ss) qr mut
|
||||
MutationDoc :: LookupService ss mut ~ 'Service mut manns mms
|
||||
=> ServiceQuery ('Package pname ss) (LookupService ss mut)
|
||||
-> Document ('Package pname ss) qr mut
|
||||
|
||||
type ServiceQuery (p :: Package snm mnm) (s :: Service snm mnm)
|
||||
= [OneMethodQuery p s]
|
||||
|
||||
data OneMethodQuery (p :: Package snm mnm) (s :: Service snm mnm) where
|
||||
OneMethodQuery
|
||||
:: Maybe Text
|
||||
-> NS (ChosenMethodQuery p) ms
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
|
||||
data ChosenMethodQuery (p :: Package snm mnm) (m :: Method snm mnm) where
|
||||
ChosenMethodQuery
|
||||
:: NP (ArgumentValue p) args
|
||||
-> ReturnQuery p r
|
||||
-> ChosenMethodQuery p ('Method mname anns args ('RetSingle r))
|
||||
|
||||
data ArgumentValue (p :: Package snm mnm) (a :: Argument snm) where
|
||||
ArgumentValue :: ArgumentValue' p r -> ArgumentValue p ('ArgSingle r)
|
||||
|
||||
data ArgumentValue' (p :: Package snm mnm) (r :: TypeRef snm) where
|
||||
ArgPrimitive :: t -> ArgumentValue' p ('PrimitiveRef t)
|
||||
ArgSchema :: Term Identity sch (sch :/: sty)
|
||||
-> ArgumentValue' p ('SchemaRef sch sty)
|
||||
ArgList :: [ArgumentValue' p r]
|
||||
-> ArgumentValue' p ('ListRef r)
|
||||
ArgOptional :: Maybe (ArgumentValue' p r)
|
||||
-> ArgumentValue' p ('OptionalRef r)
|
||||
|
||||
data ReturnQuery (p :: Package snm mnm) (r :: TypeRef snm) where
|
||||
RetPrimitive :: ReturnQuery p ('PrimitiveRef t)
|
||||
RetSchema :: ReturnQuery p ('SchemaRef sch sty)
|
||||
RetList :: ReturnQuery p r -> ReturnQuery p ('ListRef r)
|
||||
RetOptional :: ReturnQuery p r -> ReturnQuery p ('OptionalRef r)
|
||||
RetObject :: ServiceQuery ('Package pname ss) (LookupService ss s)
|
||||
-> ReturnQuery ('Package pname ss) ('ObjectRef s)
|
240
graphql/src/Mu/GraphQL/Query/Parse.hs
Normal file
240
graphql/src/Mu/GraphQL/Query/Parse.hs
Normal file
@ -0,0 +1,240 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language ViewPatterns #-}
|
||||
|
||||
module Mu.GraphQL.Query.Parse where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Functor.Identity
|
||||
import Data.Int (Int32)
|
||||
import Data.List (find)
|
||||
import Data.Proxy
|
||||
import Data.SOP.NS
|
||||
import qualified Data.Text as T
|
||||
import GHC.TypeLits
|
||||
import qualified Language.GraphQL.Draft.Syntax as GQL
|
||||
|
||||
import Mu.GraphQL.Query.Definition
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
parseDoc ::
|
||||
( Alternative f, p ~ 'Package pname ss,
|
||||
LookupService ss qr ~ 'Service qr qanns qmethods,
|
||||
ParseMethod p qmethods,
|
||||
LookupService ss mut ~ 'Service mut manns mmethods,
|
||||
ParseMethod p mmethods
|
||||
) =>
|
||||
GQL.ExecutableDocument ->
|
||||
f (Document p qr mut)
|
||||
parseDoc (GQL.ExecutableDocument defns)
|
||||
= case GQL.partitionExDefs defns of
|
||||
([unnamed], [], _) -> QueryDoc <$> parseQuery Proxy Proxy unnamed
|
||||
([], [named], _) -> parseTypedDoc named
|
||||
_ -> empty
|
||||
|
||||
parseTypedDoc ::
|
||||
( Alternative f, p ~ 'Package pname ss,
|
||||
LookupService ss qr ~ 'Service qr qanns qmethods,
|
||||
ParseMethod p qmethods,
|
||||
LookupService ss mut ~ 'Service mut manns mmethods,
|
||||
ParseMethod p mmethods
|
||||
) =>
|
||||
GQL.TypedOperationDefinition ->
|
||||
f (Document p qr mut)
|
||||
parseTypedDoc tod@GQL.TypedOperationDefinition { GQL._todType = GQL.OperationTypeQuery }
|
||||
= QueryDoc <$> parseQuery Proxy Proxy (GQL._todSelectionSet tod)
|
||||
parseTypedDoc tod@GQL.TypedOperationDefinition { GQL._todType = GQL.OperationTypeMutation }
|
||||
= MutationDoc <$> parseQuery Proxy Proxy (GQL._todSelectionSet tod)
|
||||
parseTypedDoc _ = empty
|
||||
|
||||
-- TODO: turn Hasura's `ExecutableDefinition` into a service query
|
||||
-- Hint: start with the following function, and then move up
|
||||
-- (OperationDefinition -> ExecutableDefinition -> ExecutableDocument)
|
||||
parseQuery ::
|
||||
forall (p :: Package') (s :: Symbol) pname ss sanns methods f.
|
||||
( Alternative f, p ~ 'Package pname ss,
|
||||
LookupService ss s ~ 'Service s sanns methods,
|
||||
ParseMethod p methods
|
||||
) =>
|
||||
Proxy p ->
|
||||
Proxy s ->
|
||||
GQL.SelectionSet ->
|
||||
f (ServiceQuery p (LookupService ss s))
|
||||
parseQuery _ _ = traverse toOneMethod
|
||||
where
|
||||
toOneMethod :: GQL.Selection -> f (OneMethodQuery p ('Service sname sanns methods))
|
||||
toOneMethod (GQL.SelectionField fld) = fieldToMethod fld
|
||||
toOneMethod (GQL.SelectionFragmentSpread _) = empty -- FIXME:
|
||||
toOneMethod (GQL.SelectionInlineFragment _) = empty -- FIXME:
|
||||
fieldToMethod :: GQL.Field -> f (OneMethodQuery p ('Service sname sanns methods))
|
||||
fieldToMethod (GQL.Field alias name args _ sels) =
|
||||
OneMethodQuery (GQL.unName . GQL.unAlias <$> alias) <$> selectMethod name args sels
|
||||
|
||||
class ParseMethod (p :: Package') (ms :: [Method Symbol Symbol]) where
|
||||
selectMethod ::
|
||||
Alternative f =>
|
||||
GQL.Name ->
|
||||
[GQL.Argument] ->
|
||||
GQL.SelectionSet ->
|
||||
f (NS (ChosenMethodQuery p) ms)
|
||||
|
||||
instance ParseMethod p '[] where
|
||||
selectMethod _ _ _ = empty
|
||||
instance
|
||||
(KnownSymbol mname, ParseMethod p ms, ParseArgs p args, ParseReturn p r) =>
|
||||
ParseMethod p ('Method mname manns args ('RetSingle r) ': ms)
|
||||
where
|
||||
selectMethod w@(GQL.unName -> wanted) args sels
|
||||
| wanted == mname = Z <$> (ChosenMethodQuery <$> parseArgs args <*> parseReturn sels)
|
||||
| otherwise = S <$> selectMethod w args sels
|
||||
where
|
||||
mname = T.pack $ nameVal (Proxy @mname)
|
||||
|
||||
class ParseArgs (p :: Package') (args :: [Argument Symbol]) where
|
||||
parseArgs :: Alternative f => [GQL.Argument] -> f (NP (ArgumentValue p) args)
|
||||
|
||||
instance ParseArgs p '[] where
|
||||
parseArgs _ = pure Nil
|
||||
instance (ParseArg p a, ParseArgs p as) => ParseArgs p ('ArgSingle a ': as) where
|
||||
parseArgs (GQL.Argument _ x : xs) = (:*) <$> (ArgumentValue <$> parseArg x) <*> parseArgs xs
|
||||
parseArgs _ = empty
|
||||
|
||||
class ParseArg (p :: Package') (a :: TypeRef Symbol) where
|
||||
parseArg :: Alternative f => GQL.Value -> f (ArgumentValue' p a)
|
||||
|
||||
instance (ParseArg p r) => ParseArg p ('ListRef r) where
|
||||
parseArg (GQL.VList (GQL.ListValueG xs)) = ArgList <$> traverse parseArg xs
|
||||
parseArg _ = empty
|
||||
instance ParseArg p ('PrimitiveRef Bool) where
|
||||
parseArg (GQL.VBoolean b) = pure (ArgPrimitive b)
|
||||
parseArg _ = empty
|
||||
instance ParseArg p ('PrimitiveRef Int32) where
|
||||
parseArg (GQL.VInt b) = pure (ArgPrimitive b)
|
||||
parseArg _ = empty
|
||||
instance ParseArg p ('PrimitiveRef Integer) where
|
||||
parseArg (GQL.VInt b) = pure $ ArgPrimitive $ fromIntegral b
|
||||
parseArg _ = empty
|
||||
instance ParseArg p ('PrimitiveRef Double) where
|
||||
parseArg (GQL.VFloat b) = pure (ArgPrimitive b)
|
||||
parseArg _ = empty
|
||||
instance ParseArg p ('PrimitiveRef T.Text) where
|
||||
parseArg (GQL.VString (GQL.StringValue b)) = pure $ ArgPrimitive b
|
||||
parseArg _ = empty
|
||||
instance ParseArg p ('PrimitiveRef String) where
|
||||
parseArg (GQL.VString (GQL.StringValue b)) = pure $ ArgPrimitive $ T.unpack b
|
||||
parseArg _ = empty
|
||||
instance ParseArg p ('PrimitiveRef ()) where
|
||||
parseArg GQL.VNull = pure $ ArgPrimitive ()
|
||||
parseArg _ = empty
|
||||
instance (ObjectOrEnumParser sch (sch :/: sty))
|
||||
=> ParseArg p ('SchemaRef sch sty) where
|
||||
parseArg v = ArgSchema <$> parseObjectOrEnum v
|
||||
|
||||
class ObjectOrEnumParser sch (t :: TypeDef Symbol Symbol) where
|
||||
parseObjectOrEnum :: Alternative f
|
||||
=> GQL.Value
|
||||
-> f (Term Identity sch t)
|
||||
|
||||
instance (ObjectParser sch args)
|
||||
=> ObjectOrEnumParser sch ('DRecord name args) where
|
||||
parseObjectOrEnum (GQL.VObject (GQL.ObjectValueG vs)) = TRecord <$> objectParser vs
|
||||
parseObjectOrEnum _ = empty
|
||||
instance (EnumParser choices)
|
||||
=> ObjectOrEnumParser sch ('DEnum name choices) where
|
||||
parseObjectOrEnum (GQL.VEnum (GQL.EnumValue nm)) = TEnum <$> enumParser nm
|
||||
parseObjectOrEnum _ = empty
|
||||
|
||||
class ObjectParser sch args where
|
||||
objectParser :: Alternative f
|
||||
=> [GQL.ObjectFieldG GQL.Value]
|
||||
-> f (NP (Field Identity sch) args)
|
||||
|
||||
instance ObjectParser sch '[] where
|
||||
objectParser _ = pure Nil
|
||||
instance
|
||||
(ObjectParser sch args, ValueParser sch v, KnownName nm) =>
|
||||
ObjectParser sch ('FieldDef nm v ': args)
|
||||
where
|
||||
objectParser args
|
||||
= case find ((== nameVal (Proxy @nm)) . T.unpack . GQL.unName . GQL._ofName) args of
|
||||
Just (GQL.ObjectFieldG _ v)
|
||||
-> (:*) <$> (Field . Identity <$> valueParser v) <*> objectParser args
|
||||
Nothing -> empty
|
||||
|
||||
class EnumParser (choices :: [ChoiceDef Symbol]) where
|
||||
enumParser :: Alternative f => GQL.Name -> f (NS Proxy choices)
|
||||
|
||||
instance EnumParser '[] where
|
||||
enumParser _ = empty
|
||||
instance (KnownName name, EnumParser choices)
|
||||
=> EnumParser ('ChoiceDef name ': choices) where
|
||||
enumParser w@(GQL.unName -> wanted)
|
||||
| wanted == mname = pure (Z Proxy)
|
||||
| otherwise = S <$> enumParser w
|
||||
where
|
||||
mname = T.pack $ nameVal (Proxy @name)
|
||||
|
||||
class ValueParser sch v where
|
||||
valueParser :: Alternative f
|
||||
=> GQL.Value
|
||||
-> f (FieldValue Identity sch v)
|
||||
|
||||
instance ValueParser sch 'TNull where
|
||||
valueParser GQL.VNull = pure FNull
|
||||
valueParser _ = empty
|
||||
instance ValueParser sch ('TPrimitive Bool) where
|
||||
valueParser (GQL.VBoolean b) = pure (FPrimitive b)
|
||||
valueParser _ = empty
|
||||
instance ValueParser sch ('TPrimitive Int32) where
|
||||
valueParser (GQL.VInt b) = pure (FPrimitive b)
|
||||
valueParser _ = empty
|
||||
instance ValueParser sch ('TPrimitive Integer) where
|
||||
valueParser (GQL.VInt b) = pure $ FPrimitive $ fromIntegral b
|
||||
valueParser _ = empty
|
||||
instance ValueParser sch ('TPrimitive Double) where
|
||||
valueParser (GQL.VFloat b) = pure (FPrimitive b)
|
||||
valueParser _ = empty
|
||||
instance ValueParser sch ('TPrimitive T.Text) where
|
||||
valueParser (GQL.VString (GQL.StringValue b)) = pure $ FPrimitive b
|
||||
valueParser _ = empty
|
||||
instance ValueParser sch ('TPrimitive String) where
|
||||
valueParser (GQL.VString (GQL.StringValue b)) = pure $ FPrimitive $ T.unpack b
|
||||
valueParser _ = empty
|
||||
instance (ValueParser sch r) => ValueParser sch ('TList r) where
|
||||
valueParser (GQL.VList (GQL.ListValueG xs)) = FList <$> traverse valueParser xs
|
||||
valueParser _ = empty
|
||||
instance (sch :/: sty ~ 'DRecord name args, ObjectParser sch args)
|
||||
=> ValueParser sch ('TSchematic sty) where
|
||||
valueParser (GQL.VObject (GQL.ObjectValueG vs)) = FSchematic <$> (TRecord <$> objectParser vs)
|
||||
valueParser _ = empty
|
||||
|
||||
class ParseReturn (p :: Package') (r :: TypeRef Symbol) where
|
||||
parseReturn :: Alternative f
|
||||
=> GQL.SelectionSet
|
||||
-> f (ReturnQuery p r)
|
||||
|
||||
instance ParseReturn p ('PrimitiveRef t) where
|
||||
parseReturn [] = pure RetPrimitive
|
||||
parseReturn _ = empty
|
||||
instance ParseReturn p ('SchemaRef sch sty) where
|
||||
parseReturn _ = pure RetSchema
|
||||
instance ParseReturn p r
|
||||
=> ParseReturn p ('ListRef r) where
|
||||
parseReturn s = RetList <$> parseReturn s
|
||||
instance ParseReturn p r
|
||||
=> ParseReturn p ('OptionalRef r) where
|
||||
parseReturn s = RetOptional <$> parseReturn s
|
||||
instance ( p ~ 'Package pname ss,
|
||||
LookupService ss s ~ 'Service s sanns methods,
|
||||
ParseMethod p methods
|
||||
) => ParseReturn p ('ObjectRef s) where
|
||||
parseReturn s = RetObject <$> parseQuery (Proxy @p) (Proxy @s) s
|
211
graphql/src/Mu/GraphQL/Query/Run.hs
Normal file
211
graphql/src/Mu/GraphQL/Query/Run.hs
Normal file
@ -0,0 +1,211 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language OverloadedLists #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TupleSections #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fprint-explicit-foralls #-}
|
||||
module Mu.GraphQL.Query.Run (
|
||||
runPipeline
|
||||
, runDocument
|
||||
, runQuery
|
||||
) where
|
||||
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Control.Monad.Writer
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Functor.Identity
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import GHC.TypeLits
|
||||
import qualified Language.GraphQL.Draft.Syntax as GQL
|
||||
|
||||
import Mu.GraphQL.Query.Definition
|
||||
import Mu.GraphQL.Query.Parse
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
import Mu.Server
|
||||
|
||||
data GraphQLError
|
||||
= GraphQLError ServerError [T.Text]
|
||||
|
||||
runPipeline
|
||||
:: forall qr mut (p :: Package') pname ss hs chn qanns qmethods manns mmethods.
|
||||
( p ~ 'Package pname ss
|
||||
, LookupService ss qr ~ 'Service qr qanns qmethods
|
||||
, ParseMethod p qmethods
|
||||
, LookupService ss mut ~ 'Service mut manns mmethods
|
||||
, ParseMethod p mmethods
|
||||
, RunQueryFindHandler p hs chn ss (LookupService ss qr) hs
|
||||
, MappingRight chn qr ~ ()
|
||||
, RunQueryFindHandler p hs chn ss (LookupService ss mut) hs
|
||||
, MappingRight chn mut ~ ()
|
||||
)
|
||||
=> ServerT Identity chn p ServerErrorIO hs
|
||||
-> Proxy qr -> Proxy mut -> GQL.ExecutableDocument
|
||||
-> IO Aeson.Value
|
||||
runPipeline svr _ _ doc
|
||||
= case parseDoc doc of
|
||||
Nothing ->
|
||||
return $
|
||||
Aeson.object [
|
||||
("errors", Aeson.Array [
|
||||
Aeson.object [ ("message", Aeson.String "cannot parse document") ] ])]
|
||||
Just (d :: Document p qr mut) -> do
|
||||
(data_, errors) <- runWriterT (runDocument svr d)
|
||||
case errors of
|
||||
[] -> return $ Aeson.object [ ("data", data_) ]
|
||||
_ -> return $ Aeson.object [ ("data", data_), ("errors", Aeson.listValue errValue errors) ]
|
||||
where
|
||||
errValue :: GraphQLError -> Aeson.Value
|
||||
errValue (GraphQLError (ServerError _ msg) path)
|
||||
= Aeson.object [
|
||||
("message", Aeson.String $ T.pack msg)
|
||||
, ("path", Aeson.toJSON path)
|
||||
]
|
||||
|
||||
|
||||
runDocument
|
||||
:: ( p ~ 'Package pname ss
|
||||
, RunQueryFindHandler p hs chn ss (LookupService ss qr) hs
|
||||
, MappingRight chn qr ~ ()
|
||||
, RunQueryFindHandler p hs chn ss (LookupService ss mut) hs
|
||||
, MappingRight chn mut ~ ()
|
||||
)
|
||||
=> ServerT Identity chn p ServerErrorIO hs
|
||||
-> Document p qr mut
|
||||
-> WriterT [GraphQLError] IO Aeson.Value
|
||||
runDocument svr (QueryDoc q)
|
||||
= runQuery svr () q
|
||||
runDocument svr (MutationDoc q)
|
||||
= runQuery svr () q
|
||||
|
||||
runQuery
|
||||
:: forall p s pname ss hs sname sanns ms chn inh.
|
||||
( RunQueryFindHandler p hs chn ss s hs
|
||||
, p ~ 'Package pname ss
|
||||
, s ~ 'Service sname sanns ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> ServerT Identity chn p ServerErrorIO hs
|
||||
-> inh
|
||||
-> ServiceQuery p s
|
||||
-> WriterT [GraphQLError] IO Aeson.Value
|
||||
runQuery whole@(Services ss) = runQueryFindHandler whole ss
|
||||
|
||||
class RunQueryFindHandler p whole chn ss s hs where
|
||||
runQueryFindHandler
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname sanns ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> ServerT Identity chn p ServerErrorIO whole
|
||||
-> ServicesT Identity chn ss ServerErrorIO hs
|
||||
-> inh
|
||||
-> ServiceQuery p s
|
||||
-> WriterT [GraphQLError] IO Aeson.Value
|
||||
|
||||
instance TypeError ('Text "Could not find handler for " ':<>: 'ShowType s)
|
||||
=> RunQueryFindHandler p whole chn '[] s '[] where
|
||||
runQueryFindHandler = error "this should never be called"
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
RunQueryFindHandler p whole chn ss s hs
|
||||
=> RunQueryFindHandler p whole chn (other ': ss) s (h ': hs) where
|
||||
runQueryFindHandler whole (_ :<&>: that) = runQueryFindHandler whole that
|
||||
instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, RunMethod p whole chn sname ms h)
|
||||
=> RunQueryFindHandler p whole chn (s ': ss) s (h ': hs) where
|
||||
runQueryFindHandler whole (this :<&>: _) inh queries
|
||||
= Aeson.object . catMaybes <$> mapM runOneQuery queries
|
||||
where
|
||||
-- if we include the signature we have to write
|
||||
-- an explicit type signature for 'runQueryFindHandler'
|
||||
runOneQuery (OneMethodQuery nm args)
|
||||
= pass (do (val, methodName) <- runMethod whole (Proxy @sname) inh this args
|
||||
let realName = fromMaybe methodName nm
|
||||
-- choose between given name,
|
||||
-- or fallback to method name
|
||||
newVal = fmap (realName,) val
|
||||
pure (newVal, map (updateErrs realName)) )
|
||||
where -- add the additional path component to the errors
|
||||
updateErrs :: T.Text -> GraphQLError -> GraphQLError
|
||||
updateErrs methodName (GraphQLError err loc) = GraphQLError err (methodName : loc)
|
||||
|
||||
class RunMethod p whole chn sname ms hs where
|
||||
runMethod
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> ServerT Identity chn p ServerErrorIO whole
|
||||
-> Proxy sname -> inh
|
||||
-> HandlersT Identity chn inh ms ServerErrorIO hs
|
||||
-> NS (ChosenMethodQuery p) ms
|
||||
-> WriterT [GraphQLError] IO (Maybe Aeson.Value, T.Text)
|
||||
|
||||
instance RunMethod p whole chn s '[] '[] where
|
||||
runMethod = error "this should never be called"
|
||||
instance (RunMethod p whole chn s ms hs, KnownName mname, RunHandler p whole chn args r h)
|
||||
=> RunMethod p whole chn s ('Method mname anns args ('RetSingle r) ': ms) (h ': hs) where
|
||||
runMethod whole _ inh (h :<||>: _) (Z (ChosenMethodQuery args ret))
|
||||
= (, T.pack $ nameVal (Proxy @mname)) <$> runHandler whole (h inh) args ret
|
||||
runMethod whole p inh (_ :<||>: r) (S cont)
|
||||
= runMethod whole p inh r cont
|
||||
|
||||
class Handles Identity chn args ('RetSingle r) ServerErrorIO h
|
||||
=> RunHandler p whole chn args r h where
|
||||
runHandler :: ServerT Identity chn p ServerErrorIO whole
|
||||
-> h
|
||||
-> NP (ArgumentValue p) args
|
||||
-> ReturnQuery p r
|
||||
-> WriterT [GraphQLError] IO (Maybe Aeson.Value)
|
||||
|
||||
instance (ArgumentConversion chn ref t, RunHandler p whole chn rest r h)
|
||||
=> RunHandler p whole chn ('ArgSingle 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)
|
||||
=> RunHandler p whole chn '[] r (ServerErrorIO l) where
|
||||
runHandler whole h Nil q = do
|
||||
res <- liftIO $ runExceptT h
|
||||
case res of
|
||||
Right v -> convertResult whole q v
|
||||
Left e -> tell [GraphQLError e []] >> return Nothing
|
||||
|
||||
class FromRef Identity chn ref t
|
||||
=> ArgumentConversion chn ref t where
|
||||
convertArg :: Proxy chn -> ArgumentValue' p ref -> t
|
||||
instance ArgumentConversion chn ('PrimitiveRef s) s where
|
||||
convertArg _ (ArgPrimitive x) = x
|
||||
instance FromSchema Identity sch sty t
|
||||
=> ArgumentConversion chn ('SchemaRef sch sty) t where
|
||||
convertArg _ (ArgSchema x) = fromSchema x
|
||||
instance ArgumentConversion chn ref t
|
||||
=> ArgumentConversion chn ('ListRef ref) [t] where
|
||||
convertArg p (ArgList x) = convertArg p <$> x
|
||||
instance ArgumentConversion chn ref t
|
||||
=> ArgumentConversion chn ('OptionalRef ref) (Maybe t) where
|
||||
convertArg p (ArgOptional x) = convertArg p <$> x
|
||||
|
||||
class ToRef Identity chn r l => ResultConversion p whole chn r l where
|
||||
convertResult :: ServerT Identity chn p ServerErrorIO whole
|
||||
-> ReturnQuery p r
|
||||
-> l -> WriterT [GraphQLError] IO (Maybe Aeson.Value)
|
||||
|
||||
instance Aeson.ToJSON t => ResultConversion p whole chn ('PrimitiveRef t) t where
|
||||
convertResult _ RetPrimitive = return . Just . Aeson.toJSON
|
||||
instance ( ToSchema Identity sch l r
|
||||
, Aeson.ToJSON (Term Identity sch (sch :/: l)) )
|
||||
=> ResultConversion p whole chn ('SchemaRef sch l) r where
|
||||
convertResult _ RetSchema = return . Just . Aeson.toJSON . toSchema' @_ @_ @sch @Identity @r
|
||||
instance ( MappingRight chn ref ~ t
|
||||
, MappingRight chn sname ~ t
|
||||
, LookupService ss ref ~ 'Service sname sanns ms
|
||||
, RunQueryFindHandler ('Package pname ss) whole chn ss ('Service sname sanns ms) whole)
|
||||
=> ResultConversion ('Package pname ss) whole chn ('ObjectRef ref) t where
|
||||
convertResult whole (RetObject q) h
|
||||
= Just <$> runQuery @('Package pname ss) @(LookupService ss ref) whole h q
|
||||
-- TODO: be able to return enums
|
@ -30,6 +30,7 @@ library
|
||||
other-modules: Mu.GRpc.Client.Internal
|
||||
build-depends:
|
||||
async
|
||||
, avro >=0.4.7
|
||||
, base >=4.12 && <5
|
||||
, bytestring
|
||||
, conduit
|
||||
|
@ -32,7 +32,7 @@ sayHello' host port req
|
||||
fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest (Just req))
|
||||
|
||||
sayHello :: GrpcClient -> M HelloRequest -> IO (GRpcReply (M HelloResponse))
|
||||
sayHello = gRpcCall @'MsgProtoBuf @QuickStartService @"SayHello"
|
||||
sayHello = gRpcCall @'MsgProtoBuf @QuickStartService @"Greeter" @"SayHello"
|
||||
|
||||
sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply (Maybe T.Text)]
|
||||
sayHi' host port n
|
||||
@ -41,4 +41,4 @@ sayHi' host port n
|
||||
runConduit $ cndt .| C.map (fmap (\(HelloResponse r) -> r)) .| consume
|
||||
|
||||
sayHi :: GrpcClient -> M HiRequest -> IO (ConduitT () (GRpcReply (M HelloResponse)) IO ())
|
||||
sayHi = gRpcCall @'MsgProtoBuf @QuickStartService @"SayHi"
|
||||
sayHi = gRpcCall @'MsgProtoBuf @QuickStartService @"Greeter" @"SayHi"
|
||||
|
@ -11,6 +11,7 @@
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fprint-explicit-kinds #-}
|
||||
-- | Client for gRPC services defined using Mu 'Service'
|
||||
module Mu.GRpc.Client.Internal where
|
||||
|
||||
@ -19,11 +20,14 @@ import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TMChan
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Avro
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import Data.Conduit.TMChan
|
||||
import Data.Functor.Identity
|
||||
import Data.Kind
|
||||
import GHC.TypeLits
|
||||
import Network.GRPC.Client (CompressMode (..), IncomingEvent (..),
|
||||
OutgoingEvent (..), RawReply, StreamDone (..))
|
||||
import Network.GRPC.Client.Helpers
|
||||
@ -41,14 +45,14 @@ import Mu.Schema
|
||||
setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient)
|
||||
setupGrpcClient' = runExceptT . setupGrpcClient
|
||||
|
||||
class GRpcServiceMethodCall (p :: GRpcMessageProtocol) (s :: Service snm mnm) (m :: Method mnm) h where
|
||||
gRpcServiceMethodCall :: Proxy p -> Proxy s -> Proxy m -> GrpcClient -> h
|
||||
instance ( KnownName serviceName, KnownName (FindPackageName anns), KnownName mname
|
||||
class GRpcServiceMethodCall (p :: GRpcMessageProtocol)
|
||||
(pkg :: snm) (s :: snm) (m :: Method snm mnm) h where
|
||||
gRpcServiceMethodCall :: Proxy p -> Proxy pkg -> Proxy s -> Proxy m -> GrpcClient -> h
|
||||
instance ( KnownName serviceName, KnownName pkg, KnownName mname
|
||||
, GRpcMethodCall p ('Method mname manns margs mret) h, MkRPC p )
|
||||
=> GRpcServiceMethodCall p ('Service serviceName anns methods)
|
||||
('Method mname manns margs mret) h where
|
||||
gRpcServiceMethodCall pro _ = gRpcMethodCall @p rpc
|
||||
where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
|
||||
=> GRpcServiceMethodCall p pkg serviceName ('Method mname manns margs mret) h where
|
||||
gRpcServiceMethodCall pro _ _ = gRpcMethodCall @p rpc
|
||||
where pkgName = BS.pack (nameVal (Proxy @pkg))
|
||||
svrName = BS.pack (nameVal (Proxy @serviceName))
|
||||
metName = BS.pack (nameVal (Proxy @mname))
|
||||
rpc = mkRPC pro pkgName svrName metName
|
||||
@ -80,15 +84,15 @@ buildGRpcReply3 (Right _) = GRpcOk ()
|
||||
simplifyResponse :: ClientIO (GRpcReply a) -> IO (GRpcReply a)
|
||||
simplifyResponse reply = do
|
||||
r <- runExceptT reply
|
||||
case r of
|
||||
Left e -> return $ GRpcClientError e
|
||||
Right v -> return v
|
||||
pure $ case r of
|
||||
Left e -> GRpcClientError e
|
||||
Right v -> v
|
||||
|
||||
-- These type classes allow us to abstract over
|
||||
-- the choice of message protocol (PB or Avro)
|
||||
|
||||
class GRPCInput (RPCTy p) (GRpcIWTy p ref r)
|
||||
=> GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where
|
||||
=> GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where
|
||||
type GRpcIWTy p ref r :: Type
|
||||
buildGRpcIWTy :: Proxy p -> Proxy ref -> r -> GRpcIWTy p ref r
|
||||
|
||||
@ -97,13 +101,15 @@ instance ToProtoBufTypeRef ref r
|
||||
type GRpcIWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r
|
||||
buildGRpcIWTy _ _ = ViaToProtoBufTypeRef
|
||||
|
||||
instance (GRPCInput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) r))
|
||||
=> GRpcInputWrapper 'MsgAvro ('ViaSchema sch sty) r where
|
||||
type GRpcIWTy 'MsgAvro ('ViaSchema sch sty) r = ViaToAvroTypeRef ('ViaSchema sch sty) r
|
||||
instance forall (sch :: Schema') (sty :: Symbol) (r :: Type).
|
||||
( ToSchema Identity sch sty r
|
||||
, ToAvro (Term Identity sch (sch :/: sty)) )
|
||||
=> GRpcInputWrapper 'MsgAvro ('SchemaRef sch sty) r where
|
||||
type GRpcIWTy 'MsgAvro ('SchemaRef sch sty) r = ViaToAvroTypeRef ('SchemaRef sch sty) r
|
||||
buildGRpcIWTy _ _ = ViaToAvroTypeRef
|
||||
|
||||
class GRPCOutput (RPCTy p) (GRpcOWTy p ref r)
|
||||
=> GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where
|
||||
=> GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where
|
||||
type GRpcOWTy p ref r :: Type
|
||||
unGRpcOWTy :: Proxy p -> Proxy ref -> GRpcOWTy p ref r -> r
|
||||
|
||||
@ -112,16 +118,18 @@ instance FromProtoBufTypeRef ref r
|
||||
type GRpcOWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r
|
||||
unGRpcOWTy _ _ = unViaFromProtoBufTypeRef
|
||||
|
||||
instance (GRPCOutput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) r))
|
||||
=> GRpcOutputWrapper 'MsgAvro ('ViaSchema sch sty) r where
|
||||
type GRpcOWTy 'MsgAvro ('ViaSchema sch sty) r = ViaFromAvroTypeRef ('ViaSchema sch sty) r
|
||||
instance forall (sch :: Schema') (sty :: Symbol) (r :: Type).
|
||||
( FromSchema Identity sch sty r
|
||||
, FromAvro (Term Identity sch (sch :/: sty)) )
|
||||
=> GRpcOutputWrapper 'MsgAvro ('SchemaRef sch sty) r where
|
||||
type GRpcOWTy 'MsgAvro ('SchemaRef sch sty) r = ViaFromAvroTypeRef ('SchemaRef sch sty) r
|
||||
unGRpcOWTy _ _ = unViaFromAvroTypeRef
|
||||
|
||||
-- -----------------------------
|
||||
-- IMPLEMENTATION OF THE METHODS
|
||||
-- -----------------------------
|
||||
|
||||
class GRpcMethodCall (p :: GRpcMessageProtocol) method h where
|
||||
class GRpcMethodCall (p :: GRpcMessageProtocol) (method :: Method Symbol Symbol) h where
|
||||
gRpcMethodCall :: RPCTy p -> Proxy method -> GrpcClient -> h
|
||||
|
||||
instance ( KnownName name
|
||||
@ -170,7 +178,7 @@ instance ( KnownName name
|
||||
GRpcOk _ -> -- no error, everything is fine
|
||||
sourceTMChan chan .| C.map GRpcOk
|
||||
e -> yield $ (\_ -> error "this should never happen") <$> e
|
||||
return go
|
||||
pure go
|
||||
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ()
|
||||
@ -207,8 +215,8 @@ instance ( KnownName name
|
||||
rawStreamClient @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) rpc client ()
|
||||
(\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan
|
||||
case nextVal of
|
||||
Nothing -> return ((), Left StreamDone)
|
||||
Just v -> return ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
|
||||
Nothing -> pure ((), Left StreamDone)
|
||||
Just v -> pure ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
|
||||
-- This conduit feeds information to the other thread
|
||||
let go = do x <- await
|
||||
case x of
|
||||
@ -216,7 +224,7 @@ instance ( KnownName name
|
||||
go
|
||||
Nothing -> do liftIO $ atomically $ closeTMChan chan
|
||||
liftIO $ wait promise
|
||||
return go
|
||||
pure go
|
||||
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
||||
@ -245,7 +253,7 @@ instance ( KnownName name
|
||||
GRpcOk _ -> -- no error, everything is fine
|
||||
sourceTMChan chan .| C.map GRpcOk
|
||||
e -> yield $ (\_ -> error "this should never happen") <$> e
|
||||
return go
|
||||
pure go
|
||||
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
||||
@ -268,12 +276,12 @@ instance ( KnownName name
|
||||
case ievent of
|
||||
RecvMessage o -> liftIO $ atomically $ writeTMChan inchan (GRpcOk $ unGRpcOWTy(Proxy @p) (Proxy @rref) o)
|
||||
Invalid e -> liftIO $ atomically $ writeTMChan inchan (GRpcErrorString (show e))
|
||||
_ -> return () )
|
||||
_ -> pure () )
|
||||
() (\_ -> do
|
||||
nextVal <- liftIO $ atomically $ readTMChan outchan
|
||||
case nextVal of
|
||||
Nothing -> return ((), Finalize)
|
||||
Just v -> return ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
|
||||
Nothing -> pure ((), Finalize)
|
||||
Just v -> pure ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
|
||||
case v of
|
||||
GRpcOk () -> liftIO $ atomically $ closeTMChan inchan
|
||||
_ -> liftIO $ atomically $ putTMVar var v
|
||||
@ -288,7 +296,7 @@ instance ( KnownName name
|
||||
go2
|
||||
Nothing -> do r <- liftIO $ atomically $ tryReadTMChan inchan
|
||||
case r of
|
||||
Nothing -> return () -- both are empty, end
|
||||
Nothing -> pure () -- both are empty, end
|
||||
Just Nothing -> go2
|
||||
Just (Just nextIn) -> yield nextIn >> go2
|
||||
return go
|
||||
pure go
|
||||
|
@ -49,9 +49,13 @@ import Mu.Schema
|
||||
import Mu.Schema.Optics
|
||||
|
||||
-- | Represents a connection to the service @s@.
|
||||
newtype GRpcConnection (s :: Service Symbol Symbol) (p :: GRpcMessageProtocol)
|
||||
newtype GRpcConnection (s :: Package') (p :: GRpcMessageProtocol)
|
||||
= GRpcConnection { gcClient :: G.GrpcClient }
|
||||
|
||||
-- | Represents a connection to a specific service @s@
|
||||
newtype GRpcConnectionService (pkg :: Package') (srv :: Service') (p :: GRpcMessageProtocol)
|
||||
= GRpcConnectionService { gcsClient :: G.GrpcClient }
|
||||
|
||||
-- | Initializes a connection to a gRPC server.
|
||||
-- Usually the service you are connecting to is
|
||||
-- inferred from the usage later on.
|
||||
@ -64,28 +68,43 @@ initGRpc :: G.GrpcClientConfig -- ^ gRPC configuration
|
||||
-> forall s. IO (Either ClientError (GRpcConnection s p))
|
||||
initGRpc config _ = do
|
||||
setup <- setupGrpcClient' config
|
||||
case setup of
|
||||
Left e -> return $ Left e
|
||||
Right c -> return $ Right $ GRpcConnection c
|
||||
pure $ case setup of
|
||||
Left e -> Left e
|
||||
Right c -> Right $ GRpcConnection c
|
||||
|
||||
instance forall (serviceName :: Symbol) anns (methods :: [Method Symbol]) (m :: Symbol)
|
||||
(t :: *) (p :: GRpcMessageProtocol).
|
||||
( SearchMethodOptic p methods m t
|
||||
instance forall (pkg :: Package') pkgName (services :: [Service'])
|
||||
(s :: Service')
|
||||
(p :: GRpcMessageProtocol) (m :: Symbol).
|
||||
( pkg ~ 'Package pkgName services, s ~ LookupService services m )
|
||||
=> LabelOptic m A_Getter
|
||||
(GRpcConnection pkg p)
|
||||
(GRpcConnection pkg p)
|
||||
(GRpcConnectionService pkg s p)
|
||||
(GRpcConnectionService pkg s p) where
|
||||
labelOptic = to (GRpcConnectionService . gcClient)
|
||||
|
||||
instance forall (pkg :: Package') (pkgName :: Symbol) (services :: [Service'])
|
||||
(service :: Service') (serviceName :: Symbol) (anns :: [ServiceAnnotation])
|
||||
(methods :: [Method Symbol Symbol])
|
||||
(p :: GRpcMessageProtocol) (m :: Symbol) t.
|
||||
( pkg ~ 'Package ('Just pkgName) services
|
||||
, service ~ 'Service serviceName anns methods
|
||||
, SearchMethodOptic p methods m t
|
||||
, KnownName serviceName
|
||||
, KnownName (FindPackageName anns)
|
||||
, KnownName pkgName
|
||||
, KnownName m
|
||||
, MkRPC p )
|
||||
=> LabelOptic m A_Getter
|
||||
(GRpcConnection ('Service serviceName anns methods) p)
|
||||
(GRpcConnection ('Service serviceName anns methods) p)
|
||||
(GRpcConnectionService pkg service p)
|
||||
(GRpcConnectionService pkg service p)
|
||||
t t where
|
||||
labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcClient)
|
||||
where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
|
||||
labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcsClient)
|
||||
where pkgName = BS.pack (nameVal (Proxy @pkgName))
|
||||
svrName = BS.pack (nameVal (Proxy @serviceName))
|
||||
metName = BS.pack (nameVal (Proxy @m))
|
||||
rpc = mkRPC (Proxy @p) pkgName svrName metName
|
||||
|
||||
class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method Symbol]) (m :: Symbol) t
|
||||
class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method Symbol Symbol]) (m :: Symbol) t
|
||||
| p methods m -> t where
|
||||
searchMethodOptic :: Proxy methods -> Proxy m -> RPCTy p -> G.GrpcClient -> t
|
||||
|
||||
@ -101,7 +120,7 @@ instance {-# OVERLAPPABLE #-} SearchMethodOptic p rest name t
|
||||
searchMethodOptic _ = searchMethodOptic @p (Proxy @rest)
|
||||
|
||||
class GRpcMethodCall p method t
|
||||
=> MethodOptic (p :: GRpcMessageProtocol) (method :: Method Symbol) t
|
||||
=> MethodOptic (p :: GRpcMessageProtocol) (method :: Method Symbol Symbol) t
|
||||
| p method -> t where
|
||||
methodOptic :: RPCTy p -> Proxy method -> G.GrpcClient -> t
|
||||
methodOptic = gRpcMethodCall @p
|
||||
@ -116,46 +135,46 @@ instance forall (name :: Symbol) anns t p.
|
||||
, t ~ IO (GRpcReply ()) )
|
||||
=> MethodOptic p ('Method name anns '[ ] 'RetNothing) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p w.
|
||||
( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('ViaSchema sch r))) t
|
||||
( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t
|
||||
, ProtocolWrapper p w
|
||||
, t ~ IO (GRpcReply (Term w sch (sch :/: r))) )
|
||||
=> MethodOptic p ('Method name anns '[ ] ('RetSingle ('ViaSchema sch r))) t
|
||||
=> MethodOptic p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p w.
|
||||
( GRpcMethodCall p ('Method name anns '[ ] ('RetStream ('ViaSchema sch r))) t
|
||||
( GRpcMethodCall p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t
|
||||
, ProtocolWrapper p w
|
||||
, t ~ IO (ConduitT () (GRpcReply (Term w sch (sch :/: r))) IO ()) )
|
||||
=> MethodOptic p ('Method name anns '[ ] ('RetStream ('ViaSchema sch r))) t
|
||||
=> MethodOptic p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t
|
||||
-- Simple arguments
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) anns t p w.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] 'RetNothing) t
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] 'RetNothing) t
|
||||
, ProtocolWrapper p w
|
||||
, t ~ (Term w sch (sch :/: v) -> IO (GRpcReply ())) )
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] 'RetNothing) t
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] 'RetNothing) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('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 ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('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 ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
-- Stream arguments
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('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 ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('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 ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
|
@ -49,35 +49,41 @@ import Mu.Rpc
|
||||
|
||||
-- | Fills in a Haskell record of functions with the corresponding
|
||||
-- calls to gRPC services from a Mu 'Service' declaration.
|
||||
buildService :: forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol) t
|
||||
(nm :: Symbol) (anns :: [ServiceAnnotation]) (ms :: [Method Symbol]).
|
||||
(s ~ 'Service nm anns ms, Generic t, BuildService pro s p ms (Rep t))
|
||||
buildService :: forall (pro :: GRpcMessageProtocol)
|
||||
(pkg :: Package') (s :: Symbol) (p :: Symbol) t
|
||||
(pkgName :: Symbol) (ss :: [Service'])
|
||||
(anns :: [ServiceAnnotation]) (ms :: [Method Symbol Symbol]).
|
||||
( pkg ~ 'Package ('Just pkgName) ss
|
||||
, LookupService ss s ~ 'Service s anns ms
|
||||
, Generic t
|
||||
, BuildService pro pkgName s p ms (Rep t) )
|
||||
=> GrpcClient -> t
|
||||
buildService client = to (buildService' (Proxy @pro) (Proxy @s) (Proxy @p) (Proxy @ms) client)
|
||||
buildService client
|
||||
= to (buildService' (Proxy @pro) (Proxy @pkgName) (Proxy @s) (Proxy @p) (Proxy @ms) client)
|
||||
|
||||
class BuildService (pro :: GRpcMessageProtocol) (s :: Service')
|
||||
(p :: Symbol) (ms :: [Method Symbol]) (f :: * -> *) where
|
||||
buildService' :: Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
|
||||
class BuildService (pro :: GRpcMessageProtocol) (pkg :: Symbol) (s :: Symbol)
|
||||
(p :: Symbol) (ms :: [Method Symbol Symbol]) (f :: * -> *) where
|
||||
buildService' :: Proxy pro -> Proxy pkg -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
|
||||
|
||||
instance BuildService pro s p ms U1 where
|
||||
buildService' _ _ _ _ _ = U1
|
||||
instance BuildService pro s p ms f => BuildService pro s p ms (D1 meta f) where
|
||||
buildService' ppro ps ppr pms client
|
||||
= M1 (buildService' ppro ps ppr pms client)
|
||||
instance BuildService pro s p ms f => BuildService pro s p ms (C1 meta f) where
|
||||
buildService' ppro ps ppr pms client
|
||||
= M1 (buildService' ppro ps ppr pms client)
|
||||
instance BuildService pro pkg s p ms U1 where
|
||||
buildService' _ _ _ _ _ _ = U1
|
||||
instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (D1 meta f) where
|
||||
buildService' ppro ppkg ps ppr pms client
|
||||
= M1 (buildService' ppro ppkg ps ppr pms client)
|
||||
instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (C1 meta f) where
|
||||
buildService' ppro ppkg ps ppr pms client
|
||||
= M1 (buildService' ppro ppkg ps ppr pms client)
|
||||
instance TypeError ('Text "building a service from sums is not supported")
|
||||
=> BuildService pro s p ms (f :+: g) where
|
||||
=> BuildService pro pkg s p ms (f :+: g) where
|
||||
buildService' = error "this should never happen"
|
||||
instance (BuildService pro s p ms f, BuildService pro s p ms g)
|
||||
=> BuildService pro s p ms (f :*: g) where
|
||||
buildService' ppro ps ppr pms client
|
||||
= buildService' ppro ps ppr pms client :*: buildService' ppro ps ppr pms client
|
||||
instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro s (s :-->: x) h)
|
||||
=> BuildService pro s p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where
|
||||
buildService' ppro ps _ _ client
|
||||
= M1 $ K1 $ gRpcServiceMethodCall ppro ps (Proxy @(s :-->: x)) client
|
||||
instance (BuildService pro pkg s p ms f, BuildService pro pkg s p ms g)
|
||||
=> BuildService pro pkg s p ms (f :*: g) where
|
||||
buildService' ppro ppkg ps ppr pms client
|
||||
= buildService' ppro ppkg ps ppr pms client :*: buildService' ppro ppkg ps ppr pms client
|
||||
instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro pkg sname (LookupMethod ms x) h)
|
||||
=> BuildService pro pkg sname p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where
|
||||
buildService' ppro ppkg ps _ _ client
|
||||
= M1 $ K1 $ gRpcServiceMethodCall ppro ppkg ps (Proxy @(LookupMethod ms x)) client
|
||||
|
||||
-- TEMPLATE HASKELL
|
||||
-- ================
|
||||
@ -104,20 +110,20 @@ serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ _ methods
|
||||
[RecC (mkName complete) <$> mapM (methodToDecl fieldsPrefix tNamer) methods]
|
||||
[pure (DerivClause Nothing [ConT ''Generic])]
|
||||
let buildName = mkName ("build" ++ complete)
|
||||
s <- SigD buildName <$> [t|GrpcClient -> $(return (ConT (mkName complete)))|]
|
||||
s <- SigD buildName <$> [t|GrpcClient -> $(pure (ConT (mkName complete)))|]
|
||||
c <- Clause <$> pure []
|
||||
<*> (NormalB <$> [e|buildService @($(return $ ConT serviceTyName))
|
||||
@($(return $ LitT (StrTyLit fieldsPrefix)))|])
|
||||
<*> (NormalB <$> [e|buildService @($(pure $ ConT serviceTyName))
|
||||
@($(pure $ LitT (StrTyLit fieldsPrefix)))|])
|
||||
<*> pure []
|
||||
return [d, s, FunD buildName [c]]
|
||||
pure [d, s, FunD buildName [c]]
|
||||
|
||||
methodToDecl :: String -> Namer -> Method String -> Q (Name, Bang, Type)
|
||||
methodToDecl :: String -> Namer -> Method String String -> Q (Name, Bang, Type)
|
||||
methodToDecl fieldsPrefix tNamer (Method mName _ args ret)
|
||||
= do let nm = firstLower (fieldsPrefix ++ mName)
|
||||
ty <- computeMethodType tNamer args ret
|
||||
return ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty )
|
||||
pure ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty )
|
||||
|
||||
computeMethodType :: Namer -> [Argument] -> Return -> Q Type
|
||||
computeMethodType :: Namer -> [Argument String] -> Return String -> Q Type
|
||||
computeMethodType _ [] RetNothing
|
||||
= [t|IO (GRpcReply ())|]
|
||||
computeMethodType n [] (RetSingle r)
|
||||
@ -134,11 +140,11 @@ computeMethodType n [ArgStream v] (RetStream r)
|
||||
= [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|]
|
||||
computeMethodType _ _ _ = fail "method signature not supported"
|
||||
|
||||
typeRefToType :: Namer -> TypeRef -> Q Type
|
||||
typeRefToType tNamer (ViaTH (LitT (StrTyLit s)))
|
||||
= return $ ConT (mkName $ completeName tNamer s)
|
||||
typeRefToType _tNamer (ViaTH ty)
|
||||
= return ty
|
||||
typeRefToType :: Namer -> TypeRef snm -> Q Type
|
||||
typeRefToType tNamer (THRef (LitT (StrTyLit s)))
|
||||
= pure $ ConT (mkName $ completeName tNamer s)
|
||||
typeRefToType _tNamer (THRef ty)
|
||||
= pure ty
|
||||
typeRefToType _ _ = error "this should never happen"
|
||||
|
||||
completeName :: Namer -> String -> String
|
||||
@ -167,7 +173,7 @@ typeToServiceDef toplevelty
|
||||
<*> pure []
|
||||
<*> mapM typeToMethodDef methods'
|
||||
|
||||
typeToMethodDef :: Type -> Maybe (Method String)
|
||||
typeToMethodDef :: Type -> Maybe (Method String String)
|
||||
typeToMethodDef ty
|
||||
= do (mn, _, args, ret) <- tyD4 'Method ty
|
||||
args' <- tyList args
|
||||
@ -176,12 +182,12 @@ typeToServiceDef toplevelty
|
||||
<*> mapM typeToArgDef args'
|
||||
<*> typeToRetDef ret
|
||||
|
||||
typeToArgDef :: Type -> Maybe Argument
|
||||
typeToArgDef :: Type -> Maybe (Argument String)
|
||||
typeToArgDef ty
|
||||
= ArgSingle <$> (tyD1 'ArgSingle ty >>= typeToTypeRef)
|
||||
<|> ArgStream <$> (tyD1 'ArgStream ty >>= typeToTypeRef)
|
||||
|
||||
typeToRetDef :: Type -> Maybe Return
|
||||
typeToRetDef :: Type -> Maybe (Return String)
|
||||
typeToRetDef ty
|
||||
= RetNothing <$ tyD0 'RetNothing ty
|
||||
<|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef)
|
||||
@ -189,12 +195,12 @@ typeToServiceDef toplevelty
|
||||
RetThrows <$> typeToTypeRef e <*> typeToTypeRef v)
|
||||
<|> RetStream <$> (tyD1 'RetStream ty >>= typeToTypeRef)
|
||||
|
||||
typeToTypeRef :: Type -> Maybe TypeRef
|
||||
typeToTypeRef :: Type -> Maybe (TypeRef snm)
|
||||
typeToTypeRef ty
|
||||
= (do (_,innerTy) <- tyD2 'ViaSchema ty
|
||||
return (ViaTH innerTy))
|
||||
<|> (do (_,innerTy,_) <- tyD3 'ViaRegistry ty
|
||||
return (ViaTH innerTy))
|
||||
= (do (_,innerTy) <- tyD2 'SchemaRef ty
|
||||
pure (THRef innerTy))
|
||||
<|> (do (_,innerTy,_) <- tyD3 'RegistryRef ty
|
||||
pure (THRef innerTy))
|
||||
|
||||
tyString :: Type -> Maybe String
|
||||
tyString (SigT t _)
|
||||
|
@ -26,6 +26,7 @@ module Mu.GRpc.Client.TyApps (
|
||||
, GRpcReply(..)
|
||||
) where
|
||||
|
||||
import GHC.TypeLits
|
||||
import Network.GRPC.Client (CompressMode (..))
|
||||
import Network.GRPC.Client.Helpers
|
||||
|
||||
@ -45,7 +46,12 @@ import Mu.GRpc.Client.Internal
|
||||
-- * The resulting value is always wrapped in 'GRpcReply'.
|
||||
-- * A single input or output turns into a single value.
|
||||
-- * A streaming input or output turns into a Conduit.
|
||||
gRpcCall :: forall (pro :: GRpcMessageProtocol) s methodName h.
|
||||
(GRpcServiceMethodCall pro s (s :-->: methodName) h)
|
||||
gRpcCall :: forall (pro :: GRpcMessageProtocol) (pkg :: Package')
|
||||
(srvName :: Symbol) (methodName :: Symbol) h pkgName services anns methods.
|
||||
( pkg ~ 'Package ('Just pkgName) services
|
||||
, LookupService services srvName ~ 'Service srvName anns methods
|
||||
, GRpcServiceMethodCall pro pkgName srvName (LookupMethod methods methodName) h)
|
||||
=> GrpcClient -> h
|
||||
gRpcCall = gRpcServiceMethodCall (Proxy @pro) (Proxy @s) (Proxy @(s :-->: methodName))
|
||||
gRpcCall
|
||||
= gRpcServiceMethodCall (Proxy @pro) (Proxy @pkgName) (Proxy @srvName)
|
||||
(Proxy @(LookupMethod methods methodName))
|
||||
|
@ -1,7 +1,9 @@
|
||||
name: mu-grpc-common
|
||||
version: 0.2.0.0
|
||||
synopsis: gRPC for Mu, common modules for client and server
|
||||
description: Use @mu-grpc-server@ or @mu-grpc-client@ (the common parts).
|
||||
description:
|
||||
Use @mu-grpc-server@ or @mu-grpc-client@ (the common parts).
|
||||
|
||||
license: Apache-2.0
|
||||
license-file: LICENSE
|
||||
author: Alejandro Serrano, Flavio Corpa
|
||||
|
@ -2,9 +2,9 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language KindSignatures #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
@ -34,7 +34,7 @@ import Network.GRPC.HTTP2.Types
|
||||
import Data.Monoid ((<>))
|
||||
#endif
|
||||
|
||||
import Mu.Adapter.Avro ()
|
||||
import Mu.Adapter.Avro ()
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
@ -45,9 +45,9 @@ instance IsRPC AvroRPC where
|
||||
path rpc = "/" <> pkg rpc <> "." <> srv rpc <> "/" <> meth rpc
|
||||
{-# INLINE path #-}
|
||||
|
||||
newtype ViaFromAvroTypeRef (ref :: TypeRef) t
|
||||
newtype ViaFromAvroTypeRef (ref :: TypeRef snm) t
|
||||
= ViaFromAvroTypeRef { unViaFromAvroTypeRef :: t }
|
||||
newtype ViaToAvroTypeRef (ref :: TypeRef) t
|
||||
newtype ViaToAvroTypeRef (ref :: TypeRef snm) t
|
||||
= ViaToAvroTypeRef { unViaToAvroTypeRef :: t }
|
||||
|
||||
instance GRPCInput AvroRPC () where
|
||||
@ -61,21 +61,21 @@ instance GRPCOutput AvroRPC () where
|
||||
instance forall (sch :: Schema') (sty :: Symbol) (i :: Type).
|
||||
( FromSchema Identity sch sty i
|
||||
, FromAvro (Term Identity sch (sch :/: sty)) )
|
||||
=> GRPCInput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) i) where
|
||||
=> GRPCInput AvroRPC (ViaFromAvroTypeRef ('SchemaRef sch sty) i) where
|
||||
encodeInput = error "eif/you should not call this"
|
||||
decodeInput _ i = (ViaFromAvroTypeRef . fromSchema' @_ @_ @sch @Identity <$>) <$> decoder i
|
||||
|
||||
instance forall (sch :: Schema') (sty :: Symbol) (i :: Type).
|
||||
( FromSchema Identity sch sty i
|
||||
, FromAvro (Term Identity sch (sch :/: sty)) )
|
||||
=> GRPCOutput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) i) where
|
||||
=> GRPCOutput AvroRPC (ViaFromAvroTypeRef ('SchemaRef sch sty) i) where
|
||||
encodeOutput = error "eof/you should not call this"
|
||||
decodeOutput _ i = (ViaFromAvroTypeRef . fromSchema' @_ @_ @sch @Identity <$>) <$> decoder i
|
||||
|
||||
instance forall (sch :: Schema') (sty :: Symbol) (o :: Type).
|
||||
( ToSchema Identity sch sty o
|
||||
, ToAvro (Term Identity sch (sch :/: sty)) )
|
||||
=> GRPCInput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) o) where
|
||||
=> GRPCInput AvroRPC (ViaToAvroTypeRef ('SchemaRef sch sty) o) where
|
||||
encodeInput _ compression
|
||||
= encoder compression . toSchema' @_ @_ @sch @Identity . unViaToAvroTypeRef
|
||||
decodeInput = error "dit/you should not call this"
|
||||
@ -83,7 +83,7 @@ instance forall (sch :: Schema') (sty :: Symbol) (o :: Type).
|
||||
instance forall (sch :: Schema') (sty :: Symbol) (o :: Type).
|
||||
( ToSchema Identity sch sty o
|
||||
, ToAvro (Term Identity sch (sch :/: sty)) )
|
||||
=> GRPCOutput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) o) where
|
||||
=> GRPCOutput AvroRPC (ViaToAvroTypeRef ('SchemaRef sch sty) o) where
|
||||
encodeOutput _ compression
|
||||
= encoder compression . toSchema' @_ @_ @sch @Identity . unViaToAvroTypeRef
|
||||
decodeOutput = error "dot/you should not call this"
|
||||
|
@ -24,6 +24,7 @@ library
|
||||
exposed-modules: Mu.GRpc.Server
|
||||
build-depends:
|
||||
async
|
||||
, avro >=0.4.7
|
||||
, base >=4.12 && <5
|
||||
, binary
|
||||
, bytestring
|
||||
@ -51,6 +52,7 @@ executable grpc-example-server
|
||||
other-modules: Mu.GRpc.Server
|
||||
build-depends:
|
||||
async
|
||||
, avro >=0.4.7
|
||||
, base >=4.12 && <5
|
||||
, binary
|
||||
, bytestring
|
||||
|
@ -40,10 +40,12 @@ import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Exception
|
||||
import Control.Monad.Except
|
||||
import Data.Avro
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Conduit
|
||||
import Data.Conduit.TMChan
|
||||
import Data.Functor.Identity
|
||||
import Data.Kind
|
||||
import Data.Proxy
|
||||
import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput, gzip, uncompressed)
|
||||
@ -64,22 +66,20 @@ import Mu.Server
|
||||
|
||||
-- | Run a Mu 'Server' on the given port.
|
||||
runGRpcApp
|
||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
||||
, GRpcMethodHandlers protocol ServerErrorIO methods handlers )
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> Port
|
||||
-> ServerT f ('Service name anns methods) ServerErrorIO handlers
|
||||
-> ServerT f chn ('Package ('Just name) services) ServerErrorIO handlers
|
||||
-> IO ()
|
||||
runGRpcApp protocol port = runGRpcAppTrans protocol port id
|
||||
|
||||
-- | Run a Mu 'Server' on the given port.
|
||||
runGRpcAppTrans
|
||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
||||
, GRpcMethodHandlers protocol m methods handlers )
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> Port
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT f ('Service name anns methods) m handlers
|
||||
-> ServerT f chn ('Package ('Just name) services) m handlers
|
||||
-> IO ()
|
||||
runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr)
|
||||
|
||||
@ -87,12 +87,11 @@ runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr)
|
||||
--
|
||||
-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
||||
runGRpcAppSettings
|
||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
||||
, GRpcMethodHandlers protocol m methods handlers )
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> Settings
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT f ('Service name anns methods) m handlers
|
||||
-> ServerT f chn ('Package ('Just name) services) m handlers
|
||||
-> IO ()
|
||||
runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f svr)
|
||||
|
||||
@ -101,12 +100,11 @@ runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f s
|
||||
-- Go to 'Network.Wai.Handler.WarpTLS' to declare 'TLSSettings'
|
||||
-- and to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
||||
runGRpcAppTLS
|
||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
||||
, GRpcMethodHandlers protocol m methods handlers )
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> TLSSettings -> Settings
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT f ('Service name anns methods) m handlers
|
||||
-> ServerT f chn ('Package ('Just name) services) m handlers
|
||||
-> IO ()
|
||||
runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr)
|
||||
|
||||
@ -116,10 +114,9 @@ runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr
|
||||
-- for example, @wai-routes@, or you can add middleware
|
||||
-- from @wai-extra@, among others.
|
||||
gRpcApp
|
||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
||||
, GRpcMethodHandlers protocol ServerErrorIO methods handlers )
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> ServerT f ('Service name anns methods) ServerErrorIO handlers
|
||||
-> ServerT f chn ('Package ('Just name) services) ServerErrorIO handlers
|
||||
-> Application
|
||||
gRpcApp protocol = gRpcAppTrans protocol id
|
||||
|
||||
@ -129,40 +126,58 @@ gRpcApp protocol = gRpcAppTrans protocol id
|
||||
-- for example, @wai-routes@, or you can add middleware
|
||||
-- from @wai-extra@, among others.
|
||||
gRpcAppTrans
|
||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
||||
, GRpcMethodHandlers protocol m methods handlers )
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT f ('Service name anns methods) m handlers
|
||||
-> ServerT f chn ('Package ('Just name) services) m handlers
|
||||
-> Application
|
||||
gRpcAppTrans protocol f svr
|
||||
= Wai.grpcApp [uncompressed, gzip]
|
||||
(gRpcServiceHandlers protocol f svr)
|
||||
(gRpcServerHandlers protocol f svr)
|
||||
|
||||
gRpcServiceHandlers
|
||||
:: forall name anns methods handlers m protocol w.
|
||||
( KnownName name, KnownName (FindPackageName anns)
|
||||
, GRpcMethodHandlers protocol m methods handlers )
|
||||
gRpcServerHandlers
|
||||
:: forall name services handlers m protocol w chn.
|
||||
( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT w ('Service name anns methods) m handlers
|
||||
-> ServerT w chn ('Package ('Just name) services) m handlers
|
||||
-> [ServiceHandler]
|
||||
gRpcServiceHandlers pr f (Server svr) = gRpcMethodHandlers f pr packageName serviceName svr
|
||||
where packageName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
|
||||
serviceName = BS.pack (nameVal (Proxy @name))
|
||||
gRpcServerHandlers pr f (Services svr) = gRpcServiceHandlers f pr packageName svr
|
||||
where packageName = BS.pack (nameVal (Proxy @name))
|
||||
|
||||
class GRpcServiceHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type)
|
||||
(chn :: ServiceChain snm)
|
||||
(ss :: [Service snm mnm]) (hs :: [[Type]]) where
|
||||
gRpcServiceHandlers :: (forall a. m a -> ServerErrorIO a)
|
||||
-> Proxy p -> ByteString
|
||||
-> ServicesT f chn ss m hs -> [ServiceHandler]
|
||||
|
||||
instance GRpcServiceHandlers p m chn '[] '[] where
|
||||
gRpcServiceHandlers _ _ _ S0 = []
|
||||
instance ( KnownName name, GRpcMethodHandlers p m chn (MappingRight chn name) methods h
|
||||
, GRpcServiceHandlers p m chn rest hs )
|
||||
=> GRpcServiceHandlers p m chn ('Service name anns methods ': rest) (h ': hs) where
|
||||
gRpcServiceHandlers f pr packageName (svr :<&>: rest)
|
||||
= gRpcMethodHandlers f pr packageName serviceName svr
|
||||
++ gRpcServiceHandlers f pr packageName rest
|
||||
where serviceName = BS.pack (nameVal (Proxy @name))
|
||||
|
||||
|
||||
class GRpcMethodHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type)
|
||||
(ms :: [Method mnm]) (hs :: [Type]) where
|
||||
(chn :: ServiceChain snm) (inh :: Type)
|
||||
(ms :: [Method snm mnm]) (hs :: [Type]) where
|
||||
gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a)
|
||||
-> Proxy p -> ByteString -> ByteString
|
||||
-> HandlersT f ms m hs -> [ServiceHandler]
|
||||
-> HandlersT f chn inh ms m hs -> [ServiceHandler]
|
||||
|
||||
instance GRpcMethodHandlers p m '[] '[] where
|
||||
instance GRpcMethodHandlers p m chn inh '[] '[] where
|
||||
gRpcMethodHandlers _ _ _ _ H0 = []
|
||||
instance (KnownName name, GRpcMethodHandler p m args r h, GRpcMethodHandlers p m rest hs, MkRPC p)
|
||||
=> GRpcMethodHandlers p m ('Method name anns args r ': rest) (h ': hs) where
|
||||
gRpcMethodHandlers f pr p s (h :<|>: rest)
|
||||
= gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName) h
|
||||
instance ( KnownName name, MkRPC p
|
||||
, GRpcMethodHandler p m args r h
|
||||
, GRpcMethodHandlers p m chn () rest hs)
|
||||
=> GRpcMethodHandlers p m chn () ('Method name anns args r ': rest) (h ': hs) where
|
||||
gRpcMethodHandlers f pr p s (h :<||>: rest)
|
||||
= gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName) (h ())
|
||||
: gRpcMethodHandlers f pr p s rest
|
||||
where methodName = BS.pack (nameVal (Proxy @name))
|
||||
|
||||
@ -195,7 +210,7 @@ raiseErrors h
|
||||
= liftIO $ do
|
||||
h' <- runExceptT h
|
||||
case h' of
|
||||
Right r -> return r
|
||||
Right r -> pure r
|
||||
Left (ServerError code msg)
|
||||
-> closeEarly $ GRPCStatus (serverErrorToGRpcError code)
|
||||
(BS.pack msg)
|
||||
@ -222,7 +237,7 @@ raiseErrors h
|
||||
-- the choice of message protocol (PB or Avro)
|
||||
|
||||
class GRPCOutput (RPCTy p) (GRpcOWTy p ref r)
|
||||
=> GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where
|
||||
=> GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where
|
||||
type GRpcOWTy p ref r :: Type
|
||||
buildGRpcOWTy :: Proxy p -> Proxy ref -> r -> GRpcOWTy p ref r
|
||||
|
||||
@ -231,13 +246,15 @@ instance ToProtoBufTypeRef ref r
|
||||
type GRpcOWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r
|
||||
buildGRpcOWTy _ _ = ViaToProtoBufTypeRef
|
||||
|
||||
instance (GRPCOutput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) r))
|
||||
=> GRpcOutputWrapper 'MsgAvro ('ViaSchema sch sty) r where
|
||||
type GRpcOWTy 'MsgAvro ('ViaSchema sch sty) r = ViaToAvroTypeRef ('ViaSchema sch sty) r
|
||||
instance forall (sch :: Schema') sty (r :: Type).
|
||||
( ToSchema Identity sch sty r
|
||||
, ToAvro (Term Identity sch (sch :/: sty)) )
|
||||
=> GRpcOutputWrapper 'MsgAvro ('SchemaRef sch sty) r where
|
||||
type GRpcOWTy 'MsgAvro ('SchemaRef sch sty) r = ViaToAvroTypeRef ('SchemaRef sch sty) r
|
||||
buildGRpcOWTy _ _ = ViaToAvroTypeRef
|
||||
|
||||
class GRPCInput (RPCTy p) (GRpcIWTy p ref r)
|
||||
=> GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where
|
||||
=> GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where
|
||||
type GRpcIWTy p ref r :: Type
|
||||
unGRpcIWTy :: Proxy p -> Proxy ref -> GRpcIWTy p ref r -> r
|
||||
|
||||
@ -246,9 +263,11 @@ instance FromProtoBufTypeRef ref r
|
||||
type GRpcIWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r
|
||||
unGRpcIWTy _ _ = unViaFromProtoBufTypeRef
|
||||
|
||||
instance (GRPCInput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) r))
|
||||
=> GRpcInputWrapper 'MsgAvro ('ViaSchema sch sty) r where
|
||||
type GRpcIWTy 'MsgAvro ('ViaSchema sch sty) r = ViaFromAvroTypeRef ('ViaSchema sch sty) r
|
||||
instance forall (sch :: Schema') sty (r :: Type).
|
||||
( FromSchema Identity sch sty r
|
||||
, FromAvro (Term Identity sch (sch :/: sty)) )
|
||||
=> GRpcInputWrapper 'MsgAvro ('SchemaRef sch sty) r where
|
||||
type GRpcIWTy 'MsgAvro ('SchemaRef sch sty) r = ViaFromAvroTypeRef ('SchemaRef sch sty) r
|
||||
unGRpcIWTy _ _ = unViaFromAvroTypeRef
|
||||
|
||||
---
|
||||
@ -284,10 +303,10 @@ instance (GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r, MonadIO m)
|
||||
let readNext _
|
||||
= do nextOutput <- atomically $ takeTMVar var
|
||||
case nextOutput of
|
||||
Just o -> return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||
Just o -> pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||
Nothing -> do cancel promise
|
||||
return Nothing
|
||||
return ((), ServerStream readNext)
|
||||
pure Nothing
|
||||
pure ((), ServerStream readNext)
|
||||
|
||||
-----
|
||||
|
||||
@ -330,7 +349,7 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
||||
cstreamFinalizer _
|
||||
= atomically (closeTMChan chan) >> wait promise
|
||||
-- Return the information
|
||||
return ((), ClientStream cstreamHandler cstreamFinalizer)
|
||||
pure ((), ClientStream cstreamHandler cstreamFinalizer)
|
||||
|
||||
-----
|
||||
|
||||
@ -352,10 +371,10 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
||||
let readNext _
|
||||
= do nextOutput <- atomically $ takeTMVar var
|
||||
case nextOutput of
|
||||
Just o -> return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||
Just o -> pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||
Nothing -> do cancel promise
|
||||
return Nothing
|
||||
return ((), ServerStream readNext)
|
||||
pure Nothing
|
||||
pure ((), ServerStream readNext)
|
||||
|
||||
-----
|
||||
|
||||
@ -383,13 +402,13 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
||||
= do nextOutput <- atomically $ tryTakeTMVar var
|
||||
case nextOutput of
|
||||
Just (Just o) ->
|
||||
return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||
pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||
Just Nothing -> do
|
||||
cancel promise
|
||||
return Nothing
|
||||
pure Nothing
|
||||
Nothing -> -- no new elements to output
|
||||
readNext ()
|
||||
return ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext)
|
||||
pure ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext)
|
||||
|
||||
-----
|
||||
|
||||
|
@ -12,6 +12,7 @@ packages:
|
||||
- grpc/common
|
||||
- grpc/client
|
||||
- grpc/server
|
||||
- graphql
|
||||
- examples/health-check/avro
|
||||
- examples/health-check/protobuf
|
||||
- examples/route-guide
|
||||
@ -34,3 +35,5 @@ extra-deps:
|
||||
- hw-kafka-client-3.0.0
|
||||
- hw-kafka-conduit-2.6.0
|
||||
- HasBigDecimal-0.1.1
|
||||
- git: https://github.com/hasura/graphql-parser-hs.git
|
||||
commit: 1380495a7b3269b70a7ab3081d745a5f54171a9c
|
||||
|
@ -12,6 +12,7 @@ packages:
|
||||
- grpc/common
|
||||
- grpc/client
|
||||
- grpc/server
|
||||
- graphql
|
||||
- examples/health-check/avro
|
||||
- examples/health-check/protobuf
|
||||
- examples/route-guide
|
||||
@ -34,6 +35,8 @@ extra-deps:
|
||||
- hw-kafka-client-3.0.0
|
||||
- hw-kafka-conduit-2.6.0
|
||||
- HasBigDecimal-0.1.1
|
||||
- git: https://github.com/hasura/graphql-parser-hs.git
|
||||
commit: 1380495a7b3269b70a7ab3081d745a5f54171a9c
|
||||
# missing in the current LTS
|
||||
- primitive-0.7.0.0
|
||||
- primitive-extras-0.8
|
||||
|
Loading…
Reference in New Issue
Block a user