higherkindness/mu-haskell
1
1
Fork 0
mirror of https://github.com/higherkindness/mu-haskell.git synced 2024-07-14 17:50:22 +03:00
Code Issues Projects Releases Wiki Activity

New API to support GraphQL resolvers as services (#111)

Browse Source 
Co-authored-by: Flavio Corpa <flavio.corpa@47deg.com>
This commit is contained in:
Alejandro Serrano 2020-03-05 15:37:05 +01:00 committed by GitHub
parent 551b777b87
commit c1c23326ef
52 changed files with 1314 additions and 356 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
adapter/avro/src/Mu/Adapter/Avro.hs
View File

@ -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

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

@ -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

4
adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs
View File

@ -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)))

18
adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs
View File

@ -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)

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

@ -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

18
adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs
View File

@ -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
View 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' {} ';'

1
cabal.project
View File

@ -16,3 +16,4 @@ packages: compendium-client/
grpc/common/
grpc/client/
grpc/server/
graphql/

6
compendium-client/src/Compendium/Client.hs
View File

@ -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

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

@ -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

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

@ -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 []

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

@ -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

6
core/schema/src/Mu/Adapter/Json.hs
View File

@ -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

6
core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs
View File

@ -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"

10
core/schema/src/Mu/Schema/Definition.hs
View File

@ -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

2
core/schema/src/Mu/Schema/Interpretation/Schemaless.hs
View File

@ -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

1
default.nix
View File

@ -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;

2
examples/health-check/avro/src/ClientRecord.hs
View File

@ -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

10
examples/health-check/avro/src/ClientTyApps.hs
View File

@ -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)

2
examples/health-check/avro/src/Server.hs
View File

@ -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

2
examples/health-check/protobuf/src/ClientRecord.hs
View File

@ -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

12
examples/health-check/protobuf/src/ClientTyApps.hs
View File

@ -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 ())

6
examples/health-check/protobuf/src/Server.hs
View File

@ -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 ()

10
examples/route-guide/src/Server.hs
View File

@ -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

2
examples/seed/avro/src/Main.hs
View File

@ -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

2
examples/seed/protobuf/src/Main.hs
View File

@ -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

2
examples/seed/protobuf/src/Optics.hs
View File

@ -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

4
examples/todolist/src/Server.hs
View File

@ -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"

6
examples/with-persistent/src/Client.hs
View File

@ -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 ())

8
examples/with-persistent/src/ClientOptics.hs
View File

@ -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

2
examples/with-persistent/src/ClientRecord.hs
View File

@ -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

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

@ -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)

2
generate-haddock-docs.sh
View File

@ -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
View 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
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

1
graphql/hie.yaml Normal file
View File

@ -0,0 +1 @@
cradle: { stack: { component: "mu-graphql:lib" } }

39
graphql/mu-graphql.cabal Normal file
View 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
View 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
View 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
View 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

1
grpc/client/mu-grpc-client.cabal
View File

@ -30,6 +30,7 @@ library
other-modules: Mu.GRpc.Client.Internal
build-depends:
async
, avro >=0.4.7
, base >=4.12 && <5
, bytestring
, conduit

4
grpc/client/src/Mu/GRpc/Client/Examples.hs
View File

@ -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"

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

@ -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

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

@ -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

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

@ -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 _)

12
grpc/client/src/Mu/GRpc/Client/TyApps.hs
View File

@ -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))

4
grpc/common/mu-grpc-common.cabal
View File

@ -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

16
grpc/common/src/Mu/GRpc/Avro.hs
View File

@ -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"

2
grpc/server/mu-grpc-server.cabal
View File

@ -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

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

@ -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)
-----

3
stack-nightly.yaml
View File

@ -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

3
stack.yaml
View File

@ -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