mu-grpc-client 0.2.0.0 → 0.3.0.0

raw patch · 6 files changed

+241/−190 lines, 6 filesdep +avrodep ~mu-grpc-commondep ~mu-opticsdep ~mu-protobufPVP ok

version bump matches the API change (PVP)

Dependencies added: avro

Dependency ranges changed: mu-grpc-common, mu-optics, mu-protobuf, mu-rpc, mu-schema

API changes (from Hackage documentation)

Files

• mu-grpc-client.cabal +7/−6
• src/Mu/GRpc/Client/Examples.hs +11/−13
• src/Mu/GRpc/Client/Internal.hs +92/−56
• src/Mu/GRpc/Client/Optics.hs +50/−58
• src/Mu/GRpc/Client/Record.hs +72/−54
• src/Mu/GRpc/Client/TyApps.hs +9/−3

@@ -1,5 +1,5 @@ name:               mu-grpc-client-version:            0.2.0.0+version:            0.3.0.0 synopsis:           gRPC clients from Mu definitions description:   With @mu-grpc-client@ you can easily build gRPC clients for mu-haskell!@@ -30,6 +30,7 @@   other-modules:    Mu.GRpc.Client.Internal   build-depends:       async+    , avro               >=0.5     , base               >=4.12  && <5     , bytestring     , conduit@@ -37,11 +38,11 @@     , http2-client     , http2-client-grpc     , http2-grpc-types-    , mu-grpc-common     >=0.2.0-    , mu-optics          >=0.2.0-    , mu-protobuf        >=0.2.0-    , mu-rpc             >=0.2.0-    , mu-schema          >=0.2.0+    , 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

