diff --git a/mu-grpc-client.cabal b/mu-grpc-client.cabal --- a/mu-grpc-client.cabal +++ b/mu-grpc-client.cabal @@ -1,5 +1,5 @@ name: mu-grpc-client -version: 0.3.0.0 +version: 0.4.0.0 synopsis: gRPC clients from Mu definitions description: With @mu-grpc-client@ you can easily build gRPC clients for mu-haskell! @@ -29,28 +29,29 @@ other-modules: Mu.GRpc.Client.Internal build-depends: - async - , avro >=0.5 + async >=2.2 && < 3 + , avro >=0.5.1 && <0.6 , base >=4.12 && <5 - , bytestring - , conduit - , http2 - , http2-client - , http2-client-grpc - , http2-grpc-types - , mu-grpc-common >=0.3.0 - , mu-optics >=0.3.0 - , mu-protobuf >=0.3.0 - , mu-rpc >=0.3.0 - , mu-schema >=0.3.0 - , optics-core - , sop-core - , stm - , stm-chans - , stm-conduit - , template-haskell >=2.12 - , text - , th-abstraction + , bytestring >=0.10 && <0.11 + , conduit >=1.3.2 && <2 + , http2 >=1.6 && <2.1 + , http2-client >=0.9 && <1 + , http2-client-grpc >=0.8 && <0.9 + , http2-grpc-types >=0.5 && <0.6 + , mu-grpc-common ==0.4.* + , mu-optics ==0.3.* + , mu-protobuf ==0.4.* + , mu-rpc ==0.4.* + , mu-schema ==0.3.* + , optics-core >=0.2 && <0.3 + , sop-core >=0.5 && <0.6 + , stm >=2.5 && <3 + , stm-chans >=3 && <4 + , stm-conduit >=4 && <5 + , template-haskell >=2.14 && <2.16 + , text >=1.2 && <2 + , th-abstraction >=0.3.2 && <0.4 + , tracing >=0.0.5 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Mu/GRpc/Client/Examples.hs b/src/Mu/GRpc/Client/Examples.hs --- a/src/Mu/GRpc/Client/Examples.hs +++ b/src/Mu/GRpc/Client/Examples.hs @@ -20,9 +20,9 @@ import Mu.Schema type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema - = '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1 'True) - , 'AnnField "HelloResponse" "message" ('ProtoBufId 1 'True) - , 'AnnField "HiRequest" "number" ('ProtoBufId 1 'True) ] + = '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1 '[]) + , 'AnnField "HelloResponse" "message" ('ProtoBufId 1 '[]) + , 'AnnField "HiRequest" "number" ('ProtoBufId 1 '[]) ] sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text) sayHello' host port req diff --git a/src/Mu/GRpc/Client/Internal.hs b/src/Mu/GRpc/Client/Internal.hs --- a/src/Mu/GRpc/Client/Internal.hs +++ b/src/Mu/GRpc/Client/Internal.hs @@ -4,7 +4,9 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GADTs #-} +{-# language LambdaCase #-} {-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} {-# language PolyKinds #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} @@ -26,7 +28,10 @@ import qualified Data.Conduit.Combinators as C import Data.Conduit.TMChan import Data.Kind +import Data.Text as T import GHC.TypeLits +import Monitor.Tracing +import Monitor.Tracing.Zipkin import Network.GRPC.Client (CompressMode (..), IncomingEvent (..), OutgoingEvent (..), RawReply, StreamDone (..)) import Network.GRPC.Client.Helpers @@ -42,15 +47,30 @@ import Mu.Schema -- | Initialize a connection to a gRPC server. -setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient) -setupGrpcClient' = runExceptT . setupGrpcClient +setupGrpcClient' :: MonadIO m + => GrpcClientConfig -> m (Either ClientError GrpcClient) +setupGrpcClient' = liftIO . runExceptT . setupGrpcClient +-- | Initialize a connection to a gRPC server +-- and pass information about distributed tracing. +setupGrpcClientZipkin + :: (MonadIO m, MonadTrace m) + => GrpcClientConfig -> T.Text -> m (Either ClientError GrpcClient) +setupGrpcClientZipkin cfg spanName + = clientSpan spanName $ \case + Nothing -> setupGrpcClient' cfg + (Just b3) -> setupGrpcClient' cfg { + _grpcClientConfigHeaders = ("b3", b3ToHeaderValue b3) + : _grpcClientConfigHeaders cfg + } + class GRpcServiceMethodCall (p :: GRpcMessageProtocol) - (pkg :: snm) (s :: snm) (m :: Method snm mnm anm) h where + (pkg :: snm) (s :: snm) + (m :: Method snm mnm anm (TypeRef snm)) 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 pkg serviceName ('Method mname manns margs mret) h where + , GRpcMethodCall p ('Method mname margs mret) h, MkRPC p ) + => GRpcServiceMethodCall p pkg serviceName ('Method mname margs mret) h where gRpcServiceMethodCall pro _ _ = gRpcMethodCall @p rpc where pkgName = BS.pack (nameVal (Proxy @pkg)) svrName = BS.pack (nameVal (Proxy @serviceName)) @@ -137,7 +157,7 @@ instance ( KnownName name , GRPCInput (RPCTy p) (), GRPCOutput (RPCTy p) () , handler ~ IO (GRpcReply ()) ) - => GRpcMethodCall p ('Method name anns '[ ] 'RetNothing) handler where + => GRpcMethodCall p ('Method name '[ ] 'RetNothing) handler where gRpcMethodCall rpc _ client = simplifyResponse $ buildGRpcReply1 <$> @@ -146,7 +166,7 @@ instance ( KnownName name , GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r , handler ~ IO (GRpcReply r) ) - => GRpcMethodCall p ('Method name anns '[ ] ('RetSingle rref)) handler where + => GRpcMethodCall p ('Method name '[ ] ('RetSingle rref)) handler where gRpcMethodCall rpc _ client = fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $ simplifyResponse $ @@ -156,7 +176,7 @@ instance ( KnownName name , GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r , handler ~ IO (ConduitT () (GRpcReply r) IO ()) ) - => GRpcMethodCall p ('Method name anns '[ ] ('RetStream rref)) handler where + => GRpcMethodCall p ('Method name '[ ] ('RetStream rref)) handler where gRpcMethodCall rpc _ client = do -- Create a new TMChan chan <- newTMChanIO :: IO (TMChan r) @@ -185,7 +205,7 @@ instance ( KnownName name , GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) () , handler ~ (v -> IO (GRpcReply ())) ) - => GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ] + => GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ] 'RetNothing) handler where gRpcMethodCall rpc _ client x = simplifyResponse $ @@ -195,7 +215,7 @@ instance ( KnownName name , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r , handler ~ (v -> IO (GRpcReply r)) ) - => GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ] + => GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ] ('RetSingle rref)) handler where gRpcMethodCall rpc _ client x = fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $ @@ -207,7 +227,7 @@ instance ( KnownName name , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r , handler ~ (v -> IO (ConduitT () (GRpcReply r) IO ())) ) - => GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ] + => GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ] ('RetStream rref)) handler where gRpcMethodCall rpc _ client x = do -- Create a new TMChan @@ -237,7 +257,7 @@ instance ( KnownName name , GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) () , handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply ()))) ) - => GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns vref ] + => GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ] 'RetNothing) handler where gRpcMethodCall rpc _ client compress = do -- Create a new TMChan @@ -256,7 +276,7 @@ instance ( KnownName name , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r , handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply r))) ) - => GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns vref ] + => GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ] ('RetSingle rref)) handler where gRpcMethodCall rpc _ client compress = do -- Create a new TMChan @@ -285,7 +305,7 @@ instance ( KnownName name , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r , handler ~ (CompressMode -> IO (ConduitT v (GRpcReply r) IO ())) ) - => GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aans vref ] + => GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ] ('RetStream rref)) handler where gRpcMethodCall rpc _ client compress = do -- Create a new TMChan diff --git a/src/Mu/GRpc/Client/Optics.hs b/src/Mu/GRpc/Client/Optics.hs --- a/src/Mu/GRpc/Client/Optics.hs +++ b/src/Mu/GRpc/Client/Optics.hs @@ -19,6 +19,7 @@ -- * Initialization of the gRPC client GRpcConnection , initGRpc +, initGRpcZipkin , GRpcMessageProtocol(..) , msgProtoBuf , msgAvro @@ -32,10 +33,13 @@ , module Mu.Schema.Optics ) where +import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as BS import Data.Conduit import Data.Proxy +import Data.Text as T import GHC.TypeLits +import Monitor.Tracing import Network.GRPC.Client (CompressMode) import qualified Network.GRPC.Client.Helpers as G import Network.HTTP2.Client (ClientError) @@ -58,21 +62,41 @@ -- -- > initGRpc config msgProtoBuf @Service -- -initGRpc :: G.GrpcClientConfig -- ^ gRPC configuration +initGRpc :: MonadIO m + => G.GrpcClientConfig -- ^ gRPC configuration -> Proxy p - -> forall s. IO (Either ClientError (GRpcConnection s p)) + -> forall s. m (Either ClientError (GRpcConnection s p)) initGRpc config _ = do setup <- setupGrpcClient' config pure $ case setup of Left e -> Left e Right c -> Right $ GRpcConnection c +-- | Initializes a connection to a gRPC server, +-- creating a new span for distributed tracing. +-- Usually the service you are connecting to is +-- inferred from the usage later on. +-- However, it can also be made explicit by using +-- +-- > initGRpcZipkin config msgProtoBuf "person" @Service +-- +initGRpcZipkin :: (MonadIO m, MonadTrace m) + => G.GrpcClientConfig -- ^ gRPC configuration + -> Proxy p + -> T.Text + -> forall s. m (Either ClientError (GRpcConnection s p)) +initGRpcZipkin config _ spanName = do + setup <- setupGrpcClientZipkin config spanName + pure $ case setup of + Left e -> Left e + Right c -> Right $ GRpcConnection c + instance forall (pkg :: Package') (pkgName :: Symbol) - (service :: Service') (serviceName :: Symbol) (anns :: [ServiceAnnotation]) + (service :: Service') (serviceName :: Symbol) (methods :: [Method']) (p :: GRpcMessageProtocol) (m :: Symbol) t. ( pkg ~ 'Package ('Just pkgName) '[service] - , service ~ 'Service serviceName anns methods + , service ~ 'Service serviceName methods , SearchMethodOptic p methods m t , KnownName serviceName , KnownName pkgName @@ -96,11 +120,11 @@ instance TypeError ('Text "could not find method " ':<>: ShowType m) => SearchMethodOptic '[] m t where -} -instance {-# OVERLAPS #-} MethodOptic p ('Method name anns ins outs) t - => SearchMethodOptic p ('Method name anns ins outs ': rest) name t where - searchMethodOptic _ _ rpc = methodOptic @p rpc (Proxy @('Method name anns ins outs)) +instance {-# OVERLAPS #-} MethodOptic p ('Method name ins outs) t + => SearchMethodOptic p ('Method name ins outs ': rest) name t where + searchMethodOptic _ _ rpc = methodOptic @p rpc (Proxy @('Method name ins outs)) instance {-# OVERLAPPABLE #-} SearchMethodOptic p rest name t - => SearchMethodOptic p ('Method other anns ins outs ': rest) name t where + => SearchMethodOptic p ('Method other ins outs ': rest) name t where searchMethodOptic _ = searchMethodOptic @p (Proxy @rest) class GRpcMethodCall p method t @@ -110,44 +134,44 @@ methodOptic = gRpcMethodCall @p -- No arguments -instance forall (name :: Symbol) anns t p. - ( GRpcMethodCall p ('Method name anns '[ ] 'RetNothing) t +instance forall (name :: Symbol) t p. + ( GRpcMethodCall p ('Method name '[ ] 'RetNothing) t , t ~ IO (GRpcReply ()) ) - => MethodOptic p ('Method name anns '[ ] 'RetNothing) t -instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p. - ( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t + => MethodOptic p ('Method name '[ ] 'RetNothing) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) t p. + ( GRpcMethodCall p ('Method name '[ ] ('RetSingle ('SchemaRef sch r))) t , t ~ IO (GRpcReply (Term sch (sch :/: r))) ) - => MethodOptic p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t -instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p. - ( GRpcMethodCall p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t + => MethodOptic p ('Method name '[ ] ('RetSingle ('SchemaRef sch r))) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) t p. + ( GRpcMethodCall p ('Method name '[ ] ('RetStream ('SchemaRef sch r))) t , t ~ IO (ConduitT () (GRpcReply (Term sch (sch :/: r))) IO ()) ) - => MethodOptic p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t + => MethodOptic p ('Method name '[ ] ('RetStream ('SchemaRef sch r))) t -- Simple arguments -instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) aname anns aanns t p. - ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] 'RetNothing) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] 'RetNothing) t , t ~ (Term sch (sch :/: v) -> IO (GRpcReply ())) ) - => MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] 'RetNothing) t -instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p. - ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t + => MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] 'RetNothing) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t , t ~ (Term sch (sch :/: v) -> IO (GRpcReply (Term sch (sch :/: r))) ) ) - => MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t -instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p. - ( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t + => MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t , t ~ (Term sch (sch :/: v) -> IO (ConduitT () (GRpcReply (Term sch (sch :/: r))) IO ()) ) ) - => MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t + => MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t -- Stream arguments -instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p. - ( GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t , t ~ (CompressMode -> IO (ConduitT (Term sch (sch :/: v)) Void IO (GRpcReply (Term sch (sch :/: r))))) ) - => MethodOptic p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t -instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p. - ( GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t + => MethodOptic p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t , t ~ (CompressMode -> IO (ConduitT (Term sch (sch :/: v)) (GRpcReply (Term sch (sch :/: r))) IO ())) ) - => MethodOptic p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t + => MethodOptic p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t diff --git a/src/Mu/GRpc/Client/Record.hs b/src/Mu/GRpc/Client/Record.hs --- a/src/Mu/GRpc/Client/Record.hs +++ b/src/Mu/GRpc/Client/Record.hs @@ -22,6 +22,7 @@ , GrpcClientConfig , grpcClientConfigSimple , setupGrpcClient' +, setupGrpcClientZipkin -- * Fill and generate the Haskell record of functions , buildService , GRpcMessageProtocol(..) @@ -52,9 +53,9 @@ buildService :: forall (pro :: GRpcMessageProtocol) (pkg :: Package') (s :: Symbol) (p :: Symbol) t (pkgName :: Symbol) (ss :: [Service']) - (anns :: [ServiceAnnotation]) (ms :: [Method']). + (ms :: [Method']). ( pkg ~ 'Package ('Just pkgName) ss - , LookupService ss s ~ 'Service s anns ms + , LookupService ss s ~ 'Service s ms , Generic t , BuildService pro pkgName s p ms (Rep t) ) => GrpcClient -> t @@ -101,8 +102,10 @@ type Namer = String -> String -serviceDefToDecl :: Name -> String -> String -> Namer -> Service String String String -> Q [Dec] -serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ _ methods) +serviceDefToDecl :: Name -> String -> String -> Namer + -> Service String String String (TypeRef snm) + -> Q [Dec] +serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ methods) = do d <- dataD (pure []) (mkName complete) [] @@ -117,26 +120,31 @@ <*> pure [] pure [d, s, FunD buildName [c]] -methodToDecl :: String -> Namer -> Method String String String -> Q (Name, Bang, Type) -methodToDecl fieldsPrefix tNamer (Method mName _ args ret) +methodToDecl :: String -> Namer + -> Method String String String (TypeRef snm) + -> Q (Name, Bang, Type) +methodToDecl fieldsPrefix tNamer (Method mName args ret) = do let nm = firstLower (fieldsPrefix ++ mName) ty <- computeMethodType tNamer args ret pure ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty ) -computeMethodType :: Namer -> [Argument String String] -> Return String -> Q Type +computeMethodType :: Namer + -> [Argument String String (TypeRef snm)] + -> Return String (TypeRef snm) + -> Q Type computeMethodType _ [] RetNothing = [t|IO (GRpcReply ())|] computeMethodType n [] (RetSingle r) = [t|IO (GRpcReply $(typeRefToType n r))|] -computeMethodType n [ArgSingle _ _ v] RetNothing +computeMethodType n [ArgSingle _ v] RetNothing = [t|$(typeRefToType n v) -> IO (GRpcReply ())|] -computeMethodType n [ArgSingle _ _ v] (RetSingle r) +computeMethodType n [ArgSingle _ v] (RetSingle r) = [t|$(typeRefToType n v) -> IO (GRpcReply $(typeRefToType n r))|] -computeMethodType n [ArgStream _ _ v] (RetSingle r) +computeMethodType n [ArgStream _ v] (RetSingle r) = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) Void IO (GRpcReply $(typeRefToType n r)))|] -computeMethodType n [ArgSingle _ _ v] (RetStream r) +computeMethodType n [ArgSingle _ v] (RetStream r) = [t|$(typeRefToType n v) -> IO (ConduitT () (GRpcReply $(typeRefToType n r)) IO ())|] -computeMethodType n [ArgStream _ _ v] (RetStream r) +computeMethodType n [ArgStream _ v] (RetStream r) = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|] computeMethodType _ _ _ = fail "method signature not supported" @@ -161,35 +169,33 @@ -- Parsing -- ======= -typeToServiceDef :: Type -> Q (Maybe (Service String String String)) +typeToServiceDef :: Type -> Q (Maybe (Service String String String (TypeRef snm))) typeToServiceDef toplevelty = typeToServiceDef' <$> resolveTypeSynonyms toplevelty where - typeToServiceDef' :: Type -> Maybe (Service String String String) + typeToServiceDef' :: Type -> Maybe (Service String String String (TypeRef snm)) typeToServiceDef' expanded = do (sn, _, methods) <- tyD3 'Service expanded methods' <- tyList methods Service <$> tyString sn - <*> pure [] <*> mapM typeToMethodDef methods' - typeToMethodDef :: Type -> Maybe (Method String String String) + typeToMethodDef :: Type -> Maybe (Method String String String (TypeRef snm)) typeToMethodDef ty = do (mn, _, args, ret) <- tyD4 'Method ty args' <- tyList args Method <$> tyString mn - <*> pure [] <*> mapM typeToArgDef args' <*> typeToRetDef ret - typeToArgDef :: Type -> Maybe (Argument String String) + typeToArgDef :: Type -> Maybe (Argument String String (TypeRef snm)) typeToArgDef ty = (do (n, _, t) <- tyD3 'ArgSingle ty - ArgSingle <$> tyMaybeString n <*> pure [] <*> typeToTypeRef t) + ArgSingle <$> tyMaybeString n <*> typeToTypeRef t) <|> (do (n, _, t) <- tyD3 'ArgStream ty - ArgStream <$> tyMaybeString n <*> pure [] <*> typeToTypeRef t) + ArgStream <$> tyMaybeString n <*> typeToTypeRef t) - typeToRetDef :: Type -> Maybe (Return String) + typeToRetDef :: Type -> Maybe (Return String (TypeRef snm)) typeToRetDef ty = RetNothing <$ tyD0 'RetNothing ty <|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef) diff --git a/src/Mu/GRpc/Client/TyApps.hs b/src/Mu/GRpc/Client/TyApps.hs --- a/src/Mu/GRpc/Client/TyApps.hs +++ b/src/Mu/GRpc/Client/TyApps.hs @@ -19,6 +19,7 @@ , GrpcClientConfig , grpcClientConfigSimple , setupGrpcClient' +, setupGrpcClientZipkin -- * Call methods from the gRPC service , gRpcCall , GRpcMessageProtocol(..) @@ -47,9 +48,10 @@ -- * A single input or output turns into a single value. -- * A streaming input or output turns into a Conduit. gRpcCall :: forall (pro :: GRpcMessageProtocol) (pkg :: Package') - (srvName :: Symbol) (methodName :: Symbol) h pkgName services anns methods. + (srvName :: Symbol) (methodName :: Symbol) h + pkgName services methods. ( pkg ~  'Package ('Just pkgName) services - , LookupService services srvName ~ 'Service srvName anns methods + , LookupService services srvName ~ 'Service srvName methods , GRpcServiceMethodCall pro pkgName srvName (LookupMethod methods methodName) h) => GrpcClient -> h gRpcCall