diff --git a/mu-grpc-client.cabal b/mu-grpc-client.cabal --- a/mu-grpc-client.cabal +++ b/mu-grpc-client.cabal @@ -1,47 +1,56 @@ -cabal-version: >=1.10 -name: mu-grpc-client -version: 0.1.0.0 -synopsis: gRPC clients from Mu definitions -description: With @mu-grpc-client@ you can easily build gRPC clients for mu-haskell! -license: Apache-2.0 -license-file: LICENSE -author: Alejandro Serrano, Flavio Corpa -maintainer: alejandro.serrano@47deg.com -copyright: Copyright © 2019-2020 -category: Network -build-type: Simple -extra-source-files: CHANGELOG.md -homepage: https://higherkindness.io/mu-haskell/ -bug-reports: https://github.com/higherkindness/mu-haskell/issues +name: mu-grpc-client +version: 0.2.0.0 +synopsis: gRPC clients from Mu definitions +description: + With @mu-grpc-client@ you can easily build gRPC clients for mu-haskell! +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +extra-source-files: CHANGELOG.md +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + source-repository head type: git location: https://github.com/higherkindness/mu-haskell library - exposed-modules: Mu.GRpc.Client.TyApps, - Mu.GRpc.Client.Record, - Mu.GRpc.Client.Examples - other-modules: Mu.GRpc.Client.Internal - build-depends: base >=4.12 && <5 - , async - , bytestring - , conduit - , http2 - , http2-client - , http2-client-grpc - , http2-grpc-proto3-wire - , mu-protobuf - , mu-rpc - , mu-schema - , sop-core - , stm - , stm-chans - , stm-conduit - , template-haskell >= 2.12 - , text - , th-abstraction - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - -fprint-potential-instances + exposed-modules: + Mu.GRpc.Client.Examples + Mu.GRpc.Client.Optics + Mu.GRpc.Client.Record + Mu.GRpc.Client.TyApps + + other-modules: Mu.GRpc.Client.Internal + build-depends: + async + , base >=4.12 && <5 + , bytestring + , conduit + , http2 + , 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 + , optics-core + , sop-core + , stm + , stm-chans + , stm-conduit + , template-haskell >=2.12 + , text + , th-abstraction + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances 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 @@ -32,7 +32,7 @@ fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest (Just req)) sayHello :: GrpcClient -> M HelloRequest -> IO (GRpcReply (M HelloResponse)) -sayHello = gRpcCall @QuickStartService @"SayHello" +sayHello = gRpcCall @'MsgProtoBuf @QuickStartService @"SayHello" sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply (Maybe T.Text)] sayHi' host port n @@ -41,4 +41,4 @@ runConduit $ cndt .| C.map (fmap (\(HelloResponse r) -> r)) .| consume sayHi :: GrpcClient -> M HiRequest -> IO (ConduitT () (GRpcReply (M HelloResponse)) IO ()) -sayHi = gRpcCall @QuickStartService @"SayHi" +sayHi = gRpcCall @'MsgProtoBuf @QuickStartService @"SayHi" 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 @@ -8,6 +8,7 @@ {-# language PolyKinds #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} +{-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} -- | Client for gRPC services defined using Mu 'Service' @@ -18,33 +19,39 @@ import Control.Concurrent.STM.TMChan import Control.Concurrent.STM.TMVar import Control.Monad.IO.Class -import Data.ByteString (ByteString) 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 Network.GRPC.Client (CompressMode (..), IncomingEvent (..), OutgoingEvent (..), RawReply, StreamDone (..)) import Network.GRPC.Client.Helpers -import Network.GRPC.HTTP2.Proto3Wire +import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput) import Network.HTTP2 (ErrorCode) import Network.HTTP2.Client (ClientError, ClientIO, TooMuchConcurrency, runExceptT) import Mu.Adapter.ProtoBuf.Via +import Mu.GRpc.Avro +import Mu.GRpc.Bridge import Mu.Rpc import Mu.Schema setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient) setupGrpcClient' = runExceptT . setupGrpcClient -class GRpcServiceMethodCall (s :: Service snm mnm) (m :: Method mnm) h where - gRpcServiceMethodCall :: Proxy s -> Proxy m -> GrpcClient -> h -instance (KnownName serviceName, KnownName (FindPackageName anns), GRpcMethodCall m h) - => GRpcServiceMethodCall ('Service serviceName anns methods) m h where - gRpcServiceMethodCall _ = gRpcMethodCall pkgName svrName +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 + , 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))) svrName = BS.pack (nameVal (Proxy @serviceName)) + metName = BS.pack (nameVal (Proxy @mname)) + rpc = mkRPC pro pkgName svrName metName data GRpcReply a = GRpcTooMuchConcurrency TooMuchConcurrency @@ -77,33 +84,70 @@ Left e -> return $ GRpcClientError e Right v -> return v -class GRpcMethodCall method h where - gRpcMethodCall :: ByteString -> ByteString -> Proxy method -> GrpcClient -> h +-- These type classes allow us to abstract over +-- the choice of message protocol (PB or Avro) -instance (KnownName name, handler ~ IO (GRpcReply ())) - => GRpcMethodCall ('Method name anns '[ ] 'RetNothing) handler where - gRpcMethodCall pkgName srvName _ client +class GRPCInput (RPCTy p) (GRpcIWTy p ref r) + => GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where + type GRpcIWTy p ref r :: Type + buildGRpcIWTy :: Proxy p -> Proxy ref -> r -> GRpcIWTy p ref r + +instance ToProtoBufTypeRef ref r + => GRpcInputWrapper 'MsgProtoBuf ref r where + 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 + buildGRpcIWTy _ _ = ViaToAvroTypeRef + +class GRPCOutput (RPCTy p) (GRpcOWTy p ref r) + => GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where + type GRpcOWTy p ref r :: Type + unGRpcOWTy :: Proxy p -> Proxy ref -> GRpcOWTy p ref r -> r + +instance FromProtoBufTypeRef ref r + => GRpcOutputWrapper 'MsgProtoBuf ref r where + 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 + unGRpcOWTy _ _ = unViaFromAvroTypeRef + +-- ----------------------------- +-- IMPLEMENTATION OF THE METHODS +-- ----------------------------- + +class GRpcMethodCall (p :: GRpcMessageProtocol) method h where + gRpcMethodCall :: RPCTy p -> Proxy method -> GrpcClient -> h + +instance ( KnownName name + , GRPCInput (RPCTy p) (), GRPCOutput (RPCTy p) () + , handler ~ IO (GRpcReply ()) ) + => GRpcMethodCall p ('Method name anns '[ ] 'RetNothing) handler where + gRpcMethodCall rpc _ client = simplifyResponse $ buildGRpcReply1 <$> rawUnary rpc client () - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName -instance ( KnownName name, FromProtoBufTypeRef rref r +instance ( KnownName name + , GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r , handler ~ IO (GRpcReply r) ) - => GRpcMethodCall ('Method name anns '[ ] ('RetSingle rref)) handler where - gRpcMethodCall pkgName srvName _ client - = fmap (fmap unViaFromProtoBufTypeRef) $ + => GRpcMethodCall p ('Method name anns '[ ] ('RetSingle rref)) handler where + gRpcMethodCall rpc _ client + = fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $ simplifyResponse $ buildGRpcReply1 <$> - rawUnary @_ @_ @(ViaFromProtoBufTypeRef rref _) rpc client () - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName + rawUnary @_ @() @(GRpcOWTy p rref r) rpc client () -instance ( KnownName name, FromProtoBufTypeRef rref r - , handler ~ (IO (ConduitT () (GRpcReply r) IO ())) ) - => GRpcMethodCall ('Method name anns '[ ] ('RetStream rref)) handler where - gRpcMethodCall pkgName srvName _ client +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 rpc _ client = do -- Create a new TMChan chan <- newTMChanIO :: IO (TMChan r) var <- newEmptyTMVarIO -- if full, this means an error @@ -111,11 +155,12 @@ _ <- async $ do v <- simplifyResponse $ buildGRpcReply3 <$> - rawStreamServer @_ @() @(ViaFromProtoBufTypeRef rref r) + rawStreamServer @_ @() @(GRpcOWTy p rref r) rpc client () () - (\_ _ (ViaFromProtoBufTypeRef newVal) -> liftIO $ atomically $ + (\_ _ newVal -> liftIO $ atomically $ do -- on the first iteration, say that everything is OK - tryPutTMVar var (GRpcOk ()) >> writeTMChan chan newVal) + _ <- tryPutTMVar var (GRpcOk ()) + writeTMChan chan (unGRpcOWTy (Proxy @p) (Proxy @rref) newVal)) case v of GRpcOk () -> liftIO $ atomically $ closeTMChan chan _ -> liftIO $ atomically $ putTMVar var v @@ -126,47 +171,44 @@ sourceTMChan chan .| C.map GRpcOk e -> yield $ (\_ -> error "this should never happen") <$> e return go - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName -instance ( KnownName name, ToProtoBufTypeRef vref v +instance ( KnownName name + , GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) () , handler ~ (v -> IO (GRpcReply ())) ) - => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] 'RetNothing) handler where - gRpcMethodCall pkgName srvName _ client x + => GRpcMethodCall p ('Method name anns '[ 'ArgSingle vref ] 'RetNothing) handler where + gRpcMethodCall rpc _ client x = simplifyResponse $ buildGRpcReply1 <$> - rawUnary @_ @(ViaToProtoBufTypeRef vref _) rpc client (ViaToProtoBufTypeRef x) - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName + rawUnary @_ @(GRpcIWTy p vref v) @() rpc client (buildGRpcIWTy (Proxy @p) (Proxy @vref) x) -instance ( KnownName name, ToProtoBufTypeRef vref v, FromProtoBufTypeRef rref r +instance ( KnownName name + , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r , handler ~ (v -> IO (GRpcReply r)) ) - => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] ('RetSingle rref)) handler where - gRpcMethodCall pkgName srvName _ client x - = fmap (fmap unViaFromProtoBufTypeRef) $ + => GRpcMethodCall p ('Method name anns '[ 'ArgSingle vref ] ('RetSingle rref)) handler where + gRpcMethodCall rpc _ client x + = fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $ simplifyResponse $ buildGRpcReply1 <$> - rawUnary @_ @(ViaToProtoBufTypeRef vref _) @(ViaFromProtoBufTypeRef rref _) - rpc client (ViaToProtoBufTypeRef x) - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName + rawUnary @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + rpc client (buildGRpcIWTy (Proxy @p) (Proxy @vref) x) -instance ( KnownName name, ToProtoBufTypeRef vref v, FromProtoBufTypeRef rref r +instance ( KnownName name + , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r , handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply r))) ) - => GRpcMethodCall ('Method name anns '[ 'ArgStream vref ] ('RetSingle rref)) handler where - gRpcMethodCall pkgName srvName _ client compress + => 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 unViaFromProtoBufTypeRef) $ + fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $ simplifyResponse $ buildGRpcReply2 <$> - rawStreamClient @_ @(ViaToProtoBufTypeRef vref v) @(ViaFromProtoBufTypeRef rref r) rpc client () + 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, ViaToProtoBufTypeRef v))) + 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 @@ -175,13 +217,12 @@ Nothing -> do liftIO $ atomically $ closeTMChan chan liftIO $ wait promise return go - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName -instance ( KnownName name, ToProtoBufTypeRef vref v, FromProtoBufTypeRef rref r +instance ( KnownName name + , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r , handler ~ (v -> IO (ConduitT () (GRpcReply r) IO ())) ) - => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] ('RetStream rref)) handler where - gRpcMethodCall pkgName srvName _ client x + => GRpcMethodCall p ('Method name anns '[ 'ArgSingle vref ] ('RetStream rref)) handler where + gRpcMethodCall rpc _ client x = do -- Create a new TMChan chan <- newTMChanIO :: IO (TMChan r) var <- newEmptyTMVarIO -- if full, this means an error @@ -189,11 +230,12 @@ _ <- async $ do v <- simplifyResponse $ buildGRpcReply3 <$> - rawStreamServer @_ @(ViaToProtoBufTypeRef vref v) @(ViaFromProtoBufTypeRef rref r) - rpc client () (ViaToProtoBufTypeRef x) - (\_ _ (ViaFromProtoBufTypeRef newVal) -> liftIO $ atomically $ + rawStreamServer @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + rpc client () (buildGRpcIWTy (Proxy @p) (Proxy @vref) x) + (\_ _ newVal -> liftIO $ atomically $ do -- on the first iteration, say that everything is OK - tryPutTMVar var (GRpcOk ()) >> writeTMChan chan newVal) + _ <- tryPutTMVar var (GRpcOk ()) + writeTMChan chan (unGRpcOWTy (Proxy @p) (Proxy @rref) newVal)) case v of GRpcOk () -> liftIO $ atomically $ closeTMChan chan _ -> liftIO $ atomically $ putTMVar var v @@ -204,13 +246,12 @@ sourceTMChan chan .| C.map GRpcOk e -> yield $ (\_ -> error "this should never happen") <$> e return go - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName -instance ( KnownName name, ToProtoBufTypeRef vref v, FromProtoBufTypeRef rref r +instance ( KnownName name + , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r , handler ~ (CompressMode -> IO (ConduitT v (GRpcReply r) IO ())) ) - => GRpcMethodCall ('Method name anns '[ 'ArgStream vref ] ('RetStream rref)) handler where - gRpcMethodCall pkgName srvName _ client compress + => GRpcMethodCall p ('Method name anns '[ 'ArgStream vref ] ('RetStream rref)) handler where + gRpcMethodCall rpc _ client compress = do -- Create a new TMChan inchan <- newTMChanIO :: IO (TMChan (GRpcReply r)) outchan <- newTMChanIO :: IO (TMChan v) @@ -220,19 +261,19 @@ v <- simplifyResponse $ buildGRpcReply3 <$> rawGeneralStream - @_ @(ViaToProtoBufTypeRef vref v) @(ViaFromProtoBufTypeRef rref r) + @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) rpc client () (\_ ievent -> do -- on the first iteration, say that everything is OK _ <- liftIO $ atomically $ tryPutTMVar var (GRpcOk ()) case ievent of - RecvMessage o -> liftIO $ atomically $ writeTMChan inchan (GRpcOk $ unViaFromProtoBufTypeRef o) + RecvMessage o -> liftIO $ atomically $ writeTMChan inchan (GRpcOk $ unGRpcOWTy(Proxy @p) (Proxy @rref) o) Invalid e -> liftIO $ atomically $ writeTMChan inchan (GRpcErrorString (show e)) _ -> return () ) () (\_ -> do nextVal <- liftIO $ atomically $ readTMChan outchan case nextVal of Nothing -> return ((), Finalize) - Just v -> return ((), SendMessage compress (ViaToProtoBufTypeRef v))) + Just v -> return ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v))) case v of GRpcOk () -> liftIO $ atomically $ closeTMChan inchan _ -> liftIO $ atomically $ putTMVar var v @@ -251,5 +292,3 @@ Just Nothing -> go2 Just (Just nextIn) -> yield nextIn >> go2 return go - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName diff --git a/src/Mu/GRpc/Client/Optics.hs b/src/Mu/GRpc/Client/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GRpc/Client/Optics.hs @@ -0,0 +1,161 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Client for gRPC services using optics and labels + +For further information over initialization of the connection, +consult the . +-} +module Mu.GRpc.Client.Optics ( + -- * Initialization of the gRPC client + GRpcConnection +, initGRpc +, GRpcMessageProtocol(..) +, msgProtoBuf +, msgAvro +, G.GrpcClientConfig +, G.grpcClientConfigSimple + -- * Request arguments and responses +, CompressMode +, GRpcReply(..) + -- * Re-exported for convenience +, module Optics.Core +, module Mu.Schema.Optics +) where + +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) +import qualified Network.GRPC.Client.Helpers as G +import Network.HTTP2.Client (ClientError) +import Optics.Core + +import Mu.GRpc.Bridge +import Mu.GRpc.Client.Internal +import Mu.Rpc +import Mu.Schema +import Mu.Schema.Optics + +-- | Represents a connection to the service @s@. +newtype GRpcConnection (s :: Service Symbol Symbol) (p :: GRpcMessageProtocol) + = GRpcConnection { gcClient :: G.GrpcClient } + +-- | Initializes a connection to a gRPC server. +-- Usually the service you are connecting to is +-- inferred from the usage later on. +-- However, it can also be made explicit by using +-- +-- > initGRpc config @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 + +instance forall (serviceName :: Symbol) anns (methods :: [Method Symbol]) (m :: Symbol) + (t :: *) (p :: GRpcMessageProtocol). + ( SearchMethodOptic p methods m t + , KnownName serviceName + , KnownName (FindPackageName anns) + , KnownName m + , MkRPC p ) + => LabelOptic m A_Getter + (GRpcConnection ('Service serviceName anns methods) p) + (GRpcConnection ('Service serviceName anns methods) p) + t t where + labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcClient) + where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns))) + 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 + | p methods m -> t where + searchMethodOptic :: Proxy methods -> Proxy m -> RPCTy p -> G.GrpcClient -> t + +{- Not possible due to functional dependency +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 {-# OVERLAPPABLE #-} SearchMethodOptic p rest name t + => SearchMethodOptic p ('Method other anns ins outs ': rest) name t where + searchMethodOptic _ = searchMethodOptic @p (Proxy @rest) + +class GRpcMethodCall p method t + => MethodOptic (p :: GRpcMessageProtocol) (method :: Method Symbol) 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 +-- 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 +-- 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 + , 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 +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 + , 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 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 @@ -24,6 +24,7 @@ , setupGrpcClient' -- * Fill and generate the Haskell record of functions , buildService +, GRpcMessageProtocol(..) , CompressMode(..) , GRpcReply(..) , generateRecordFromService @@ -42,39 +43,41 @@ import Network.GRPC.Client (CompressMode (..)) import Network.GRPC.Client.Helpers +import Mu.GRpc.Bridge import Mu.GRpc.Client.Internal import Mu.Rpc -- | Fills in a Haskell record of functions with the corresponding -- calls to gRPC services from a Mu 'Service' declaration. -buildService :: forall (s :: Service') (p :: Symbol) t +buildService :: forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol) t (nm :: Symbol) (anns :: [ServiceAnnotation]) (ms :: [Method Symbol]). - (s ~ 'Service nm anns ms, Generic t, BuildService s p ms (Rep t)) + (s ~ 'Service nm anns ms, Generic t, BuildService pro s p ms (Rep t)) => GrpcClient -> t -buildService client = to (buildService' (Proxy @s) (Proxy @p) (Proxy @ms) client) +buildService client = to (buildService' (Proxy @pro) (Proxy @s) (Proxy @p) (Proxy @ms) client) -class BuildService (s :: Service') (p :: Symbol) (ms :: [Method Symbol]) (f :: * -> *) where - buildService' :: Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a +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 -instance BuildService s p ms U1 where - buildService' _ _ _ _ = U1 -instance BuildService s p ms f => BuildService s p ms (D1 meta f) where - buildService' ps ppr pms client - = M1 (buildService' ps ppr pms client) -instance BuildService s p ms f => BuildService s p ms (C1 meta f) where - buildService' ps ppr pms client - = M1 (buildService' ps ppr pms client) +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 TypeError ('Text "building a service from sums is not supported") - => BuildService s p ms (f :+: g) where + => BuildService pro s p ms (f :+: g) where buildService' = error "this should never happen" -instance (BuildService s p ms f, BuildService s p ms g) - => BuildService s p ms (f :*: g) where - buildService' ps ppr pms client - = buildService' ps ppr pms client :*: buildService' ps ppr pms client -instance (m ~ AppendSymbol p x, GRpcServiceMethodCall s (s :-->: x) h) - => BuildService s p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where - buildService' ps _ _ client - = M1 $ K1 $ gRpcServiceMethodCall ps (Proxy @(s :-->: x)) client +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 -- TEMPLATE HASKELL -- ================ 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 @@ -21,6 +21,7 @@ , setupGrpcClient' -- * Call methods from the gRPC service , gRpcCall +, GRpcMessageProtocol(..) , CompressMode(..) , GRpcReply(..) ) where @@ -31,19 +32,20 @@ import Mu.Rpc import Mu.Schema +import Mu.GRpc.Bridge import Mu.GRpc.Client.Internal -- | Call a method from a Mu definition. -- This method is thought to be used with @TypeApplications@: -- --- > gRpcCall @"packageName" @ServiceDeclaration @"method" +-- > gRpcCall @'MsgFormat @"packageName" @ServiceDeclaration @"method" -- -- The additional arguments you must provide to 'gRpcCall' -- depend on the signature of the method itself: -- * 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 s methodName h. - (GRpcServiceMethodCall s (s :-->: methodName) h) +gRpcCall :: forall (pro :: GRpcMessageProtocol) s methodName h. + (GRpcServiceMethodCall pro s (s :-->: methodName) h) => GrpcClient -> h -gRpcCall = gRpcServiceMethodCall (Proxy @s) (Proxy @(s :-->: methodName)) +gRpcCall = gRpcServiceMethodCall (Proxy @pro) (Proxy @s) (Proxy @(s :-->: methodName))