@@ -20,25 +20,23 @@ import           Mu.Schema  type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema-  = '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1)-     , 'AnnField "HelloResponse" "message" ('ProtoBufId 1)-     , 'AnnField "HiRequest" "number" ('ProtoBufId 1) ]--type M a = a Maybe+  = '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1 'True)+     , 'AnnField "HelloResponse" "message" ('ProtoBufId 1 'True)+     , 'AnnField "HiRequest" "number" ('ProtoBufId 1 'True) ] -sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply (Maybe T.Text))+sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text) sayHello' host port req   = do Right c <- setupGrpcClient' (grpcClientConfigSimple host port False)-       fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest (Just req))+       fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest req) -sayHello :: GrpcClient -> M HelloRequest -> IO (GRpcReply (M HelloResponse))-sayHello = gRpcCall @'MsgProtoBuf @QuickStartService @"SayHello"+sayHello :: GrpcClient -> HelloRequest -> IO (GRpcReply HelloResponse)+sayHello = gRpcCall @'MsgProtoBuf @QuickStartService @"Greeter" @"SayHello" -sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply (Maybe T.Text)]+sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply T.Text] sayHi' host port n   = do Right c <- setupGrpcClient' (grpcClientConfigSimple host port False)-       cndt <- sayHi c (HiRequest (Just n))+       cndt <- sayHi c (HiRequest 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 :: GrpcClient -> HiRequest -> IO (ConduitT () (GRpcReply HelloResponse) IO ())+sayHi = gRpcCall @'MsgProtoBuf @QuickStartService @"Greeter" @"SayHi"

@@ -11,6 +11,7 @@ {-# language TypeFamilies          #-} {-# language TypeOperators         #-} {-# language UndecidableInstances  #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-} -- | Client for gRPC services defined using Mu 'Service' module Mu.GRpc.Client.Internal where @@ -19,11 +20,13 @@ 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.Kind+import           GHC.TypeLits import           Network.GRPC.Client           (CompressMode (..), IncomingEvent (..),                                                 OutgoingEvent (..), RawReply, StreamDone (..)) import           Network.GRPC.Client.Helpers@@ -38,17 +41,18 @@ import           Mu.Rpc import           Mu.Schema +-- | Initialize a connection to a gRPC server. 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 anm) 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 @@ 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,16 @@   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 sch sty r+         , ToAvro (WithSchema sch sty r)+         , HasAvroSchema (WithSchema sch sty r) )+         => 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 +119,19 @@   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 sch sty r+         , FromAvro (WithSchema sch sty r)+         , HasAvroSchema (WithSchema sch sty r) )+         => 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') h where   gRpcMethodCall :: RPCTy p -> Proxy method -> GrpcClient -> h  instance ( KnownName name@@ -170,12 +180,13 @@                        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) ()          , handler ~ (v -> IO (GRpcReply ())) )-         => GRpcMethodCall p ('Method name anns '[ 'ArgSingle vref ] 'RetNothing) handler where+         => GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]+                                      'RetNothing) handler where   gRpcMethodCall rpc _ client x     = simplifyResponse $       buildGRpcReply1 <$>@@ -184,7 +195,8 @@ instance ( KnownName name          , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r          , handler ~ (v -> IO (GRpcReply r)) )-         => GRpcMethodCall p ('Method name anns '[ 'ArgSingle vref ] ('RetSingle rref)) handler where+         => GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]+                                      ('RetSingle rref)) handler where   gRpcMethodCall rpc _ client x     = fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $       simplifyResponse $@@ -194,34 +206,9 @@  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 vref ] ('RetSingle rref)) handler where-  gRpcMethodCall rpc _ client compress-    = do -- Create a new TMChan-         chan <- newTMChanIO :: IO (TMChan v)-         -- Start executing the client in another thread-         promise <- async $-            fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $-            simplifyResponse $-            buildGRpcReply2 <$>-            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)))-         -- This conduit feeds information to the other thread-         let go = do x <- await-                     case x of-                       Just v  -> do liftIO $ atomically $ writeTMChan chan v-                                     go-                       Nothing -> do liftIO $ atomically $ closeTMChan chan-                                     liftIO $ wait promise-         return go--instance ( KnownName name-         , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r          , handler ~ (v -> IO (ConduitT () (GRpcReply r) IO ())) )-         => GRpcMethodCall p ('Method name anns '[ 'ArgSingle vref ] ('RetStream rref)) handler where+         => GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]+                                      ('RetStream rref)) handler where   gRpcMethodCall rpc _ client x     = do -- Create a new TMChan          chan <- newTMChanIO :: IO (TMChan r)@@ -245,12 +232,61 @@                        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) ()+         , handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply ()))) )+         => GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns vref ]+                                      'RetNothing) handler where+  gRpcMethodCall rpc _ client compress+    = do -- Create a new TMChan+         chan <- newTMChanIO :: IO (TMChan v)+         -- Start executing the client in another thread+         promise <- async $+            simplifyResponse $+            buildGRpcReply2 <$>+            rawStreamClient @_ @(GRpcIWTy p vref v) @() rpc client ()+                            (\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan+                                      case nextVal of+                                        Nothing -> pure ((), Left StreamDone)+                                        Just v  -> pure ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))+         pure (conduitFromChannel chan promise)++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 ]+                                      ('RetSingle rref)) handler where+  gRpcMethodCall rpc _ client compress+    = do -- Create a new TMChan+         chan <- newTMChanIO :: IO (TMChan v)+         -- Start executing the client in another thread+         promise <- async $+            fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $+            simplifyResponse $+            buildGRpcReply2 <$>+            rawStreamClient @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) rpc client ()+                            (\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan+                                      case nextVal of+                                        Nothing -> pure ((), Left StreamDone)+                                        Just v  -> pure ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))+         pure (conduitFromChannel chan promise)++conduitFromChannel :: MonadIO m => TMChan a -> Async b -> ConduitT a o m b+conduitFromChannel chan promise = go+  where go = do x <- await+                case x of+                  Just v  -> do liftIO $ atomically $ writeTMChan chan v+                                go+                  Nothing -> do liftIO $ atomically $ closeTMChan chan+                                liftIO $ wait promise++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 vref ] ('RetStream rref)) handler where+         => GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aans vref ]+                                      ('RetStream rref)) handler where   gRpcMethodCall rpc _ client compress     = do -- Create a new TMChan          inchan <- newTMChanIO :: IO (TMChan (GRpcReply r))@@ -268,12 +304,12 @@                         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 +324,7 @@                                       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

@@ -34,7 +34,6 @@  import qualified Data.ByteString.Char8       as BS import           Data.Conduit-import           Data.Functor.Identity import           Data.Proxy import           GHC.TypeLits import           Network.GRPC.Client         (CompressMode)@@ -49,7 +48,7 @@ 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 }  -- | Initializes a connection to a gRPC server.@@ -57,35 +56,39 @@ --   inferred from the usage later on. --   However, it can also be made explicit by using -----   > initGRpc config @Service+--   > initGRpc config msgProtoBuf @Service -- initGRpc :: G.GrpcClientConfig  -- ^ gRPC configuration          -> Proxy p          -> 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 :: Symbol)+                (service :: Service') (serviceName :: Symbol) (anns :: [ServiceAnnotation])+                (methods :: [Method'])+                (p :: GRpcMessageProtocol) (m :: Symbol) t.+         ( pkg ~ 'Package ('Just pkgName) '[service]+         , 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)+                       (GRpcConnection pkg p)+                       (GRpcConnection pkg p)                        t t where   labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcClient)-    where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns)))+    where pkgName = BS.pack (nameVal (Proxy @pkgName))           svrName = BS.pack (nameVal (Proxy @serviceName))           metName = BS.pack (nameVal (Proxy @m))           rpc = mkRPC (Proxy @p) pkgName svrName metName -class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method Symbol]) (m :: Symbol) t+class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method']) (m :: Symbol) t       | p methods m -> t where   searchMethodOptic :: Proxy methods -> Proxy m -> RPCTy p -> G.GrpcClient -> t @@ -101,61 +104,50 @@   searchMethodOptic _ = searchMethodOptic @p (Proxy @rest)  class GRpcMethodCall p method t-      => MethodOptic (p :: GRpcMessageProtocol) (method :: Method Symbol) t+      => MethodOptic (p :: GRpcMessageProtocol) (method :: Method') t       | p method -> t where   methodOptic :: RPCTy p -> Proxy method -> G.GrpcClient -> t   methodOptic = gRpcMethodCall @p -class ProtocolWrapper (p :: GRpcMessageProtocol) (w :: * -> *) | p -> w where-instance ProtocolWrapper 'MsgAvro Identity where-instance ProtocolWrapper 'MsgProtoBuf Maybe where- -- No arguments instance forall (name :: Symbol) anns t p.          ( GRpcMethodCall p ('Method name anns '[ ] '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 w.-         ( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('ViaSchema sch r))) t-         , ProtocolWrapper p w-         , t ~ IO (GRpcReply (Term w sch (sch :/: r))) )-         => MethodOptic p ('Method name anns '[ ] ('RetSingle ('ViaSchema 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-         , ProtocolWrapper p w-         , t ~ IO (ConduitT () (GRpcReply (Term w sch (sch :/: r))) IO ()) )-         => MethodOptic p ('Method name anns '[ ] ('RetStream ('ViaSchema sch r))) t+instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p.+         ( GRpcMethodCall p ('Method name anns '[ ] ('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+         , t ~ IO (ConduitT () (GRpcReply (Term sch (sch :/: r))) IO ()) )+         => 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-         , ProtocolWrapper p w-         , t ~ (Term w sch (sch :/: v) -> IO (GRpcReply ())) )-         => MethodOptic p ('Method name anns '[ 'ArgSingle ('ViaSchema 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-         , 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-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-         , 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+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+         , 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+         , 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+         , 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 -- 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-         , ProtocolWrapper p w+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          , t ~ (CompressMode-                -> IO (ConduitT (Term w sch (sch :/: v))+                -> IO (ConduitT (Term 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-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-         , ProtocolWrapper p w+                                (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          , 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+               -> 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

@@ -49,35 +49,41 @@  -- | 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']).+                ( 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']) (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 -- ================@@ -95,7 +101,7 @@  type Namer = String -> String -serviceDefToDecl :: Name -> String -> String -> Namer -> Service String String -> Q [Dec]+serviceDefToDecl :: Name -> String -> String -> Namer -> Service String String String -> Q [Dec] serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ _ methods)   = do d <- dataD (pure [])                   (mkName complete)@@ -104,41 +110,41 @@                   [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 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 String] -> Return String -> 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" -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@@ -155,11 +161,11 @@ -- Parsing -- ======= -typeToServiceDef :: Type -> Q (Maybe (Service String String))+typeToServiceDef :: Type -> Q (Maybe (Service String String String)) typeToServiceDef toplevelty   = typeToServiceDef' <$> resolveTypeSynonyms toplevelty   where-    typeToServiceDef' :: Type -> Maybe (Service String String)+    typeToServiceDef' :: Type -> Maybe (Service String String String)     typeToServiceDef' expanded       = do (sn, _, methods) <- tyD3 'Service expanded            methods' <- tyList methods@@ -167,7 +173,7 @@                    <*> pure []                    <*> mapM typeToMethodDef methods' -    typeToMethodDef :: Type -> Maybe (Method String)+    typeToMethodDef :: Type -> Maybe (Method String String String)     typeToMethodDef ty       = do (mn, _, args, ret) <- tyD4 'Method ty            args' <- tyList args@@ -176,12 +182,14 @@                   <*> mapM typeToArgDef args'                   <*> typeToRetDef ret -    typeToArgDef :: Type -> Maybe Argument+    typeToArgDef :: Type -> Maybe (Argument String String)     typeToArgDef ty-      =   ArgSingle <$> (tyD1 'ArgSingle ty >>= typeToTypeRef)-      <|> ArgStream <$> (tyD1 'ArgStream ty >>= typeToTypeRef)+      =   (do (n, _, t) <- tyD3 'ArgSingle ty+              ArgSingle <$> tyMaybeString n <*> pure [] <*> typeToTypeRef t)+      <|> (do (n, _, t) <- tyD3 'ArgStream ty+              ArgStream <$> tyMaybeString n <*> pure [] <*> typeToTypeRef t) -    typeToRetDef :: Type -> Maybe Return+    typeToRetDef :: Type -> Maybe (Return String)     typeToRetDef ty       =   RetNothing <$ tyD0 'RetNothing ty       <|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef)@@ -189,12 +197,22 @@               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))++tyMaybeString :: Type -> Maybe (Maybe String)+tyMaybeString (PromotedT c)+  | c == 'Nothing+  = pure Nothing+tyMaybeString (AppT (PromotedT c) r)+  | c == 'Just+  = Just <$> tyString r+tyMaybeString _+  = Nothing  tyString :: Type -> Maybe String tyString (SigT t _)

@@ -26,6 +26,7 @@ , GRpcReply(..) ) where +import           GHC.TypeLits import           Network.GRPC.Client         (CompressMode (..)) import           Network.GRPC.Client.Helpers @@ -45,7 +46,12 @@ --   * 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))