diff --git a/adapter/avro/src/Mu/Adapter/Avro.hs b/adapter/avro/src/Mu/Adapter/Avro.hs index f8d8c98..660e3e7 100644 --- a/adapter/avro/src/Mu/Adapter/Avro.hs +++ b/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 diff --git a/adapter/avro/src/Mu/Quasi/Avro.hs b/adapter/avro/src/Mu/Quasi/Avro.hs index 099867a..97623d8 100644 --- a/adapter/avro/src/Mu/Quasi/Avro.hs +++ b/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)) - $(typesToList <$> mapM (avroMethodToType schemaName') (S.toList $ A.messages protocol)) |] - return [schemaDec, serviceDec] + [t| 'Package $(pkgType (A.ns protocol)) + '[ 'Service $(textToStrLit (A.pname protocol)) '[] + $(typesToList <$> mapM (avroMethodToType schemaName') + (S.toList $ A.messages protocol)) ] |] + pure [schemaDec, serviceDec] where - pkgType Nothing = [t| '[] |] + pkgType Nothing = [t| 'Nothing |] pkgType (Just (A.Namespace p)) - = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |] + = [t| 'Just $(textToStrLit (T.intercalate "." p)) |] schemaFromAvro :: [A.Schema] -> Q Type schemaFromAvro = @@ -181,7 +183,7 @@ avroMethodToType schemaName m where argToType :: A.Argument -> Q Type argToType (A.Argument (A.NamedType a) _) - = [t| 'ArgSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |] + = [t| 'ArgSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |] argToType (A.Argument _ _) = fail "only named types may be used as arguments" @@ -189,7 +191,7 @@ avroMethodToType schemaName m retToType A.Null = [t| 'RetNothing |] retToType (A.NamedType a) - = [t| 'RetSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |] + = [t| 'RetSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |] retToType _ = fail "only named types may be used as results" @@ -197,4 +199,4 @@ typesToList :: [Type] -> Type typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT textToStrLit :: T.Text -> Q Type -textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s +textToStrLit s = litT $ strTyLit $ T.unpack s diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs index ef5461b..f45f7e3 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs +++ b/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))) diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs index d5b7c7e..a726fa6 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs +++ b/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) diff --git a/adapter/protobuf/src/Mu/Quasi/GRpc.hs b/adapter/protobuf/src/Mu/Quasi/GRpc.hs index b03852a..623ca3e 100644 --- a/adapter/protobuf/src/Mu/Quasi/GRpc.hs +++ b/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) - $(typesToList <$> mapM (pbMethodToType schema) methods) |] + = [t| 'Package $(pkgType pkg) + '[ 'Service $(textToStrLit nm) '[] + $(typesToList <$> mapM (pbMethodToType schema) methods) ] |] where - pkgType Nothing = [t| '[] |] - pkgType (Just p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |] + pkgType Nothing = [t| 'Nothing |] + pkgType (Just p) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |] pbMethodToType :: Name -> P.Method -> Q Type pbMethodToType s (P.Method nm vr v rr r _) @@ -83,27 +84,27 @@ pbMethodToType s (P.Method nm vr v rr r _) argToType P.Single (P.TOther ["google","protobuf","Empty"]) = [t| '[ ] |] argToType P.Single (P.TOther a) - = [t| '[ 'ArgSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |] + = [t| '[ 'ArgSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |] argToType P.Stream (P.TOther a) - = [t| '[ 'ArgStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |] + = [t| '[ 'ArgStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |] argToType _ _ = fail "only message types may be used as arguments" retToType P.Single (P.TOther ["google","protobuf","Empty"]) = [t| 'RetNothing |] retToType P.Single (P.TOther a) - = [t| 'RetSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |] + = [t| 'RetSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |] retToType P.Stream (P.TOther a) - = [t| 'RetStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |] + = [t| 'RetStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |] retToType _ _ = fail "only message types may be used as results" schemaTy :: Name -> Q Type -schemaTy schema = return $ ConT schema +schemaTy schema = pure $ ConT schema typesToList :: [Type] -> Type typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT textToStrLit :: T.Text -> Q Type textToStrLit s - = return $ LitT $ StrTyLit $ T.unpack s + = pure $ LitT $ StrTyLit $ T.unpack s diff --git a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs index b9dc47b..86e4257 100644 --- a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs +++ b/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 diff --git a/cabal-fmt.sh b/cabal-fmt.sh old mode 100644 new mode 100755 index 8b44fb0..af06b54 --- a/cabal-fmt.sh +++ b/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' {} ';' diff --git a/cabal.project b/cabal.project index 61f8190..6651395 100644 --- a/cabal.project +++ b/cabal.project @@ -16,3 +16,4 @@ packages: compendium-client/ grpc/common/ grpc/client/ grpc/server/ + graphql/ diff --git a/compendium-client/src/Compendium/Client.hs b/compendium-client/src/Compendium/Client.hs index d5a8b8c..84fe5bd 100644 --- a/compendium-client/src/Compendium/Client.hs +++ b/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) - Right pb -> return $ Right pb + Left e -> pure $ Left (OPEParse e) + Right pb -> pure $ Right pb diff --git a/core/rpc/src/Mu/Rpc.hs b/core/rpc/src/Mu/Rpc.hs index c10f328..6ebd361 100644 --- a/core/rpc/src/Mu/Rpc.hs +++ b/core/rpc/src/Mu/Rpc.hs @@ -14,9 +14,10 @@ RPC-like microservices independently of the transport and protocol. -} module Mu.Rpc ( - Service', Service(..) -, ServiceAnnotation, Package, FindPackageName -, Method(..), (:-->:) + Package', Package(..) +, Service', Service(..), Object +, ServiceAnnotation, Method(..), ObjectField +, LookupService, LookupMethod , TypeRef(..), Argument(..), Return(..) ) where @@ -27,66 +28,82 @@ import qualified Language.Haskell.TH as TH import Mu.Schema import Mu.Schema.Registry +-- | Packages whose names are given by type-level strings. +type Package' = Package Symbol Symbol -- | Services whose names are given by type-level strings. type Service' = Service Symbol Symbol -- | Annotations for services. At this moment, such -- annotations can be of any type. type ServiceAnnotation = Type +-- | A package is a set of services. +data Package serviceName methodName + = Package (Maybe serviceName) + [Service serviceName methodName] + -- | A service is a set of methods. data Service serviceName methodName - = Service serviceName [ServiceAnnotation] [Method methodName] - --- | An annotation to define a package name. --- This is used by some handlers, like gRPC. -data Package (s :: Symbol) - --- | Find the 'Package' for a service, to be found --- as part of the annotations. -type family FindPackageName (anns :: [ServiceAnnotation]) :: Symbol where - FindPackageName '[] = TypeError ('Text "Cannot find package name for the service") - FindPackageName (Package s ': rest) = s - FindPackageName (other ': rest) = FindPackageName rest + = Service serviceName + [ServiceAnnotation] + [Method serviceName methodName] -- | A method is defined by its name, arguments, and return type. -data Method methodName - = Method methodName [ServiceAnnotation] [Argument] Return +data Method serviceName methodName + = Method methodName [ServiceAnnotation] + [Argument serviceName] + (Return serviceName) + +-- Synonyms for GraphQL +-- | An object is a set of fields, in GraphQL lingo. +type Object = 'Service +-- | A field in an object takes some input objects, +-- and returns a value or some other object, +-- in GraphQL lingo. +type ObjectField = 'Method + +type family LookupService (ss :: [Service snm mnm]) (s :: snm) :: Service snm mnm where + LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s) + LookupService ('Service s anns ms ': ss) s = 'Service s anns ms + LookupService (other ': ss) s = LookupService ss s -- | Look up a method in a service definition using its name. --- Useful to declare handlers like @HandlerIO (MyService :-->: "MyMethod")@. -type family (:-->:) (s :: Service snm mnm) (m :: mnm) :: Method mnm where - 'Service sname anns methods :-->: m = LookupMethod methods m - -type family LookupMethod (s :: [Method mnm]) (m :: snm) :: Method snm where +type family LookupMethod (s :: [Method snm mnm]) (m :: mnm) :: Method snm mnm where LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m) LookupMethod ('Method m anns args r ': ms) m = 'Method m anns args r LookupMethod (other ': ms) m = LookupMethod ms m --- | Defines how to handle the type -data TypeRef where - ViaSchema :: Schema typeName fieldName -> typeName -> TypeRef +data TypeRef serviceName where + -- | A primitive type. + PrimitiveRef :: Type -> TypeRef serviceName + -- | Chain with another service. + ObjectRef :: serviceName -> TypeRef serviceName + -- | Point to schema. + SchemaRef :: Schema typeName fieldName -> typeName -> TypeRef serviceName -- | Registry subject, type to convert to, and preferred serialization version - ViaRegistry :: Registry -> Type -> Nat -> TypeRef + RegistryRef :: Registry -> Type -> Nat -> TypeRef serviceName -- | To be used only during TH generation! - ViaTH :: TH.Type -> TypeRef + THRef :: TH.Type -> TypeRef serviceName + -- Combinators found in the gRPC and GraphQL languages. + -- | Represents a list of values. + ListRef :: TypeRef serviceName -> TypeRef serviceName + -- | Represents a possibly-missing value. + OptionalRef :: TypeRef serviceName -> TypeRef serviceName -- | Defines the way in which arguments are handled. -data Argument where +data Argument serviceName where -- | Use a single value. - ArgSingle :: TypeRef -> Argument + ArgSingle :: TypeRef serviceName -> Argument serviceName -- | Consume a stream of values. - ArgStream :: TypeRef -> Argument + ArgStream :: TypeRef serviceName -> Argument serviceName -- | Defines the different possibilities for returning -- information from a method. -data Return where +data Return serviceName where -- | Fire and forget. - RetNothing :: Return + RetNothing :: Return serviceName -- | Return a single value. - RetSingle :: TypeRef -> Return - -- | Return a value or an error - -- (this can be found in Avro IDL). - RetThrows :: TypeRef -> TypeRef -> Return - -- | Return a stream of values - -- (this can be found in gRPC). - RetStream :: TypeRef -> Return + RetSingle :: TypeRef serviceName -> Return serviceName + -- | Return a stream of values. + RetStream :: TypeRef serviceName -> Return serviceName + -- | Return a value or an error. + RetThrows :: TypeRef serviceName -> TypeRef serviceName -> Return serviceName diff --git a/core/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs index e817005..6c87c35 100644 --- a/core/rpc/src/Mu/Rpc/Examples.hs +++ b/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"] - '[ 'Method "SayHello" '[] - '[ 'ArgSingle ('ViaSchema QuickstartSchema "HelloRequest") ] - ('RetSingle ('ViaSchema QuickstartSchema "HelloResponse")) - , 'Method "SayHi" '[] - '[ 'ArgSingle ('ViaSchema QuickstartSchema "HiRequest")] - ('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) - , 'Method "SayManyHellos" '[] - '[ 'ArgStream ('ViaSchema QuickstartSchema "HelloRequest")] - ('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) ] + = 'Package ('Just "helloworld") + '[ 'Service "Greeter" '[] + '[ 'Method "SayHello" '[] + '[ 'ArgSingle ('SchemaRef QuickstartSchema "HelloRequest") ] + ('RetSingle ('SchemaRef QuickstartSchema "HelloResponse")) + , 'Method "SayHi" '[] + '[ 'ArgSingle ('SchemaRef QuickstartSchema "HiRequest")] + ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) + , 'Method "SayManyHellos" '[] + '[ 'ArgStream ('SchemaRef QuickstartSchema "HelloRequest")] + ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ] newtype HelloRequest f = HelloRequest { name :: f T.Text } deriving (Generic) deriving instance Functor f => ToSchema f QuickstartSchema "HelloRequest" (HelloRequest f) @@ -69,21 +70,62 @@ deriving instance Functor f => FromSchema f QuickstartSchema "HiRequest" (HiRequ quickstartServer :: forall m f. (MonadServer m, Applicative f, MaybeLike f) - => ServerT f QuickStartService m _ + => ServerT f '[] QuickStartService m _ quickstartServer = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0) - where sayHello :: HelloRequest f -> m (HelloResponse f) - sayHello (HelloRequest nm) - = return (HelloResponse (("hi, " <>) <$> nm)) - sayHi :: HiRequest f - -> ConduitT (HelloResponse f) Void m () - -> m () - sayHi (HiRequest (likeMaybe -> Just n)) sink - = runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink - sayHi (HiRequest _) sink - = runConduit $ return () .| sink - sayManyHellos :: ConduitT () (HelloRequest f) m () - -> ConduitT (HelloResponse f) Void m () - -> m () - sayManyHellos source sink - = runConduit $ source .| C.mapM sayHello .| sink + where + sayHello :: HelloRequest f -> m (HelloResponse f) + sayHello (HelloRequest nm) + = pure (HelloResponse (("hi, " <>) <$> nm)) + sayHi :: HiRequest f + -> ConduitT (HelloResponse f) Void m () + -> m () + sayHi (HiRequest (likeMaybe -> Just n)) sink + = runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink + sayHi (HiRequest _) sink + = runConduit $ pure () .| sink + sayManyHellos :: ConduitT () (HelloRequest f) m () + -> ConduitT (HelloResponse f) Void m () + -> m () + sayManyHellos source sink + = runConduit $ source .| C.mapM sayHello .| sink + +{- +From https://www.apollographql.com/docs/apollo-server/schema/schema/ + +type Book { + title: String + author: Author +} + +type Author { + name: String + books: [Book] +} +-} + +type ApolloService + = 'Package ('Just "apollo") + '[ Object "Book" '[] + '[ ObjectField "title" '[] '[] ('RetSingle ('PrimitiveRef String)) + , ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author")) + ] + , Object "Author" '[] + '[ ObjectField "name" '[] '[] ('RetSingle ('PrimitiveRef String)) + , ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book"))) + ] + ] + +type ApolloBookAuthor = '[ + "Book" ':-> (String, Integer) + , "Author" ':-> Integer + ] + +apolloServer :: forall m. (MonadServer m) => ServerT Maybe ApolloBookAuthor ApolloService m _ +apolloServer + = Services $ (pure . fst :<||>: pure . snd :<||>: H0) :<&>: (authorName :<||>: authorBooks :<||>: H0) :<&>: S0 + where + authorName :: Integer -> m String + authorName _ = pure "alex" -- this would run in the DB + authorBooks :: Integer -> m [(String, Integer)] + authorBooks _ = pure [] diff --git a/core/rpc/src/Mu/Server.hs b/core/rpc/src/Mu/Server.hs index 97631a6..75bc59f 100644 --- a/core/rpc/src/Mu/Server.hs +++ b/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. -data ServerT (w :: Type -> Type) (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where - Server :: HandlersT w methods m hs -> ServerT w ('Service sname anns methods) m hs +-- | Defines a mapping between outcome of +-- a service, and its representation as +-- Haskell type. +type ServiceChain snm = Mappings snm Type -infixr 5 :<|>: +-- | A server for a single service, +-- like most RPC ones. +type SingleServerT w = ServerT w '[] + +-- | Definition of a complete server +-- for a set of services, with possible +-- references between them. +data ServerT (w :: Type -> Type) -- wrapper for data types + (chn :: ServiceChain snm) (s :: Package snm mnm) + (m :: Type -> Type) (hs :: [[Type]]) where + Services :: ServicesT w chn s m hs + -> ServerT w chn ('Package pname s) m hs + +pattern Server :: (MappingRight chn sname ~ ()) + => HandlersT w chn () methods m hs + -> ServerT w chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs] +pattern Server svr = Services (svr :<&>: S0) + +infixr 3 :<&>: +-- | Definition of a complete server for a service. +data ServicesT (w :: Type -> Type) + (chn :: ServiceChain snm) (s :: [Service snm mnm]) + (m :: Type -> Type) (hs :: [[Type]]) where + S0 :: ServicesT w chn '[] m '[] + (:<&>:) :: HandlersT w chn (MappingRight chn sname) methods m hs + -> ServicesT w chn rest m hss + -> ServicesT w chn ('Service sname anns methods ': rest) m (hs ': hss) + +infixr 4 :<||>: -- | 'HandlersT' is a sequence of handlers. -- Note that the handlers for your service -- must appear __in the same order__ as they @@ -111,36 +154,59 @@ infixr 5 :<|>: -- * Output streams turn into an __additional argument__ -- of type @Conduit t Void m ()@. This stream should -- be connected to a source to get the elements. -data HandlersT (w :: Type -> Type) (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where - H0 :: HandlersT w '[] m '[] - (:<|>:) :: Handles w args ret m h => h -> HandlersT w ms m hs - -> HandlersT w ('Method name anns args ret ': ms) m (h ': hs) +data HandlersT (w :: Type -> Type) (chn :: ServiceChain snm) + (inh :: *) (methods :: [Method snm mnm]) + (m :: Type -> Type) (hs :: [Type]) where + H0 :: HandlersT w chn inh '[] m '[] + (:<||>:) :: Handles w chn args ret m h + => (inh -> h) -> HandlersT w chn inh ms m hs + -> HandlersT w chn inh ('Method name anns args ret ': ms) m (h ': hs) + +infixr 4 :<|>: +pattern (:<|>:) :: (Handles w chn args ret m h) + => h -> HandlersT w chn () ms m hs + -> HandlersT w chn () ('Method name anns args ret ': ms) m (h ': hs) +pattern x :<|>: xs <- (($ ()) -> x) :<||>: xs where + x :<|>: xs = noContext x :<||>: xs -- Define a relation for handling -class Handles (w :: Type -> Type) (args :: [Argument]) (ret :: Return) +class Handles (w :: Type -> Type) + (chn :: ServiceChain snm) + (args :: [Argument snm]) (ret :: Return snm) (m :: Type -> Type) (h :: Type) -class ToRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type) -class FromRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type) +class ToRef (w :: Type -> Type) (chn :: ServiceChain snm) + (ref :: TypeRef snm) (t :: Type) +class FromRef (w :: Type -> Type) (chn :: ServiceChain snm) + (ref :: TypeRef snm) (t :: Type) -- Type references -instance ToSchema w sch sty t => ToRef w ('ViaSchema sch sty) t -instance ToRef w ('ViaRegistry subject t last) t -instance FromSchema w sch sty t => FromRef w ('ViaSchema sch sty) t -instance FromRef w ('ViaRegistry subject t last) t +instance t ~ s => ToRef w chn ('PrimitiveRef t) s +instance ToSchema w sch sty t => ToRef w chn ('SchemaRef sch sty) t +instance MappingRight chn ref ~ t => ToRef w chn ('ObjectRef ref) t +instance t ~ s => ToRef w chn ('RegistryRef subject t last) s +instance (ToRef w chn ref t, [t] ~ s) => ToRef w chn ('ListRef ref) s +instance (ToRef w chn ref t, Maybe t ~ s) => ToRef w chn ('OptionalRef ref) s + +instance t ~ s => FromRef w chn ('PrimitiveRef t) s +instance FromSchema w sch sty t => FromRef w chn ('SchemaRef sch sty) t +instance MappingRight chn ref ~ t => FromRef w chn ('ObjectRef ref) t +instance t ~ s => FromRef w chn ('RegistryRef subject t last) s +instance (FromRef w chn ref t, [t] ~ s) => FromRef w chn ('ListRef ref) s +instance (FromRef w chn ref t, Maybe t ~ s) => FromRef w chn ('OptionalRef ref) s -- Arguments -instance (FromRef w ref t, Handles w args ret m h, +instance (FromRef w chn ref t, Handles w chn args ret m h, handler ~ (t -> h)) - => Handles w ('ArgSingle ref ': args) ret m handler -instance (MonadError ServerError m, FromRef w ref t, Handles w args ret m h, + => Handles w chn ('ArgSingle ref ': args) ret m handler +instance (MonadError ServerError m, FromRef w chn ref t, Handles w chn args ret m h, handler ~ (ConduitT () t m () -> h)) - => Handles w ('ArgStream ref ': args) ret m handler + => Handles w chn ('ArgStream ref ': args) ret m handler -- Result with exception instance (MonadError ServerError m, handler ~ m ()) - => Handles w '[] 'RetNothing m handler -instance (MonadError ServerError m, ToRef w eref e, ToRef w vref v, handler ~ m (Either e v)) - => Handles w '[] ('RetThrows eref vref) m handler -instance (MonadError ServerError m, ToRef w ref v, handler ~ m v) - => Handles w '[] ('RetSingle ref) m handler -instance (MonadError ServerError m, ToRef w ref v, handler ~ (ConduitT v Void m () -> m ())) - => Handles w '[] ('RetStream ref) m handler + => Handles w chn '[] 'RetNothing m handler +instance (MonadError ServerError m, ToRef w chn eref e, ToRef w chn vref v, handler ~ m (Either e v)) + => Handles w chn '[] ('RetThrows eref vref) m handler +instance (MonadError ServerError m, ToRef w chn ref v, handler ~ m v) + => Handles w chn '[] ('RetSingle ref) m handler +instance (MonadError ServerError m, ToRef w chn ref v, handler ~ (ConduitT v Void m () -> m ())) + => Handles w chn '[] ('RetStream ref) m handler diff --git a/core/schema/src/Mu/Adapter/Json.hs b/core/schema/src/Mu/Adapter/Json.hs index 76ecd51..e047a5d 100644 --- a/core/schema/src/Mu/Adapter/Json.hs +++ b/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 diff --git a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs index 792fee3..51e94d6 100644 --- a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs +++ b/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" diff --git a/core/schema/src/Mu/Schema/Definition.hs b/core/schema/src/Mu/Schema/Definition.hs index 6053ca6..678ecfc 100644 --- a/core/schema/src/Mu/Schema/Definition.hs +++ b/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 diff --git a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs index 122a5b2..e3ada07 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs +++ b/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 diff --git a/default.nix b/default.nix index 76049b1..463a43d 100644 --- a/default.nix +++ b/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; diff --git a/examples/health-check/avro/src/ClientRecord.hs b/examples/health-check/avro/src/ClientRecord.hs index 09ea26f..0b4483b 100644 --- a/examples/health-check/avro/src/ClientRecord.hs +++ b/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 diff --git a/examples/health-check/avro/src/ClientTyApps.hs b/examples/health-check/avro/src/ClientTyApps.hs index f0978c9..a1ce727 100644 --- a/examples/health-check/avro/src/ClientTyApps.hs +++ b/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) diff --git a/examples/health-check/avro/src/Server.hs b/examples/health-check/avro/src/Server.hs index 01e1408..aa13427 100644 --- a/examples/health-check/avro/src/Server.hs +++ b/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 "" ss) + pure $ ServerStatusMsg (fromMaybe "" ss) clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO () clearStatus_ m (HealthCheckMsg nm) = alwaysOk $ do diff --git a/examples/health-check/protobuf/src/ClientRecord.hs b/examples/health-check/protobuf/src/ClientRecord.hs index 1af0116..e2488d3 100644 --- a/examples/health-check/protobuf/src/ClientRecord.hs +++ b/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 diff --git a/examples/health-check/protobuf/src/ClientTyApps.hs b/examples/health-check/protobuf/src/ClientTyApps.hs index d619ebe..08eef41 100644 --- a/examples/health-check/protobuf/src/ClientTyApps.hs +++ b/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 ()) diff --git a/examples/health-check/protobuf/src/Server.hs b/examples/health-check/protobuf/src/Server.hs index f97fb70..a112e17 100644 --- a/examples/health-check/protobuf/src/Server.hs +++ b/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 () diff --git a/examples/route-guide/src/Server.hs b/examples/route-guide/src/Server.hs index a577862..9a32454 100644 --- a/examples/route-guide/src/Server.hs +++ b/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 diff --git a/examples/seed/avro/src/Main.hs b/examples/seed/avro/src/Main.hs index abc961a..2b674f5 100644 --- a/examples/seed/avro/src/Main.hs +++ b/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 diff --git a/examples/seed/protobuf/src/Main.hs b/examples/seed/protobuf/src/Main.hs index 972cc82..75cf766 100644 --- a/examples/seed/protobuf/src/Main.hs +++ b/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 diff --git a/examples/seed/protobuf/src/Optics.hs b/examples/seed/protobuf/src/Optics.hs index 564c834..94208bd 100644 --- a/examples/seed/protobuf/src/Optics.hs +++ b/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 diff --git a/examples/todolist/src/Server.hs b/examples/todolist/src/Server.hs index b4e3879..f4525cf 100644 --- a/examples/todolist/src/Server.hs +++ b/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" diff --git a/examples/with-persistent/src/Client.hs b/examples/with-persistent/src/Client.hs index 3aaa9a6..31634db 100644 --- a/examples/with-persistent/src/Client.hs +++ b/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 ()) diff --git a/examples/with-persistent/src/ClientOptics.hs b/examples/with-persistent/src/ClientOptics.hs index 78c9c80..3879655 100644 --- a/examples/with-persistent/src/ClientOptics.hs +++ b/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 diff --git a/examples/with-persistent/src/ClientRecord.hs b/examples/with-persistent/src/ClientRecord.hs index 8b79acd..9d3392f 100644 --- a/examples/with-persistent/src/ClientRecord.hs +++ b/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 diff --git a/examples/with-persistent/src/Server.hs b/examples/with-persistent/src/Server.hs index 9bcf9d0..8d6ae51 100644 --- a/examples/with-persistent/src/Server.hs +++ b/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) diff --git a/generate-haddock-docs.sh b/generate-haddock-docs.sh index 280a7cd..d0300e4 100755 --- a/generate-haddock-docs.sh +++ b/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 {} \; diff --git a/graphql/LICENSE b/graphql/LICENSE new file mode 100644 index 0000000..ffeb95d --- /dev/null +++ b/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. + + 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. diff --git a/graphql/Setup.hs b/graphql/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/graphql/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/graphql/hie.yaml b/graphql/hie.yaml new file mode 100644 index 0000000..c37630d --- /dev/null +++ b/graphql/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-graphql:lib" } } diff --git a/graphql/mu-graphql.cabal b/graphql/mu-graphql.cabal new file mode 100644 index 0000000..9ddd84a --- /dev/null +++ b/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 diff --git a/graphql/src/Mu/GraphQL/Query/Definition.hs b/graphql/src/Mu/GraphQL/Query/Definition.hs new file mode 100644 index 0000000..c841f0d --- /dev/null +++ b/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) diff --git a/graphql/src/Mu/GraphQL/Query/Parse.hs b/graphql/src/Mu/GraphQL/Query/Parse.hs new file mode 100644 index 0000000..877e307 --- /dev/null +++ b/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 diff --git a/graphql/src/Mu/GraphQL/Query/Run.hs b/graphql/src/Mu/GraphQL/Query/Run.hs new file mode 100644 index 0000000..9e18a71 --- /dev/null +++ b/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 diff --git a/grpc/client/mu-grpc-client.cabal b/grpc/client/mu-grpc-client.cabal index 01a0fd6..2d755bd 100644 --- a/grpc/client/mu-grpc-client.cabal +++ b/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 diff --git a/grpc/client/src/Mu/GRpc/Client/Examples.hs b/grpc/client/src/Mu/GRpc/Client/Examples.hs index 33a4ec9..8a51a93 100644 --- a/grpc/client/src/Mu/GRpc/Client/Examples.hs +++ b/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" diff --git a/grpc/client/src/Mu/GRpc/Client/Internal.hs b/grpc/client/src/Mu/GRpc/Client/Internal.hs index ddecb70..1481cbf 100644 --- a/grpc/client/src/Mu/GRpc/Client/Internal.hs +++ b/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 - gRpcServiceMethodCall :: Proxy p -> Proxy s -> Proxy m -> GrpcClient -> h -instance ( KnownName serviceName, KnownName (FindPackageName anns), KnownName mname +class GRpcServiceMethodCall (p :: GRpcMessageProtocol) + (pkg :: snm) (s :: snm) (m :: Method snm mnm) h where + gRpcServiceMethodCall :: Proxy p -> Proxy pkg -> Proxy s -> Proxy m -> GrpcClient -> h +instance ( KnownName serviceName, KnownName pkg, KnownName mname , GRpcMethodCall p ('Method mname manns margs mret) h, MkRPC p ) - => GRpcServiceMethodCall p ('Service serviceName anns methods) - ('Method mname manns margs mret) h where - gRpcServiceMethodCall pro _ = gRpcMethodCall @p rpc - where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns))) + => GRpcServiceMethodCall p pkg serviceName ('Method mname manns margs mret) h where + gRpcServiceMethodCall pro _ _ = gRpcMethodCall @p rpc + where pkgName = BS.pack (nameVal (Proxy @pkg)) svrName = BS.pack (nameVal (Proxy @serviceName)) metName = BS.pack (nameVal (Proxy @mname)) rpc = mkRPC pro pkgName svrName metName @@ -80,15 +84,15 @@ buildGRpcReply3 (Right _) = GRpcOk () simplifyResponse :: ClientIO (GRpcReply a) -> IO (GRpcReply a) simplifyResponse reply = do r <- runExceptT reply - case r of - Left e -> return $ GRpcClientError e - Right v -> return v + pure $ case r of + Left e -> GRpcClientError e + Right v -> v -- These type classes allow us to abstract over -- the choice of message protocol (PB or Avro) class GRPCInput (RPCTy p) (GRpcIWTy p ref r) - => GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where + => GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where type GRpcIWTy p ref r :: Type buildGRpcIWTy :: Proxy p -> Proxy ref -> r -> GRpcIWTy p ref r @@ -97,13 +101,15 @@ instance ToProtoBufTypeRef ref r type GRpcIWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r buildGRpcIWTy _ _ = ViaToProtoBufTypeRef -instance (GRPCInput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) r)) - => GRpcInputWrapper 'MsgAvro ('ViaSchema sch sty) r where - type GRpcIWTy 'MsgAvro ('ViaSchema sch sty) r = ViaToAvroTypeRef ('ViaSchema sch sty) r +instance forall (sch :: Schema') (sty :: Symbol) (r :: Type). + ( ToSchema Identity sch sty r + , ToAvro (Term Identity sch (sch :/: sty)) ) + => GRpcInputWrapper 'MsgAvro ('SchemaRef sch sty) r where + type GRpcIWTy 'MsgAvro ('SchemaRef sch sty) r = ViaToAvroTypeRef ('SchemaRef sch sty) r buildGRpcIWTy _ _ = ViaToAvroTypeRef class GRPCOutput (RPCTy p) (GRpcOWTy p ref r) - => GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where + => GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where type GRpcOWTy p ref r :: Type unGRpcOWTy :: Proxy p -> Proxy ref -> GRpcOWTy p ref r -> r @@ -112,16 +118,18 @@ instance FromProtoBufTypeRef ref r type GRpcOWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r unGRpcOWTy _ _ = unViaFromProtoBufTypeRef -instance (GRPCOutput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) r)) - => GRpcOutputWrapper 'MsgAvro ('ViaSchema sch sty) r where - type GRpcOWTy 'MsgAvro ('ViaSchema sch sty) r = ViaFromAvroTypeRef ('ViaSchema sch sty) r +instance forall (sch :: Schema') (sty :: Symbol) (r :: Type). + ( FromSchema Identity sch sty r + , FromAvro (Term Identity sch (sch :/: sty)) ) + => GRpcOutputWrapper 'MsgAvro ('SchemaRef sch sty) r where + type GRpcOWTy 'MsgAvro ('SchemaRef sch sty) r = ViaFromAvroTypeRef ('SchemaRef sch sty) r unGRpcOWTy _ _ = unViaFromAvroTypeRef -- ----------------------------- -- IMPLEMENTATION OF THE METHODS -- ----------------------------- -class GRpcMethodCall (p :: GRpcMessageProtocol) method h where +class GRpcMethodCall (p :: GRpcMessageProtocol) (method :: Method Symbol Symbol) h where gRpcMethodCall :: RPCTy p -> Proxy method -> GrpcClient -> h instance ( KnownName name @@ -170,7 +178,7 @@ instance ( KnownName name GRpcOk _ -> -- no error, everything is fine sourceTMChan chan .| C.map GRpcOk e -> yield $ (\_ -> error "this should never happen") <$> e - return go + pure go instance ( KnownName name , GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) () @@ -207,8 +215,8 @@ instance ( KnownName name rawStreamClient @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) rpc client () (\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan case nextVal of - Nothing -> return ((), Left StreamDone) - Just v -> return ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v))) + Nothing -> pure ((), Left StreamDone) + Just v -> pure ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v))) -- This conduit feeds information to the other thread let go = do x <- await case x of @@ -216,7 +224,7 @@ instance ( KnownName name go Nothing -> do liftIO $ atomically $ closeTMChan chan liftIO $ wait promise - return go + pure go instance ( KnownName name , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r @@ -245,7 +253,7 @@ instance ( KnownName name GRpcOk _ -> -- no error, everything is fine sourceTMChan chan .| C.map GRpcOk e -> yield $ (\_ -> error "this should never happen") <$> e - return go + pure go instance ( KnownName name , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r @@ -268,12 +276,12 @@ instance ( KnownName name case ievent of RecvMessage o -> liftIO $ atomically $ writeTMChan inchan (GRpcOk $ unGRpcOWTy(Proxy @p) (Proxy @rref) o) Invalid e -> liftIO $ atomically $ writeTMChan inchan (GRpcErrorString (show e)) - _ -> return () ) + _ -> pure () ) () (\_ -> do nextVal <- liftIO $ atomically $ readTMChan outchan case nextVal of - Nothing -> return ((), Finalize) - Just v -> return ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v))) + Nothing -> pure ((), Finalize) + Just v -> pure ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v))) case v of GRpcOk () -> liftIO $ atomically $ closeTMChan inchan _ -> liftIO $ atomically $ putTMVar var v @@ -288,7 +296,7 @@ instance ( KnownName name go2 Nothing -> do r <- liftIO $ atomically $ tryReadTMChan inchan case r of - Nothing -> return () -- both are empty, end + Nothing -> pure () -- both are empty, end Just Nothing -> go2 Just (Just nextIn) -> yield nextIn >> go2 - return go + pure go diff --git a/grpc/client/src/Mu/GRpc/Client/Optics.hs b/grpc/client/src/Mu/GRpc/Client/Optics.hs index 58ff50c..35e69b2 100644 --- a/grpc/client/src/Mu/GRpc/Client/Optics.hs +++ b/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 - Left e -> return $ Left e - Right c -> return $ Right $ GRpcConnection c + pure $ case setup of + Left e -> Left e + Right c -> Right $ GRpcConnection c -instance forall (serviceName :: Symbol) anns (methods :: [Method Symbol]) (m :: Symbol) - (t :: *) (p :: GRpcMessageProtocol). - ( SearchMethodOptic p methods m t +instance forall (pkg :: Package') pkgName (services :: [Service']) + (s :: Service') + (p :: GRpcMessageProtocol) (m :: Symbol). + ( pkg ~ 'Package pkgName services, s ~ LookupService services m ) + => LabelOptic m A_Getter + (GRpcConnection pkg p) + (GRpcConnection pkg p) + (GRpcConnectionService pkg s p) + (GRpcConnectionService pkg s p) where + labelOptic = to (GRpcConnectionService . gcClient) + +instance forall (pkg :: Package') (pkgName :: Symbol) (services :: [Service']) + (service :: Service') (serviceName :: Symbol) (anns :: [ServiceAnnotation]) + (methods :: [Method Symbol Symbol]) + (p :: GRpcMessageProtocol) (m :: Symbol) t. + ( pkg ~ 'Package ('Just pkgName) services + , service ~ 'Service serviceName anns methods + , SearchMethodOptic p methods m t , KnownName serviceName - , KnownName (FindPackageName anns) + , KnownName pkgName , KnownName m , MkRPC p ) => LabelOptic m A_Getter - (GRpcConnection ('Service serviceName anns methods) p) - (GRpcConnection ('Service serviceName anns methods) p) + (GRpcConnectionService pkg service p) + (GRpcConnectionService pkg service p) t t where - labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcClient) - where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns))) + labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcsClient) + where pkgName = BS.pack (nameVal (Proxy @pkgName)) svrName = BS.pack (nameVal (Proxy @serviceName)) metName = BS.pack (nameVal (Proxy @m)) rpc = mkRPC (Proxy @p) pkgName svrName metName -class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method Symbol]) (m :: Symbol) t +class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method Symbol Symbol]) (m :: Symbol) t | p methods m -> t where searchMethodOptic :: Proxy methods -> Proxy m -> RPCTy p -> G.GrpcClient -> t @@ -101,7 +120,7 @@ instance {-# OVERLAPPABLE #-} SearchMethodOptic p rest name t searchMethodOptic _ = searchMethodOptic @p (Proxy @rest) class GRpcMethodCall p method t - => MethodOptic (p :: GRpcMessageProtocol) (method :: Method Symbol) t + => MethodOptic (p :: GRpcMessageProtocol) (method :: Method Symbol Symbol) t | p method -> t where methodOptic :: RPCTy p -> Proxy method -> G.GrpcClient -> t methodOptic = gRpcMethodCall @p @@ -116,46 +135,46 @@ instance forall (name :: Symbol) anns t p. , t ~ IO (GRpcReply ()) ) => MethodOptic p ('Method name anns '[ ] 'RetNothing) t instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p w. - ( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('ViaSchema sch r))) t + ( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t , ProtocolWrapper p w , t ~ IO (GRpcReply (Term w sch (sch :/: r))) ) - => MethodOptic p ('Method name anns '[ ] ('RetSingle ('ViaSchema sch r))) t + => MethodOptic p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p w. - ( GRpcMethodCall p ('Method name anns '[ ] ('RetStream ('ViaSchema sch r))) t + ( GRpcMethodCall p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t , ProtocolWrapper p w , t ~ IO (ConduitT () (GRpcReply (Term w sch (sch :/: r))) IO ()) ) - => MethodOptic p ('Method name anns '[ ] ('RetStream ('ViaSchema sch r))) t + => MethodOptic p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t -- Simple arguments instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) anns t p w. - ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] 'RetNothing) t + ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] 'RetNothing) t , ProtocolWrapper p w , t ~ (Term w sch (sch :/: v) -> IO (GRpcReply ())) ) - => MethodOptic p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] 'RetNothing) t + => MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] 'RetNothing) t instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w. - ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t + ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t , ProtocolWrapper p w , t ~ (Term w sch (sch :/: v) -> IO (GRpcReply (Term w sch (sch :/: r))) ) ) - => MethodOptic p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t + => MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w. - ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t + ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t , ProtocolWrapper p w , t ~ (Term w sch (sch :/: v) -> IO (ConduitT () (GRpcReply (Term Maybe sch (sch :/: r))) IO ()) ) ) - => MethodOptic p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t + => MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t -- Stream arguments instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w. - ( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t + ( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t , ProtocolWrapper p w , t ~ (CompressMode -> IO (ConduitT (Term w sch (sch :/: v)) Void IO (GRpcReply (Term w sch (sch :/: r))))) ) - => MethodOptic p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t + => MethodOptic p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w. - ( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t + ( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t , ProtocolWrapper p w , t ~ (CompressMode -> IO (ConduitT (Term w sch (sch :/: v)) (GRpcReply (Term w sch (sch :/: r))) IO ())) ) - => MethodOptic p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t + => MethodOptic p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t diff --git a/grpc/client/src/Mu/GRpc/Client/Record.hs b/grpc/client/src/Mu/GRpc/Client/Record.hs index 2498784..7a1231c 100644 --- a/grpc/client/src/Mu/GRpc/Client/Record.hs +++ b/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 - (nm :: Symbol) (anns :: [ServiceAnnotation]) (ms :: [Method Symbol]). - (s ~ 'Service nm anns ms, Generic t, BuildService pro s p ms (Rep t)) +buildService :: forall (pro :: GRpcMessageProtocol) + (pkg :: Package') (s :: Symbol) (p :: Symbol) t + (pkgName :: Symbol) (ss :: [Service']) + (anns :: [ServiceAnnotation]) (ms :: [Method Symbol Symbol]). + ( pkg ~ 'Package ('Just pkgName) ss + , LookupService ss s ~ 'Service s anns ms + , Generic t + , BuildService pro pkgName s p ms (Rep t) ) => GrpcClient -> t -buildService client = to (buildService' (Proxy @pro) (Proxy @s) (Proxy @p) (Proxy @ms) client) +buildService client + = to (buildService' (Proxy @pro) (Proxy @pkgName) (Proxy @s) (Proxy @p) (Proxy @ms) client) -class BuildService (pro :: GRpcMessageProtocol) (s :: Service') - (p :: Symbol) (ms :: [Method Symbol]) (f :: * -> *) where - buildService' :: Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a +class BuildService (pro :: GRpcMessageProtocol) (pkg :: Symbol) (s :: Symbol) + (p :: Symbol) (ms :: [Method Symbol Symbol]) (f :: * -> *) where + buildService' :: Proxy pro -> Proxy pkg -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a -instance BuildService pro s p ms U1 where - buildService' _ _ _ _ _ = U1 -instance BuildService pro s p ms f => BuildService pro s p ms (D1 meta f) where - buildService' ppro ps ppr pms client - = M1 (buildService' ppro ps ppr pms client) -instance BuildService pro s p ms f => BuildService pro s p ms (C1 meta f) where - buildService' ppro ps ppr pms client - = M1 (buildService' ppro ps ppr pms client) +instance BuildService pro pkg s p ms U1 where + buildService' _ _ _ _ _ _ = U1 +instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (D1 meta f) where + buildService' ppro ppkg ps ppr pms client + = M1 (buildService' ppro ppkg ps ppr pms client) +instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (C1 meta f) where + buildService' ppro ppkg ps ppr pms client + = M1 (buildService' ppro ppkg ps ppr pms client) instance TypeError ('Text "building a service from sums is not supported") - => BuildService pro s p ms (f :+: g) where + => BuildService pro pkg s p ms (f :+: g) where buildService' = error "this should never happen" -instance (BuildService pro s p ms f, BuildService pro s p ms g) - => BuildService pro s p ms (f :*: g) where - buildService' ppro ps ppr pms client - = buildService' ppro ps ppr pms client :*: buildService' ppro ps ppr pms client -instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro s (s :-->: x) h) - => BuildService pro s p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where - buildService' ppro ps _ _ client - = M1 $ K1 $ gRpcServiceMethodCall ppro ps (Proxy @(s :-->: x)) client +instance (BuildService pro pkg s p ms f, BuildService pro pkg s p ms g) + => BuildService pro pkg s p ms (f :*: g) where + buildService' ppro ppkg ps ppr pms client + = buildService' ppro ppkg ps ppr pms client :*: buildService' ppro ppkg ps ppr pms client +instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro pkg sname (LookupMethod ms x) h) + => BuildService pro pkg sname p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where + buildService' ppro ppkg ps _ _ client + = M1 $ K1 $ gRpcServiceMethodCall ppro ppkg ps (Proxy @(LookupMethod ms x)) client -- TEMPLATE HASKELL -- ================ @@ -104,20 +110,20 @@ serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ _ methods [RecC (mkName complete) <$> mapM (methodToDecl fieldsPrefix tNamer) methods] [pure (DerivClause Nothing [ConT ''Generic])] let buildName = mkName ("build" ++ complete) - s <- SigD buildName <$> [t|GrpcClient -> $(return (ConT (mkName complete)))|] + s <- SigD buildName <$> [t|GrpcClient -> $(pure (ConT (mkName complete)))|] c <- Clause <$> pure [] - <*> (NormalB <$> [e|buildService @($(return $ ConT serviceTyName)) - @($(return $ LitT (StrTyLit fieldsPrefix)))|]) + <*> (NormalB <$> [e|buildService @($(pure $ ConT serviceTyName)) + @($(pure $ LitT (StrTyLit fieldsPrefix)))|]) <*> pure [] - return [d, s, FunD buildName [c]] + pure [d, s, FunD buildName [c]] -methodToDecl :: String -> Namer -> Method String -> Q (Name, Bang, Type) +methodToDecl :: String -> Namer -> Method String String -> Q (Name, Bang, Type) methodToDecl fieldsPrefix tNamer (Method mName _ args ret) = do let nm = firstLower (fieldsPrefix ++ mName) ty <- computeMethodType tNamer args ret - return ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty ) + pure ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty ) -computeMethodType :: Namer -> [Argument] -> Return -> Q Type +computeMethodType :: Namer -> [Argument String] -> Return String -> Q Type computeMethodType _ [] RetNothing = [t|IO (GRpcReply ())|] computeMethodType n [] (RetSingle r) @@ -134,11 +140,11 @@ computeMethodType n [ArgStream v] (RetStream r) = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|] computeMethodType _ _ _ = fail "method signature not supported" -typeRefToType :: Namer -> TypeRef -> Q Type -typeRefToType tNamer (ViaTH (LitT (StrTyLit s))) - = return $ ConT (mkName $ completeName tNamer s) -typeRefToType _tNamer (ViaTH ty) - = return ty +typeRefToType :: Namer -> TypeRef snm -> Q Type +typeRefToType tNamer (THRef (LitT (StrTyLit s))) + = pure $ ConT (mkName $ completeName tNamer s) +typeRefToType _tNamer (THRef ty) + = pure ty typeRefToType _ _ = error "this should never happen" completeName :: Namer -> String -> String @@ -167,7 +173,7 @@ typeToServiceDef toplevelty <*> pure [] <*> mapM typeToMethodDef methods' - typeToMethodDef :: Type -> Maybe (Method String) + typeToMethodDef :: Type -> Maybe (Method String String) typeToMethodDef ty = do (mn, _, args, ret) <- tyD4 'Method ty args' <- tyList args @@ -176,12 +182,12 @@ typeToServiceDef toplevelty <*> mapM typeToArgDef args' <*> typeToRetDef ret - typeToArgDef :: Type -> Maybe Argument + typeToArgDef :: Type -> Maybe (Argument String) typeToArgDef ty = ArgSingle <$> (tyD1 'ArgSingle ty >>= typeToTypeRef) <|> ArgStream <$> (tyD1 'ArgStream ty >>= typeToTypeRef) - typeToRetDef :: Type -> Maybe Return + typeToRetDef :: Type -> Maybe (Return String) typeToRetDef ty = RetNothing <$ tyD0 'RetNothing ty <|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef) @@ -189,12 +195,12 @@ typeToServiceDef toplevelty RetThrows <$> typeToTypeRef e <*> typeToTypeRef v) <|> RetStream <$> (tyD1 'RetStream ty >>= typeToTypeRef) - typeToTypeRef :: Type -> Maybe TypeRef + typeToTypeRef :: Type -> Maybe (TypeRef snm) typeToTypeRef ty - = (do (_,innerTy) <- tyD2 'ViaSchema ty - return (ViaTH innerTy)) - <|> (do (_,innerTy,_) <- tyD3 'ViaRegistry ty - return (ViaTH innerTy)) + = (do (_,innerTy) <- tyD2 'SchemaRef ty + pure (THRef innerTy)) + <|> (do (_,innerTy,_) <- tyD3 'RegistryRef ty + pure (THRef innerTy)) tyString :: Type -> Maybe String tyString (SigT t _) diff --git a/grpc/client/src/Mu/GRpc/Client/TyApps.hs b/grpc/client/src/Mu/GRpc/Client/TyApps.hs index 7804112..22aa9e5 100644 --- a/grpc/client/src/Mu/GRpc/Client/TyApps.hs +++ b/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. - (GRpcServiceMethodCall pro s (s :-->: methodName) h) +gRpcCall :: forall (pro :: GRpcMessageProtocol) (pkg :: Package') + (srvName :: Symbol) (methodName :: Symbol) h pkgName services anns methods. + ( pkg ~  'Package ('Just pkgName) services + , LookupService services srvName ~ 'Service srvName anns methods + , GRpcServiceMethodCall pro pkgName srvName (LookupMethod methods methodName) h) => GrpcClient -> h -gRpcCall = gRpcServiceMethodCall (Proxy @pro) (Proxy @s) (Proxy @(s :-->: methodName)) +gRpcCall + = gRpcServiceMethodCall (Proxy @pro) (Proxy @pkgName) (Proxy @srvName) + (Proxy @(LookupMethod methods methodName)) diff --git a/grpc/common/mu-grpc-common.cabal b/grpc/common/mu-grpc-common.cabal index 49d4871..443595d 100644 --- a/grpc/common/mu-grpc-common.cabal +++ b/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 diff --git a/grpc/common/src/Mu/GRpc/Avro.hs b/grpc/common/src/Mu/GRpc/Avro.hs index 9945858..2e8d772 100644 --- a/grpc/common/src/Mu/GRpc/Avro.hs +++ b/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" diff --git a/grpc/server/mu-grpc-server.cabal b/grpc/server/mu-grpc-server.cabal index bf0d150..c2295ce 100644 --- a/grpc/server/mu-grpc-server.cabal +++ b/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 diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index abb47d7..440d788 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/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) - , GRpcMethodHandlers protocol ServerErrorIO methods handlers ) + :: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers ) => Proxy protocol -> Port - -> ServerT f ('Service name anns methods) ServerErrorIO handlers + -> ServerT f chn ('Package ('Just name) services) ServerErrorIO handlers -> IO () runGRpcApp protocol port = runGRpcAppTrans protocol port id -- | Run a Mu 'Server' on the given port. runGRpcAppTrans - :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers protocol m methods handlers ) + :: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers ) => Proxy protocol -> Port -> (forall a. m a -> ServerErrorIO a) - -> ServerT f ('Service name anns methods) m handlers + -> ServerT f chn ('Package ('Just name) services) m handlers -> IO () runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr) @@ -87,12 +87,11 @@ runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr) -- -- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'. runGRpcAppSettings - :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers protocol m methods handlers ) + :: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers ) => Proxy protocol -> Settings -> (forall a. m a -> ServerErrorIO a) - -> ServerT f ('Service name anns methods) m handlers + -> ServerT f chn ('Package ('Just name) services) m handlers -> IO () runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f svr) @@ -101,12 +100,11 @@ runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f s -- Go to 'Network.Wai.Handler.WarpTLS' to declare 'TLSSettings' -- and to 'Network.Wai.Handler.Warp' to declare 'Settings'. runGRpcAppTLS - :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers protocol m methods handlers ) + :: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers ) => Proxy protocol -> TLSSettings -> Settings -> (forall a. m a -> ServerErrorIO a) - -> ServerT f ('Service name anns methods) m handlers + -> ServerT f chn ('Package ('Just name) services) m handlers -> IO () runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr) @@ -116,10 +114,9 @@ runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr -- for example, @wai-routes@, or you can add middleware -- from @wai-extra@, among others. gRpcApp - :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers protocol ServerErrorIO methods handlers ) + :: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers ) => Proxy protocol - -> ServerT f ('Service name anns methods) ServerErrorIO handlers + -> ServerT f chn ('Package ('Just name) services) ServerErrorIO handlers -> Application gRpcApp protocol = gRpcAppTrans protocol id @@ -129,40 +126,58 @@ gRpcApp protocol = gRpcAppTrans protocol id -- for example, @wai-routes@, or you can add middleware -- from @wai-extra@, among others. gRpcAppTrans - :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers protocol m methods handlers ) + :: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers ) => Proxy protocol -> (forall a. m a -> ServerErrorIO a) - -> ServerT f ('Service name anns methods) m handlers + -> ServerT f chn ('Package ('Just name) services) m handlers -> Application gRpcAppTrans protocol f svr = Wai.grpcApp [uncompressed, gzip] - (gRpcServiceHandlers protocol f svr) + (gRpcServerHandlers protocol f svr) -gRpcServiceHandlers - :: forall name anns methods handlers m protocol w. - ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers protocol m methods handlers ) +gRpcServerHandlers + :: forall name services handlers m protocol w chn. + ( KnownName name, GRpcServiceHandlers protocol m chn services handlers ) => Proxy protocol -> (forall a. m a -> ServerErrorIO a) - -> ServerT w ('Service name anns methods) m handlers + -> ServerT w chn ('Package ('Just name) services) m handlers -> [ServiceHandler] -gRpcServiceHandlers pr f (Server svr) = gRpcMethodHandlers f pr packageName serviceName svr - where packageName = BS.pack (nameVal (Proxy @(FindPackageName anns))) - serviceName = BS.pack (nameVal (Proxy @name)) +gRpcServerHandlers pr f (Services svr) = gRpcServiceHandlers f pr packageName svr + where packageName = BS.pack (nameVal (Proxy @name)) + +class GRpcServiceHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type) + (chn :: ServiceChain snm) + (ss :: [Service snm mnm]) (hs :: [[Type]]) where + gRpcServiceHandlers :: (forall a. m a -> ServerErrorIO a) + -> Proxy p -> ByteString + -> ServicesT f chn ss m hs -> [ServiceHandler] + +instance GRpcServiceHandlers p m chn '[] '[] where + gRpcServiceHandlers _ _ _ S0 = [] +instance ( KnownName name, GRpcMethodHandlers p m chn (MappingRight chn name) methods h + , GRpcServiceHandlers p m chn rest hs ) + => GRpcServiceHandlers p m chn ('Service name anns methods ': rest) (h ': hs) where + gRpcServiceHandlers f pr packageName (svr :<&>: rest) + = gRpcMethodHandlers f pr packageName serviceName svr + ++ gRpcServiceHandlers f pr packageName rest + where serviceName = BS.pack (nameVal (Proxy @name)) + class GRpcMethodHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type) - (ms :: [Method mnm]) (hs :: [Type]) where + (chn :: ServiceChain snm) (inh :: Type) + (ms :: [Method snm mnm]) (hs :: [Type]) where gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a) -> Proxy p -> ByteString -> ByteString - -> HandlersT f ms m hs -> [ServiceHandler] + -> HandlersT f chn inh ms m hs -> [ServiceHandler] -instance GRpcMethodHandlers p m '[] '[] where +instance GRpcMethodHandlers p m chn inh '[] '[] where gRpcMethodHandlers _ _ _ _ H0 = [] -instance (KnownName name, GRpcMethodHandler p m args r h, GRpcMethodHandlers p m rest hs, MkRPC p) - => GRpcMethodHandlers p m ('Method name anns args r ': rest) (h ': hs) where - gRpcMethodHandlers f pr p s (h :<|>: rest) - = gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName) h +instance ( KnownName name, MkRPC p + , GRpcMethodHandler p m args r h + , GRpcMethodHandlers p m chn () rest hs) + => GRpcMethodHandlers p m chn () ('Method name anns args r ': rest) (h ': hs) where + gRpcMethodHandlers f pr p s (h :<||>: rest) + = gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName) (h ()) : gRpcMethodHandlers f pr p s rest where methodName = BS.pack (nameVal (Proxy @name)) @@ -195,7 +210,7 @@ raiseErrors h = liftIO $ do h' <- runExceptT h case h' of - Right r -> return r + Right r -> pure r Left (ServerError code msg) -> closeEarly $ GRPCStatus (serverErrorToGRpcError code) (BS.pack msg) @@ -222,7 +237,7 @@ raiseErrors h -- the choice of message protocol (PB or Avro) class GRPCOutput (RPCTy p) (GRpcOWTy p ref r) - => GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where + => GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where type GRpcOWTy p ref r :: Type buildGRpcOWTy :: Proxy p -> Proxy ref -> r -> GRpcOWTy p ref r @@ -231,13 +246,15 @@ instance ToProtoBufTypeRef ref r type GRpcOWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r buildGRpcOWTy _ _ = ViaToProtoBufTypeRef -instance (GRPCOutput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) r)) - => GRpcOutputWrapper 'MsgAvro ('ViaSchema sch sty) r where - type GRpcOWTy 'MsgAvro ('ViaSchema sch sty) r = ViaToAvroTypeRef ('ViaSchema sch sty) r +instance forall (sch :: Schema') sty (r :: Type). + ( ToSchema Identity sch sty r + , ToAvro (Term Identity sch (sch :/: sty)) ) + => GRpcOutputWrapper 'MsgAvro ('SchemaRef sch sty) r where + type GRpcOWTy 'MsgAvro ('SchemaRef sch sty) r = ViaToAvroTypeRef ('SchemaRef sch sty) r buildGRpcOWTy _ _ = ViaToAvroTypeRef class GRPCInput (RPCTy p) (GRpcIWTy p ref r) - => GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where + => GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where type GRpcIWTy p ref r :: Type unGRpcIWTy :: Proxy p -> Proxy ref -> GRpcIWTy p ref r -> r @@ -246,9 +263,11 @@ instance FromProtoBufTypeRef ref r type GRpcIWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r unGRpcIWTy _ _ = unViaFromProtoBufTypeRef -instance (GRPCInput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) r)) - => GRpcInputWrapper 'MsgAvro ('ViaSchema sch sty) r where - type GRpcIWTy 'MsgAvro ('ViaSchema sch sty) r = ViaFromAvroTypeRef ('ViaSchema sch sty) r +instance forall (sch :: Schema') sty (r :: Type). + ( FromSchema Identity sch sty r + , FromAvro (Term Identity sch (sch :/: sty)) ) + => GRpcInputWrapper 'MsgAvro ('SchemaRef sch sty) r where + type GRpcIWTy 'MsgAvro ('SchemaRef sch sty) r = ViaFromAvroTypeRef ('SchemaRef sch sty) r unGRpcIWTy _ _ = unViaFromAvroTypeRef --- @@ -284,10 +303,10 @@ instance (GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r, MonadIO m) let readNext _ = do nextOutput <- atomically $ takeTMVar var case nextOutput of - Just o -> return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) + Just o -> pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) Nothing -> do cancel promise - return Nothing - return ((), ServerStream readNext) + pure Nothing + pure ((), ServerStream readNext) ----- @@ -330,7 +349,7 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m) cstreamFinalizer _ = atomically (closeTMChan chan) >> wait promise -- Return the information - return ((), ClientStream cstreamHandler cstreamFinalizer) + pure ((), ClientStream cstreamHandler cstreamFinalizer) ----- @@ -352,10 +371,10 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m) let readNext _ = do nextOutput <- atomically $ takeTMVar var case nextOutput of - Just o -> return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) + Just o -> pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) Nothing -> do cancel promise - return Nothing - return ((), ServerStream readNext) + pure Nothing + pure ((), ServerStream readNext) ----- @@ -383,13 +402,13 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m) = do nextOutput <- atomically $ tryTakeTMVar var case nextOutput of Just (Just o) -> - return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) + pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) Just Nothing -> do cancel promise - return Nothing + pure Nothing Nothing -> -- no new elements to output readNext () - return ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext) + pure ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext) ----- diff --git a/stack-nightly.yaml b/stack-nightly.yaml index f360e40..bc937fc 100644 --- a/stack-nightly.yaml +++ b/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 diff --git a/stack.yaml b/stack.yaml index e8d2cb8..1c35683 100644 --- a/stack.yaml +++ b/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