diff --git a/bench/Bench.hs b/bench/Bench.hs index 56cae40..2f20609 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -97,7 +97,7 @@ serverOpts = main :: IO () main = bracket startServer stopServer $ const $ withGRPC $ \grpc -> - withClient grpc (ClientConfig "localhost" 50051 [] Nothing) $ \c -> do + withClient grpc (ClientConfig "localhost" 50051 [] Nothing Nothing) $ \c -> do rmAdd <- clientRegisterMethodNormal c addMethod rmClientStream <- clientRegisterMethodClientStreaming c addClientStreamMethod rmServerStream <- clientRegisterMethodServerStreaming c addServerStreamMethod diff --git a/core/src/Network/GRPC/LowLevel/Client.hs b/core/src/Network/GRPC/LowLevel/Client.hs index d591218..a221c82 100644 --- a/core/src/Network/GRPC/LowLevel/Client.hs +++ b/core/src/Network/GRPC/LowLevel/Client.hs @@ -37,8 +37,9 @@ data Client = Client {clientChannel :: C.Channel, } data ClientSSLKeyCertPair = ClientSSLKeyCertPair - {clientPrivateKey :: FilePath, - clientCert :: FilePath} + { clientPrivateKey :: FilePath, + clientCert :: FilePath + } deriving Show -- | SSL configuration for the client. It's perfectly acceptable for both fields -- to be 'Nothing', in which case default fallbacks will be used for the server diff --git a/examples/echo/echo-hs/EchoClient.hs b/examples/echo/echo-hs/EchoClient.hs index a84dd34..899f6e3 100644 --- a/examples/echo/echo-hs/EchoClient.hs +++ b/examples/echo/echo-hs/EchoClient.hs @@ -36,7 +36,7 @@ main = do cfg = ClientConfig (Host . fromMaybe "localhost" . unHelpful $ bind) (Port . fromMaybe 50051 . unHelpful $ port) - [] Nothing + [] Nothing Nothing withGRPC $ \g -> withClient g cfg $ \c -> do Echo{..} <- echoClient c echoDoEcho (ClientNormalRequest rqt 5 mempty) >>= \case diff --git a/examples/hellos/hellos-client/Main.hs b/examples/hellos/hellos-client/Main.hs index ee65368..58e244c 100644 --- a/examples/hellos/hellos-client/Main.hs +++ b/examples/hellos/hellos-client/Main.hs @@ -110,7 +110,7 @@ doHelloBi c n = do highlevelMain :: IO () highlevelMain = withGRPC $ \g -> - withClient g (ClientConfig "localhost" 50051 [] Nothing) $ \c -> do + withClient g (ClientConfig "localhost" 50051 [] Nothing Nothing) $ \c -> do let n = 100000 putStrLn "-------------- HelloSS --------------" doHelloSS c n diff --git a/examples/tutorial/ArithmeticClient.hs b/examples/tutorial/ArithmeticClient.hs index 8b52d7f..84b822b 100644 --- a/examples/tutorial/ArithmeticClient.hs +++ b/examples/tutorial/ArithmeticClient.hs @@ -11,6 +11,7 @@ clientConfig = ClientConfig { clientServerHost = "localhost" , clientServerPort = 50051 , clientArgs = [] , clientSSLConfig = Nothing + , clientAuthority = Nothing } main :: IO () diff --git a/examples/tutorial/TUTORIAL.md b/examples/tutorial/TUTORIAL.md index 9fc8c59..e79d3e8 100644 --- a/examples/tutorial/TUTORIAL.md +++ b/examples/tutorial/TUTORIAL.md @@ -159,6 +159,7 @@ clientConfig = ClientConfig { clientServerHost = "localhost" , clientServerPort = 50051 , clientArgs = [] , clientSSLConfig = Nothing + , clientAuthority = Nothing } main :: IO () diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal index 396d493..50e5d27 100644 --- a/grpc-haskell.cabal +++ b/grpc-haskell.cabal @@ -30,6 +30,7 @@ library , grpc-haskell-core , async ==2.1.* + , managed >= 1.0.5 exposed-modules: Network.GRPC.HighLevel @@ -37,10 +38,8 @@ library Network.GRPC.HighLevel.Server Network.GRPC.HighLevel.Server.Unregistered Network.GRPC.HighLevel.Client - build-tools: c2hs default-language: Haskell2010 ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind - include-dirs: include hs-source-dirs: src default-extensions: CPP CC-Options: -std=c99 diff --git a/release.nix b/release.nix index 0748429..b957772 100644 --- a/release.nix +++ b/release.nix @@ -213,7 +213,10 @@ let (haskellPackagesNew.callPackage ./nix/proto3-suite.nix {}); grpc-haskell-core = - usesGRPC (haskellPackagesNew.callPackage ./core { }); + usesGRPC + (pkgs.haskell.lib.overrideCabal + (haskellPackagesNew.callPackage ./core { }) + (_: { buildDepends = [ haskellPackagesNew.c2hs ]; })); grpc-haskell-no-tests = usesGRPC @@ -242,11 +245,18 @@ let ]); in rec { + configureFlags = (oldDerivation.configureFlags or []) ++ [ + "--flags=with-examples" + ]; + buildDepends = [ pkgs.makeWrapper # Give our nix-shell its own cabal so we don't pick up one # from the user's environment by accident. haskellPackagesNew.cabal-install + + # And likewise for c2hs + haskellPackagesNew.c2hs ]; patches = [ tests/tests.patch ]; @@ -299,11 +309,18 @@ let pkgs = import nixpkgs { inherit config; }; in - { grpc-haskell-linux = linuxPkgs.haskellPackages.grpc-haskell; - grpc-haskell-darwin = darwinPkgs.haskellPackages.grpc-haskell; - grpc-haskell = pkgs.haskellPackages.grpc-haskell; - grpc-haskell-no-tests = pkgs.haskellPackages.grpc-haskell-no-tests; - grpc-linux = linuxPkgs.grpc; - grpc-darwin = darwinPkgs.grpc; - grpc = pkgs.grpc; + { + grpc-haskell-core-linux = linuxPkgs.haskellPackages.grpc-haskell-core; + grpc-haskell-core-darwin = darwinPkgs.haskellPackages.grpc-haskell-core; + grpc-haskell-core = pkgs.haskellPackages.grpc-haskell-core; + + grpc-haskell-linux = linuxPkgs.haskellPackages.grpc-haskell; + grpc-haskell-darwin = darwinPkgs.haskellPackages.grpc-haskell; + grpc-haskell = pkgs.haskellPackages.grpc-haskell; + grpc-haskell-no-tests = pkgs.haskellPackages.grpc-haskell-no-tests; + + grpc-linux = linuxPkgs.grpc; + grpc-darwin = darwinPkgs.grpc; + + grpc = pkgs.grpc; } diff --git a/src/Network/GRPC/HighLevel/Client.hs b/src/Network/GRPC/HighLevel/Client.hs index 812b755..abc5c25 100644 --- a/src/Network/GRPC/HighLevel/Client.hs +++ b/src/Network/GRPC/HighLevel/Client.hs @@ -1,44 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} module Network.GRPC.HighLevel.Client - ( RegisteredMethod - , TimeoutSeconds - , MetadataMap(..) - , StatusDetails(..) - , GRPCMethodType(..) - , StreamRecv - , StreamSend - , WritesDone - , LL.Client - , ServiceClient - , ClientError(..) + ( ClientError(..) + , ClientRegisterable(..) , ClientRequest(..) , ClientResult(..) - , ClientRegisterable(..) + , GRPCMethodType(..) + , MetadataMap(..) + , RegisteredMethod + , ServiceClient + , StatusCode(..) + , StatusDetails(..) + , StreamRecv + , StreamSend + , TimeoutSeconds + , WritesDone + + , LL.Client + , LL.ClientConfig(..) + , LL.ClientSSLConfig(..) + , LL.ClientSSLKeyCertPair(..) + , LL.Host(..) + , LL.Port(..) + , clientRequest + + -- * Client utility functions + , acquireClient + , simplifyUnary ) where -import qualified Network.GRPC.LowLevel.Client as LL -import qualified Network.GRPC.LowLevel.Call as LL -import Network.GRPC.LowLevel.CompletionQueue (TimeoutSeconds) -import Network.GRPC.LowLevel ( GRPCMethodType(..) - , StatusCode(..) - , StatusDetails(..) - , MetadataMap(..) - , GRPCIOError(..) - , StreamRecv - , StreamSend ) -import Network.GRPC.LowLevel.Op (WritesDone) -import Network.GRPC.HighLevel.Server (convertRecv, convertSend) - -import Proto3.Suite (Message, toLazyByteString, fromByteString) -import Proto3.Wire.Decode (ParseError) -import qualified Data.ByteString.Lazy as BL +import Control.Monad.Managed (Managed, liftIO, + managed) +import qualified Data.ByteString.Lazy as BL +import Network.GRPC.HighLevel.Server (convertRecv, + convertSend) +import Network.GRPC.LowLevel (GRPCIOError (..), + GRPCMethodType (..), + MetadataMap (..), + StatusCode (..), + StatusDetails (..), + StreamRecv, StreamSend) +import qualified Network.GRPC.LowLevel as LL +import Network.GRPC.LowLevel.CompletionQueue (TimeoutSeconds) +import Network.GRPC.LowLevel.Op (WritesDone) +import Proto3.Suite (Message, fromByteString, + toLazyByteString) +import Proto3.Wire.Decode (ParseError) newtype RegisteredMethod (mt :: GRPCMethodType) request response = RegisteredMethod (LL.RegisteredMethod mt) @@ -121,3 +135,45 @@ clientRequest client (RegisteredMethod method) (ClientBiDiRequest timeout meta h mkResponse (Left ioError_) = ClientErrorResponse (ClientIOError ioError_) mkResponse (Right (meta_, rspCode_, details_)) = ClientBiDiResponse meta_ rspCode_ details_ + +acquireClient + :: LL.ClientConfig + -- ^ The client configuration (host, port, SSL settings, etc) + -> (LL.Client -> IO (ServiceClient service)) + -- ^ The client implementation (typically generated) + -> Managed (ServiceClient service) +acquireClient cfg impl = do + g <- managed LL.withGRPC + c <- managed (LL.withClient g cfg) + liftIO (impl c) + +-- | A utility for simplifying gRPC client requests in common cases; you can use +-- this to avoid 'ClientRequest' and 'ClientResponse' pattern-matching +-- boilerplate at call sites. +simplifyUnary :: TimeoutSeconds + -- ^ RPC call timeout, in seconds + -> MetadataMap + -- ^ RPC call metadata + -> (ClientError -> IO (b, StatusDetails)) + -- ^ Handler for client errors + -> (b -> StatusCode -> StatusDetails -> IO (b, StatusDetails)) + -- ^ Handler for non-StatusOK responses + -> (ClientRequest 'Normal a b -> IO (ClientResult 'Normal b)) + -- ^ gRPC function implementation (typically generated by gRPC-haskell) + -> (a -> IO (b, StatusDetails)) + -- ^ The simplified happy-path (StatusOk) unary call action +simplifyUnary timeout meta clientError nonStatusOkError f x = do + + let request = ClientNormalRequest x timeout meta + + response <- f request + + case response of + ClientNormalResponse y _ _ StatusOk details + -> pure (y, details) + + ClientNormalResponse y _ _ code details + -> nonStatusOkError y code details + + ClientErrorResponse err + -> clientError err