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

Co-authored-by: Flavio Corpa <flavio.corpa@47deg.com>

adapter/avro/src/Mu/Adapter/Avro.hs

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

adapter/avro/src/Mu/Quasi/Avro.hs

@@ -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))
+         [t| 'Package $(pkgType (A.ns protocol))
-                      $(typesToList <$> mapM (avroMethodToType schemaName') (S.toList $ A.messages protocol)) |]
+                '[ 'Service $(textToStrLit (A.pname protocol)) '[]
-       return [schemaDec, serviceDec]
+                            $(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

adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs

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

adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs

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

adapter/protobuf/src/Mu/Quasi/GRpc.hs

@@ -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)
+  = [t| 'Package $(pkgType pkg)
-                 $(typesToList <$> mapM (pbMethodToType schema) methods) |]
+          '[ 'Service $(textToStrLit nm) '[]
+                      $(typesToList <$> mapM (pbMethodToType schema) methods) ] |]
   where
-    pkgType Nothing  = [t| '[] |]
+    pkgType Nothing  = [t| 'Nothing |]
-    pkgType (Just p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]
+    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

adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs

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

cabal-fmt.sh

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

cabal.project

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

compendium-client/src/Compendium/Client.hs

@@ -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)
+          Left e   -> pure $ Left (OPEParse e)
-          Right pb -> return $ Right pb
+          Right pb -> pure $ Right pb

core/rpc/src/Mu/Rpc.hs

@@ -14,9 +14,10 @@ RPC-like microservices independently of the transport
 and protocol.
 -}
 module Mu.Rpc (
-  Service', Service(..)
+  Package', Package(..)
-, ServiceAnnotation, Package, FindPackageName
+, Service', Service(..), Object
-, Method(..), (:-->:)
+, 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]
+  = Service serviceName
-
+            [ServiceAnnotation]
--- | An annotation to define a package name.
+            [Method serviceName methodName]
---   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
 
 -- | A method is defined by its name, arguments, and return type.
-data Method methodName
+data Method serviceName methodName
-  = Method methodName [ServiceAnnotation] [Argument] Return
+  = 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 LookupMethod (s :: [Method snm mnm]) (m :: mnm) :: Method snm mnm where
-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
   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 serviceName where
-data TypeRef where
+  -- | A primitive type.
-  ViaSchema   :: Schema typeName fieldName -> typeName -> TypeRef
+  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
+  RetSingle  :: TypeRef serviceName -> Return serviceName
-  -- | Return a value or an error
+  -- | Return a stream of values.
-  --   (this can be found in Avro IDL).
+  RetStream  :: TypeRef serviceName -> Return serviceName
-  RetThrows :: TypeRef -> TypeRef -> Return
+  -- | Return a value or an error.
-  -- | Return a stream of values
+  RetThrows  :: TypeRef serviceName -> TypeRef serviceName -> Return serviceName
-  --   (this can be found in gRPC).
-  RetStream :: TypeRef -> Return

core/rpc/src/Mu/Rpc/Examples.hs

@@ -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"]
+  = 'Package ('Just "helloworld")
-      '[ 'Method "SayHello" '[]
+      '[ 'Service "Greeter" '[]
-                 '[ 'ArgSingle ('ViaSchema QuickstartSchema "HelloRequest") ]
+        '[ 'Method "SayHello" '[]
-                 ('RetSingle ('ViaSchema QuickstartSchema "HelloResponse"))
+          '[ 'ArgSingle ('SchemaRef QuickstartSchema "HelloRequest") ]
-       , 'Method "SayHi" '[]
+            ('RetSingle ('SchemaRef QuickstartSchema "HelloResponse"))
-                 '[ 'ArgSingle ('ViaSchema QuickstartSchema "HiRequest")]
+        , 'Method "SayHi" '[]
-                 ('RetStream ('ViaSchema QuickstartSchema "HelloResponse"))
+          '[ 'ArgSingle ('SchemaRef QuickstartSchema "HiRequest")]
-       , 'Method "SayManyHellos" '[]
+            ('RetStream ('SchemaRef QuickstartSchema "HelloResponse"))
-                 '[ 'ArgStream ('ViaSchema QuickstartSchema "HelloRequest")]
+        , 'Method "SayManyHellos" '[]
-                 ('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) ]
+          '[ '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)
+  where
-        sayHello (HelloRequest nm)
+    sayHello :: HelloRequest f -> m (HelloResponse f)
-          = return (HelloResponse (("hi, " <>) <$> nm))
+    sayHello (HelloRequest nm)
-        sayHi :: HiRequest f
+      = pure (HelloResponse (("hi, " <>) <$> nm))
-              -> ConduitT (HelloResponse f) Void m ()
+    sayHi :: HiRequest f
-              -> m ()
+          -> ConduitT (HelloResponse f) Void m ()
-        sayHi (HiRequest (likeMaybe -> Just n)) sink
+          -> m ()
-          = runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink
+    sayHi (HiRequest (likeMaybe -> Just n)) sink
-        sayHi (HiRequest _) sink
+      = runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink
-          = runConduit $ return () .| sink
+    sayHi (HiRequest _) sink
-        sayManyHellos :: ConduitT () (HelloRequest f) m ()
+      = runConduit $ pure () .| sink
-                      -> ConduitT (HelloResponse f) Void m ()
+    sayManyHellos :: ConduitT () (HelloRequest f) m ()
-                      -> m ()
+                  -> ConduitT (HelloResponse f) Void m ()
-        sayManyHellos source sink
+                  -> m ()
-          = runConduit $ source .| C.mapM sayHello .| sink
+    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 []

core/rpc/src/Mu/Server.hs

@@ -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.
+-- | Defines a mapping between outcome of
-data ServerT (w :: Type -> Type) (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where
+--   a service, and its representation as
-  Server :: HandlersT w methods m hs -> ServerT w ('Service sname anns methods) m hs
+--   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
+data HandlersT (w :: Type -> Type) (chn :: ServiceChain snm)
-  H0 :: HandlersT w '[] m '[]
+               (inh :: *) (methods :: [Method snm mnm])
-  (:<|>:) :: Handles w args ret m h => h -> HandlersT w ms m hs
+               (m :: Type -> Type) (hs :: [Type]) where
-          -> HandlersT w ('Method name anns args ret ': ms) m (h ': hs)
+  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 ToRef   (w :: Type -> Type) (chn :: ServiceChain snm)
-class FromRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type)
+              (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 t ~ s => ToRef w chn ('PrimitiveRef t) s
-instance ToRef w ('ViaRegistry subject t last) t
+instance ToSchema w sch sty t => ToRef w chn ('SchemaRef sch sty) t
-instance FromSchema w sch sty t => FromRef w ('ViaSchema sch sty) t
+instance MappingRight chn ref ~ t => ToRef w chn ('ObjectRef ref) t
-instance FromRef w ('ViaRegistry subject t last) 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
+         => Handles w chn ('ArgSingle ref ': args) ret m handler
-instance (MonadError ServerError m, FromRef w ref t, Handles w args ret m h,
+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
+         => Handles w chn '[] 'RetNothing m handler
-instance (MonadError ServerError m, ToRef w eref e, ToRef w vref v, handler ~ m (Either e v))
+instance (MonadError ServerError m, ToRef w chn eref e, ToRef w chn vref v, handler ~ m (Either e v))
-         => Handles w '[] ('RetThrows eref vref) m handler
+         => Handles w chn '[] ('RetThrows eref vref) m handler
-instance (MonadError ServerError m, ToRef w ref v, handler ~ m v)
+instance (MonadError ServerError m, ToRef w chn ref v, handler ~ m v)
-         => Handles w '[] ('RetSingle ref) m handler
+         => Handles w chn '[] ('RetSingle ref) m handler
-instance (MonadError ServerError m, ToRef w ref v, handler ~ (ConduitT v Void m () -> m ()))
+instance (MonadError ServerError m, ToRef w chn ref v, handler ~ (ConduitT v Void m () -> m ()))
-         => Handles w '[] ('RetStream ref) m handler
+         => Handles w chn '[] ('RetStream ref) m handler

core/schema/src/Mu/Adapter/Json.hs

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

core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs

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

core/schema/src/Mu/Schema/Definition.hs

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

core/schema/src/Mu/Schema/Interpretation/Schemaless.hs

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

default.nix

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

examples/health-check/avro/src/ClientRecord.hs

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

examples/health-check/avro/src/ClientTyApps.hs

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

examples/health-check/avro/src/Server.hs

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

examples/health-check/protobuf/src/ClientRecord.hs

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

examples/health-check/protobuf/src/ClientTyApps.hs

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

examples/health-check/protobuf/src/Server.hs

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

examples/route-guide/src/Server.hs

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

examples/seed/avro/src/Main.hs

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

examples/seed/protobuf/src/Main.hs

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

examples/seed/protobuf/src/Optics.hs

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

examples/todolist/src/Server.hs

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

examples/with-persistent/src/Client.hs

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

examples/with-persistent/src/ClientOptics.hs

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

examples/with-persistent/src/ClientRecord.hs

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

examples/with-persistent/src/Server.hs

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

generate-haddock-docs.sh

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

graphql/LICENSE

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

graphql/Setup.hs

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

graphql/hie.yaml

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

graphql/mu-graphql.cabal

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

graphql/src/Mu/GraphQL/Query/Definition.hs

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

graphql/src/Mu/GraphQL/Query/Parse.hs

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

graphql/src/Mu/GraphQL/Query/Run.hs

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

grpc/client/mu-grpc-client.cabal

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

grpc/client/src/Mu/GRpc/Client/Examples.hs

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

grpc/client/src/Mu/GRpc/Client/Internal.hs

@@ -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
+class GRpcServiceMethodCall (p :: GRpcMessageProtocol)
-  gRpcServiceMethodCall :: Proxy p -> Proxy s -> Proxy m -> GrpcClient -> h
+                            (pkg :: snm) (s :: snm) (m :: Method snm mnm) h where
-instance ( KnownName serviceName, KnownName (FindPackageName anns), KnownName mname
+  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)
+         => GRpcServiceMethodCall p pkg serviceName ('Method mname manns margs mret) h where
-                                  ('Method mname manns margs mret) h where
+  gRpcServiceMethodCall pro _ _ = gRpcMethodCall @p rpc
-  gRpcServiceMethodCall pro _ = gRpcMethodCall @p rpc
+    where pkgName = BS.pack (nameVal (Proxy @pkg))
-    where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
           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
+  pure $ case r of
-    Left e  -> return $ GRpcClientError e
+    Left e  -> GRpcClientError e
-    Right v -> return v
+    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))
+instance forall (sch :: Schema') (sty :: Symbol) (r :: Type).
-         => GRpcInputWrapper 'MsgAvro ('ViaSchema sch sty) r where
+         ( ToSchema Identity sch sty r
-  type GRpcIWTy 'MsgAvro ('ViaSchema sch sty) r = ViaToAvroTypeRef ('ViaSchema 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))
+instance forall (sch :: Schema') (sty :: Symbol) (r :: Type).
-         => GRpcOutputWrapper 'MsgAvro ('ViaSchema sch sty) r where
+         ( FromSchema Identity sch sty r
-  type GRpcOWTy 'MsgAvro ('ViaSchema sch sty) r = ViaFromAvroTypeRef ('ViaSchema 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)
+                                        Nothing -> pure ((), Left StreamDone)
-                                        Just v  -> return ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
+                                        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)
+                          Nothing -> pure ((), Finalize)
-                          Just v  -> return ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
+                          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

grpc/client/src/Mu/GRpc/Client/Optics.hs

@@ -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
+  pure $ case setup of
-    Left e  -> return $ Left e
+    Left e  -> Left e
-    Right c -> return $ Right $ GRpcConnection c
+    Right c -> Right $ GRpcConnection c
 
-instance forall (serviceName :: Symbol) anns (methods :: [Method Symbol]) (m :: Symbol)
+instance forall (pkg :: Package') pkgName (services :: [Service'])
-                (t :: *) (p :: GRpcMessageProtocol).
+                (s :: Service')
-         ( SearchMethodOptic p methods m t
+                (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)
+                       (GRpcConnectionService pkg service p)
-                       (GRpcConnection ('Service serviceName anns methods) p)
+                       (GRpcConnectionService pkg service p)
                        t t where
-  labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcClient)
+  labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcsClient)
-    where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
+    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

grpc/client/src/Mu/GRpc/Client/Record.hs

@@ -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
+buildService :: forall (pro :: GRpcMessageProtocol)
-                (nm :: Symbol) (anns :: [ServiceAnnotation]) (ms :: [Method Symbol]).
+                (pkg :: Package') (s :: Symbol) (p :: Symbol) t
-                (s ~ 'Service nm anns ms, Generic t, BuildService pro s p ms (Rep 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')
+class BuildService (pro :: GRpcMessageProtocol) (pkg :: Symbol) (s :: Symbol)
-                   (p :: Symbol) (ms :: [Method Symbol]) (f :: * -> *) where
+                   (p :: Symbol) (ms :: [Method Symbol Symbol]) (f :: * -> *) where
-  buildService' :: Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
+  buildService' :: Proxy pro -> Proxy pkg -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
 
-instance BuildService pro s p ms U1 where
+instance BuildService pro pkg s p ms U1 where
-  buildService' _ _ _ _ _ = U1
+  buildService' _ _ _ _ _ _ = U1
-instance BuildService pro s p ms f => BuildService pro s p ms (D1 meta f) where
+instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (D1 meta f) where
-  buildService' ppro ps ppr pms client
+  buildService' ppro ppkg ps ppr pms client
-    = M1 (buildService' ppro ps ppr pms client)
+    = M1 (buildService' ppro ppkg ps ppr pms client)
-instance BuildService pro s p ms f => BuildService pro s p ms (C1 meta f) where
+instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (C1 meta f) where
-  buildService' ppro ps ppr pms client
+  buildService' ppro ppkg ps ppr pms client
-    = M1 (buildService' ppro 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)
+instance (BuildService pro pkg s p ms f, BuildService pro pkg s p ms g)
-         => BuildService pro s p ms (f :*: g) where
+         => BuildService pro pkg s p ms (f :*: g) where
-  buildService' ppro ps ppr pms client
+  buildService' ppro ppkg ps ppr pms client
-    = buildService' ppro ps ppr pms client :*: buildService' ppro 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 s (s :-->: x) h)
+instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro pkg sname (LookupMethod ms x) h)
-         => BuildService pro s p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where
+         => BuildService pro pkg sname p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where
-  buildService' ppro ps _ _ client
+  buildService' ppro ppkg ps _ _ client
-    = M1 $ K1 $ gRpcServiceMethodCall ppro ps (Proxy @(s :-->: x)) 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))
+                   <*> (NormalB <$> [e|buildService @($(pure $ ConT serviceTyName))
-                                                    @($(return $ LitT (StrTyLit fieldsPrefix)))|])
+                                                    @($(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 :: Namer -> TypeRef snm -> Q Type
-typeRefToType tNamer (ViaTH (LitT (StrTyLit s)))
+typeRefToType tNamer (THRef (LitT (StrTyLit s)))
-  = return $ ConT (mkName $ completeName tNamer s)
+  = pure $ ConT (mkName $ completeName tNamer s)
-typeRefToType _tNamer (ViaTH ty)
+typeRefToType _tNamer (THRef ty)
-  = return 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
+      =   (do (_,innerTy) <- tyD2 'SchemaRef ty
-              return (ViaTH innerTy))
+              pure (THRef innerTy))
-      <|> (do (_,innerTy,_) <- tyD3 'ViaRegistry ty
+      <|> (do (_,innerTy,_) <- tyD3 'RegistryRef ty
-              return (ViaTH innerTy))
+              pure (THRef innerTy))
 
 tyString :: Type -> Maybe String
 tyString (SigT t _)

grpc/client/src/Mu/GRpc/Client/TyApps.hs

@@ -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.
+gRpcCall :: forall (pro :: GRpcMessageProtocol) (pkg :: Package')
-            (GRpcServiceMethodCall pro s (s :-->: methodName) h)
+                   (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))

grpc/common/mu-grpc-common.cabal

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

grpc/common/src/Mu/GRpc/Avro.hs

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

grpc/server/mu-grpc-server.cabal

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

grpc/server/src/Mu/GRpc/Server.hs

@@ -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)
+  :: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers )
-     , GRpcMethodHandlers protocol ServerErrorIO methods 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)
+  :: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
-     , GRpcMethodHandlers protocol m methods 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)
+  :: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
-     , GRpcMethodHandlers protocol m methods 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)
+  :: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
-     , GRpcMethodHandlers protocol m methods 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)
+  :: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers )
-     , GRpcMethodHandlers protocol ServerErrorIO methods 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)
+  :: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
-     , GRpcMethodHandlers protocol m methods 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
+gRpcServerHandlers
-  :: forall name anns methods handlers m protocol w.
+  :: forall name services handlers m protocol w chn.
-     ( KnownName name, KnownName (FindPackageName anns)
+     ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
-     , GRpcMethodHandlers protocol m methods 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
+gRpcServerHandlers pr f (Services svr) = gRpcServiceHandlers f pr packageName svr
-  where packageName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
+  where packageName = BS.pack (nameVal (Proxy @name))
-        serviceName = 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)
+instance ( KnownName name, MkRPC p
-         => GRpcMethodHandlers p m ('Method name anns args r ': rest) (h ': hs) where
+         , GRpcMethodHandler p m args r h
-  gRpcMethodHandlers f pr p s (h :<|>: rest)
+         , GRpcMethodHandlers p m chn () rest hs)
-    = gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName) h
+         => 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))
+instance forall (sch :: Schema') sty (r :: Type).
-         => GRpcOutputWrapper 'MsgAvro ('ViaSchema sch sty) r where
+         ( ToSchema Identity sch sty r
-  type GRpcOWTy 'MsgAvro ('ViaSchema sch sty) r = ViaToAvroTypeRef ('ViaSchema 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))
+instance forall (sch :: Schema') sty (r :: Type).
-         => GRpcInputWrapper 'MsgAvro ('ViaSchema sch sty) r where
+         ( FromSchema Identity sch sty r
-  type GRpcIWTy 'MsgAvro ('ViaSchema sch sty) r = ViaFromAvroTypeRef ('ViaSchema 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
+                                       pure Nothing
-            return ((), ServerStream readNext)
+            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
+                                       pure Nothing
-            return ((), ServerStream readNext)
+            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)
 
 -----
 

stack-nightly.yaml

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

stack.yaml

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