packages feed

grpc-haskell 0.0.0.0 → 0.0.1.0

raw patch · 17 files changed

+527/−69 lines, 17 filesdep ~QuickCheckdep ~proto3-suite

Dependency ranges changed: QuickCheck, proto3-suite

Files

examples/echo/echo-hs/Echo.hs view
@@ -32,12 +32,12 @@ import Network.GRPC.HighLevel.Server as HsGRPC hiding (serverLoop) import Network.GRPC.HighLevel.Server.Unregistered as HsGRPC        (serverLoop)- + data Echo request response = Echo{echoDoEcho ::                                   request 'HsGRPC.Normal Echo.EchoRequest Echo.EchoResponse ->                                     Hs.IO (response 'HsGRPC.Normal Echo.EchoResponse)}                            deriving Hs.Generic- + echoServer ::              Echo HsGRPC.ServerRequest HsGRPC.ServerResponse ->                HsGRPC.ServiceOptions -> Hs.IO ()@@ -56,7 +56,7 @@                              optUserAgentSuffix = userAgentSuffix,                              optInitialMetadata = initialMetadata, optSSLConfig = sslConfig,                              optLogger = logger})- + echoClient ::              HsGRPC.Client ->                Hs.IO (Echo HsGRPC.ClientRequest HsGRPC.ClientResult)@@ -65,13 +65,13 @@       ((Hs.pure (HsGRPC.clientRequest client)) <*>          (HsGRPC.clientRegisterMethod client             (HsGRPC.MethodName "/echo.Echo/DoEcho")))- + data EchoRequest = EchoRequest{echoRequestMessage :: Hs.Text}                  deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)- + instance HsProtobuf.Named EchoRequest where         nameOf _ = (Hs.fromString "EchoRequest")- + instance HsProtobuf.Message EchoRequest where         encodeMessage _           EchoRequest{echoRequestMessage = echoRequestMessage}@@ -87,24 +87,24 @@                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "message")                 []-                Hs.Nothing)]- +                "")]+ instance HsJSONPB.ToJSONPB EchoRequest where         toJSONPB (EchoRequest f1) = (HsJSONPB.object ["message" .= f1])         toEncodingPB (EchoRequest f1) = (HsJSONPB.pairs ["message" .= f1])- + instance HsJSONPB.FromJSONPB EchoRequest where         parseJSONPB           = (HsJSONPB.withObject "EchoRequest"                (\ obj -> (Hs.pure EchoRequest) <*> obj .: "message"))- + instance HsJSONPB.ToJSON EchoRequest where         toJSON = HsJSONPB.toAesonValue         toEncoding = HsJSONPB.toAesonEncoding- + instance HsJSONPB.FromJSON EchoRequest where         parseJSON = HsJSONPB.parseJSONPB- + instance HsJSONPB.ToSchema EchoRequest where         declareNamedSchema _           = do let declare_message = HsJSONPB.declareSchemaRef@@ -116,17 +116,17 @@                                        HsJSONPB._namedSchemaSchema =                                          Hs.mempty{HsJSONPB._schemaParamSchema =                                                      Hs.mempty{HsJSONPB._paramSchemaType =-                                                                 HsJSONPB.SwaggerObject},+                                                                 Hs.Just HsJSONPB.SwaggerObject},                                                    HsJSONPB._schemaProperties =                                                      HsJSONPB.insOrdFromList                                                        [("message", echoRequestMessage)]}})- + data EchoResponse = EchoResponse{echoResponseMessage :: Hs.Text}                   deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)- + instance HsProtobuf.Named EchoResponse where         nameOf _ = (Hs.fromString "EchoResponse")- + instance HsProtobuf.Message EchoResponse where         encodeMessage _           EchoResponse{echoResponseMessage = echoResponseMessage}@@ -142,24 +142,24 @@                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "message")                 []-                Hs.Nothing)]- +                "")]+ instance HsJSONPB.ToJSONPB EchoResponse where         toJSONPB (EchoResponse f1) = (HsJSONPB.object ["message" .= f1])         toEncodingPB (EchoResponse f1) = (HsJSONPB.pairs ["message" .= f1])- + instance HsJSONPB.FromJSONPB EchoResponse where         parseJSONPB           = (HsJSONPB.withObject "EchoResponse"                (\ obj -> (Hs.pure EchoResponse) <*> obj .: "message"))- + instance HsJSONPB.ToJSON EchoResponse where         toJSON = HsJSONPB.toAesonValue         toEncoding = HsJSONPB.toAesonEncoding- + instance HsJSONPB.FromJSON EchoResponse where         parseJSON = HsJSONPB.parseJSONPB- + instance HsJSONPB.ToSchema EchoResponse where         declareNamedSchema _           = do let declare_message = HsJSONPB.declareSchemaRef@@ -171,7 +171,7 @@                                        HsJSONPB._namedSchemaSchema =                                          Hs.mempty{HsJSONPB._schemaParamSchema =                                                      Hs.mempty{HsJSONPB._paramSchemaType =-                                                                 HsJSONPB.SwaggerObject},+                                                                 Hs.Just HsJSONPB.SwaggerObject},                                                    HsJSONPB._schemaProperties =                                                      HsJSONPB.insOrdFromList                                                        [("message", echoResponseMessage)]}})
examples/echo/echo-hs/EchoClient.hs view
@@ -14,7 +14,6 @@ import           Echo import           GHC.Generics                     (Generic) import           Network.GRPC.HighLevel.Client-import           Network.GRPC.HighLevel.Generated import           Network.GRPC.LowLevel import           Options.Generic import           Prelude                          hiding (FilePath)
examples/hellos/hellos-client/Main.hs view
@@ -42,7 +42,7 @@   let pay        = SSRqt "server streaming mode" (fromIntegral n)       enc        = BL.toStrict . toLazyByteString $ pay       err desc e = fail $ "doHelloSS: " ++ desc ++ " error: " ++ show e-  eea <- clientReader c rm n enc mempty $ \_md recv -> do+  eea <- clientReader c rm n enc mempty $ \_cc _md recv -> do     n' <- flip fix (0::Int) $ \go i -> recv >>= \case       Left e          -> err "recv" e       Right Nothing   -> return i@@ -84,7 +84,7 @@   let pay        = BiRqtRpy "bidi payload"       enc        = BL.toStrict . toLazyByteString $ pay       err desc e = fail $ "doHelloBi: " ++ desc ++ " error: " ++ show e-  eea <- clientRW c rm n mempty $ \_getMD recv send writesDone -> do+  eea <- clientRW c rm n mempty $ \_cc _getMD recv send writesDone -> do     -- perform n writes on a worker thread     thd <- async $ do       replicateM_ n $ send enc >>= \case
examples/tutorial/Arithmetic.hs view
@@ -32,7 +32,7 @@ import Network.GRPC.HighLevel.Server as HsGRPC hiding (serverLoop) import Network.GRPC.HighLevel.Server.Unregistered as HsGRPC        (serverLoop)- + data Arithmetic request response = Arithmetic{arithmeticAdd ::                                               request 'HsGRPC.Normal Arithmetic.TwoInts                                                 Arithmetic.OneInt@@ -46,7 +46,7 @@                                                   (response 'HsGRPC.ClientStreaming                                                      Arithmetic.OneInt)}                                  deriving Hs.Generic- + arithmeticServer ::                    Arithmetic HsGRPC.ServerRequest HsGRPC.ServerResponse ->                      HsGRPC.ServiceOptions -> Hs.IO ()@@ -72,7 +72,7 @@                              optUserAgentSuffix = userAgentSuffix,                              optInitialMetadata = initialMetadata, optSSLConfig = sslConfig,                              optLogger = logger})- + arithmeticClient ::                    HsGRPC.Client ->                      Hs.IO (Arithmetic HsGRPC.ClientRequest HsGRPC.ClientResult)@@ -85,13 +85,13 @@       ((Hs.pure (HsGRPC.clientRequest client)) <*>          (HsGRPC.clientRegisterMethod client             (HsGRPC.MethodName "/arithmetic.Arithmetic/RunningSum")))- + data TwoInts = TwoInts{twoIntsX :: Hs.Int32, twoIntsY :: Hs.Int32}              deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)- + instance HsProtobuf.Named TwoInts where         nameOf _ = (Hs.fromString "TwoInts")- + instance HsProtobuf.Message TwoInts where         encodeMessage _ TwoInts{twoIntsX = twoIntsX, twoIntsY = twoIntsY}           = (Hs.mconcat@@ -111,30 +111,30 @@                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "x")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "y")                 []-                Hs.Nothing)]- +                "")]+ instance HsJSONPB.ToJSONPB TwoInts where         toJSONPB (TwoInts f1 f2) = (HsJSONPB.object ["x" .= f1, "y" .= f2])         toEncodingPB (TwoInts f1 f2)           = (HsJSONPB.pairs ["x" .= f1, "y" .= f2])- + instance HsJSONPB.FromJSONPB TwoInts where         parseJSONPB           = (HsJSONPB.withObject "TwoInts"                (\ obj -> (Hs.pure TwoInts) <*> obj .: "x" <*> obj .: "y"))- + instance HsJSONPB.ToJSON TwoInts where         toJSON = HsJSONPB.toAesonValue         toEncoding = HsJSONPB.toAesonEncoding- + instance HsJSONPB.FromJSON TwoInts where         parseJSON = HsJSONPB.parseJSONPB- + instance HsJSONPB.ToSchema TwoInts where         declareNamedSchema _           = do let declare_x = HsJSONPB.declareSchemaRef@@ -149,17 +149,17 @@                                        HsJSONPB._namedSchemaSchema =                                          Hs.mempty{HsJSONPB._schemaParamSchema =                                                      Hs.mempty{HsJSONPB._paramSchemaType =-                                                                 HsJSONPB.SwaggerObject},+                                                                 Hs.Just HsJSONPB.SwaggerObject},                                                    HsJSONPB._schemaProperties =                                                      HsJSONPB.insOrdFromList                                                        [("x", twoIntsX), ("y", twoIntsY)]}})- + data OneInt = OneInt{oneIntResult :: Hs.Int32}             deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)- + instance HsProtobuf.Named OneInt where         nameOf _ = (Hs.fromString "OneInt")- + instance HsProtobuf.Message OneInt where         encodeMessage _ OneInt{oneIntResult = oneIntResult}           = (Hs.mconcat@@ -174,24 +174,24 @@                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "result")                 []-                Hs.Nothing)]- +                "")]+ instance HsJSONPB.ToJSONPB OneInt where         toJSONPB (OneInt f1) = (HsJSONPB.object ["result" .= f1])         toEncodingPB (OneInt f1) = (HsJSONPB.pairs ["result" .= f1])- + instance HsJSONPB.FromJSONPB OneInt where         parseJSONPB           = (HsJSONPB.withObject "OneInt"                (\ obj -> (Hs.pure OneInt) <*> obj .: "result"))- + instance HsJSONPB.ToJSON OneInt where         toJSON = HsJSONPB.toAesonValue         toEncoding = HsJSONPB.toAesonEncoding- + instance HsJSONPB.FromJSON OneInt where         parseJSON = HsJSONPB.parseJSONPB- + instance HsJSONPB.ToSchema OneInt where         declareNamedSchema _           = do let declare_result = HsJSONPB.declareSchemaRef@@ -202,7 +202,7 @@                                        HsJSONPB._namedSchemaSchema =                                          Hs.mempty{HsJSONPB._schemaParamSchema =                                                      Hs.mempty{HsJSONPB._paramSchemaType =-                                                                 HsJSONPB.SwaggerObject},+                                                                 Hs.Just HsJSONPB.SwaggerObject},                                                    HsJSONPB._schemaProperties =                                                      HsJSONPB.insOrdFromList                                                        [("result", oneIntResult)]}})
grpc-haskell.cabal view
@@ -1,5 +1,5 @@ name:                grpc-haskell-version:             0.0.0.0+version:             0.0.1.0 synopsis:            Haskell implementation of gRPC layered on shared C library. homepage:            https://github.com/awakenetworks/gRPC-haskell license:             Apache-2.0@@ -10,6 +10,10 @@ category:            Network build-type:          Simple cabal-version:       >=1.10+extra-source-files:  tests/*.hs+                     tests/*.proto+                     tests/*.py+                     tests/*.sh  Flag Debug   Description: Adds debug logging.@@ -25,7 +29,7 @@   build-depends:       base >=4.8 && <5.0     , bytestring ==0.10.*-    , proto3-suite+    , proto3-suite >=0.4.0.0     , proto3-wire     , grpc-haskell-core @@ -201,7 +205,7 @@     , clock >=0.6.0 && <0.8.0     , turtle >= 1.2.0     , text-    , QuickCheck >=2.8 && <3.0+    , QuickCheck >=2.10 && <3.0   other-modules:     GeneratedTests   default-language:     Haskell2010
src/Network/GRPC/HighLevel/Client.hs view
@@ -31,6 +31,7 @@    -- * Client utility functions   , acquireClient+  , simplifyServerStreaming   , simplifyUnary   ) @@ -71,8 +72,8 @@   -- | The final field will be invoked once, and it should repeatedly   -- invoke its final argument (of type @(StreamRecv response)@)   -- in order to obtain the streaming response incrementally.-  ClientReaderRequest :: request -> TimeoutSeconds -> MetadataMap -> (MetadataMap -> StreamRecv response -> IO ()) -> ClientRequest 'ServerStreaming request response-  ClientBiDiRequest :: TimeoutSeconds -> MetadataMap -> (MetadataMap -> StreamRecv response -> StreamSend request -> WritesDone -> IO ()) -> ClientRequest 'BiDiStreaming request response+  ClientReaderRequest :: request -> TimeoutSeconds -> MetadataMap -> (LL.ClientCall -> MetadataMap -> StreamRecv response -> IO ()) -> ClientRequest 'ServerStreaming request response+  ClientBiDiRequest :: TimeoutSeconds -> MetadataMap -> (LL.ClientCall -> MetadataMap -> StreamRecv response -> StreamSend request -> WritesDone -> IO ()) -> ClientRequest 'BiDiStreaming request response  data ClientResult (streamType :: GRPCMethodType) response where   ClientNormalResponse :: response -> MetadataMap -> MetadataMap -> StatusCode -> StatusDetails -> ClientResult 'Normal response@@ -124,13 +125,13 @@         Right parsedRsp ->           ClientWriterResponse parsedRsp initMD_ trailMD_ rspCode_ details_ clientRequest client (RegisteredMethod method) (ClientReaderRequest req timeout meta handler) =-    mkResponse <$> LL.clientReader client method timeout (BL.toStrict (toLazyByteString req)) meta (\m recv -> handler m (convertRecv recv))+    mkResponse <$> LL.clientReader client method timeout (BL.toStrict (toLazyByteString req)) meta (\cc m recv -> handler cc m (convertRecv recv))   where     mkResponse (Left ioError_) = ClientErrorResponse (ClientIOError ioError_)     mkResponse (Right (meta_, rspCode_, details_)) =       ClientReaderResponse meta_ rspCode_ details_ clientRequest client (RegisteredMethod method) (ClientBiDiRequest timeout meta handler) =-    mkResponse <$> LL.clientRW client method timeout meta (\_m recv send writesDone -> handler meta (convertRecv recv) (convertSend send) writesDone)+    mkResponse <$> LL.clientRW client method timeout meta (\cc _m recv send writesDone -> handler cc meta (convertRecv recv) (convertSend send) writesDone)   where     mkResponse (Left ioError_) = ClientErrorResponse (ClientIOError ioError_)     mkResponse (Right (meta_, rspCode_, details_)) =@@ -147,20 +148,57 @@   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+-- | A utility for simplifying server-streaming gRPC client requests; you can+-- use this to avoid 'ClientRequest' and 'ClientResult' pattern-matching -- boilerplate at call sites.+simplifyServerStreaming :: TimeoutSeconds+                           -- ^ RPC call timeout, in seconds+                        -> MetadataMap+                           -- ^ RPC call metadata+                        -> (ClientError -> IO StatusDetails)+                           -- ^ Handler for client errors+                        -> (StatusCode -> StatusDetails -> IO StatusDetails)+                           -- ^ Handler for non-StatusOk response+                        -> (ClientRequest 'ServerStreaming request response+                            -> IO (ClientResult 'ServerStreaming response))+                           -- ^ Endpoint implementation (typically generated by grpc-haskell)+                        -> request+                           -- ^ Request payload+                        -> (LL.ClientCall -> MetadataMap -> StreamRecv response -> IO ())+                           -- ^ Stream handler; note that the 'StreamRecv'+                           -- action must be called repeatedly in order to+                           -- consume the stream+                        -> IO StatusDetails+simplifyServerStreaming timeout meta clientError nonStatusOkError f x handler = do++  let request = ClientReaderRequest x timeout meta handler++  response <- f request++  case response of+    ClientReaderResponse _ StatusOk details+      -> pure details++    ClientReaderResponse _ statusCode details+      -> nonStatusOkError statusCode details++    ClientErrorResponse err+      -> clientError err++-- | A utility for simplifying unary gRPC client requests; you can use this to+-- avoid 'ClientRequest' and 'ClientResult' pattern-matching boilerplate at+-- call sites. simplifyUnary :: TimeoutSeconds                 -- ^ RPC call timeout, in seconds               -> MetadataMap                  -- ^ RPC call metadata-              -> (ClientError -> IO (b, StatusDetails))+              -> (ClientError -> IO (response, StatusDetails))                  -- ^ Handler for client errors-              -> (b -> StatusCode -> StatusDetails -> IO (b, StatusDetails))+              -> (response -> StatusCode -> StatusDetails -> IO (response, 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))+              -> (ClientRequest 'Normal request response -> IO (ClientResult 'Normal response))+                 -- ^ Endpoint implementation (typically generated by grpc-haskell)+              -> (request -> IO (response, StatusDetails))                  -- ^ The simplified happy-path (StatusOk) unary call action simplifyUnary timeout meta clientError nonStatusOkError f x = do
tests/GeneratedTests.hs view
@@ -4,7 +4,7 @@ module GeneratedTests where  import Test.Tasty-import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.HUnit (assertEqual, testCase, (@?=))  import Data.String import Proto3.Suite.DotProto.Generate@@ -21,7 +21,13 @@   mktree hsTmpDir   mktree pyTmpDir -  compileDotProtoFileOrDie [] hsTmpDir ["tests"] "simple.proto"+  let args = CompileArgs+        { includeDir = ["tests"]+        , extraInstanceFiles = []+        , inputProto = "simple.proto"+        , outputDir = hsTmpDir+        }+  compileDotProtoFileOrDie args    do exitCode <- proc "tests/simple-server.sh" [hsTmpDir] empty      exitCode @?= ExitSuccess@@ -49,7 +55,13 @@   mktree hsTmpDir   mktree pyTmpDir -  compileDotProtoFileOrDie [] hsTmpDir ["tests"] "simple.proto"+  let args = CompileArgs+        { includeDir = ["tests"]+        , extraInstanceFiles = []+        , inputProto = "simple.proto"+        , outputDir = hsTmpDir+        }+  compileDotProtoFileOrDie args    do exitCode <- proc "tests/simple-client.sh" [hsTmpDir] empty      exitCode @?= ExitSuccess@@ -66,8 +78,8 @@       serverExitCode <- liftIO (wait serverExitCodeA)       clientExitCode <- liftIO (wait clientExitCodeA) -      serverExitCode @?= ExitSuccess-      clientExitCode @?= ExitSuccess+      assertEqual "Server exit code" serverExitCode ExitSuccess+      assertEqual "Client exit code" clientExitCode ExitSuccess    rmtree hsTmpDir   rmtree pyTmpDir
+ tests/TestClient.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Prelude hiding (sum)++import Simple++import Control.Concurrent+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.IO.Class+import Control.Exception+import Control.Arrow++import Data.Monoid+import Data.Foldable (sum)+import Data.String+import Data.Word+import Data.Vector (fromList)++import Network.GRPC.LowLevel+import Network.GRPC.HighLevel.Client++import Proto3.Suite++import System.Random++import Test.Tasty+import Test.Tasty.HUnit ((@?=), assertFailure, testCase)++testNormalCall client = testCase "Normal call" $+  do randoms <- fromList <$> replicateM 1000 (randomRIO (1, 1000))+     let req = SimpleServiceRequest "NormalRequest" randoms+     res <- simpleServiceNormalCall client+              (ClientNormalRequest req 10 mempty)+     case res of+       ClientErrorResponse err -> assertFailure ("ClientErrorResponse: " <> show err)+       ClientNormalResponse res _ _ stsCode _ ->+         do stsCode @?= StatusOk+            simpleServiceResponseResponse res @?= "NormalRequest"+            simpleServiceResponseNum res @?= sum randoms++testClientStreamingCall client = testCase "Client-streaming call" $+  do iterationCount <- randomRIO (5, 50)+     v <- newEmptyMVar+     res <- simpleServiceClientStreamingCall client . ClientWriterRequest 10 mempty $ \send ->+       do (finalName, totalSum) <-+             fmap ((mconcat *** (sum . mconcat)) . unzip) .+             replicateM iterationCount $+             do randoms <- fromList <$> replicateM 1000 (randomRIO (1, 1000))+                name <- fromString <$> replicateM 10 (randomRIO ('a', 'z'))+                send (SimpleServiceRequest name randoms)+                pure (name, randoms)+          putMVar v (finalName, totalSum)++     (finalName, totalSum) <- readMVar v+     case res of+       ClientErrorResponse err -> assertFailure ("ClientErrorResponse: " <> show err)+       ClientWriterResponse Nothing _ _ _ _ -> assertFailure "No response received"+       ClientWriterResponse (Just res) _ _ stsCode _ ->+         do stsCode @?= StatusOk+            simpleServiceResponseResponse res @?= finalName+            simpleServiceResponseNum res @?= totalSum++testServerStreamingCall client = testCase "Server-streaming call" $+  do numCount <- randomRIO (50, 500)+     nums <- replicateM numCount randomIO++     let checkResults [] recv =+           do res <- recv+              case res of+                Left err -> assertFailure ("recv error: " <> show err)+                Right Nothing -> pure ()+                Right (Just _) -> assertFailure "recv: elements past end of stream"+         checkResults (expNum:nums) recv =+           do res <- recv+              case res of+                Left err -> assertFailure ("recv error: " <> show err)+                Right Nothing -> assertFailure ("recv: stream ended earlier than expected")+                Right (Just (SimpleServiceResponse response num)) ->+                  do response @?= "Test"+                     num @?= expNum+                     checkResults nums recv+     res <- simpleServiceServerStreamingCall client $+            ClientReaderRequest (SimpleServiceRequest "Test" (fromList nums)) 10 mempty+              (\_ _ -> checkResults nums)+     case res of+       ClientErrorResponse err -> assertFailure ("ClientErrorResponse: " <> show err)+       ClientReaderResponse _ sts _ ->+         sts @?= StatusOk++testBiDiStreamingCall client = testCase "Bidi-streaming call" $+  do let handleRequests (0 :: Int) _ _ done = done >> pure ()+         handleRequests n recv send done =+           do numCount <- randomRIO (10, 1000)+              nums <- fromList <$> replicateM numCount (randomRIO (1, 1000))+              testName <- fromString <$> replicateM 10 (randomRIO ('a', 'z'))+              send (SimpleServiceRequest testName nums)++              res <- recv+              case res of+                Left err -> assertFailure ("recv error: " <> show err)+                Right Nothing -> pure ()+                Right (Just (SimpleServiceResponse name total)) ->+                  do name @?= testName+                     total @?= sum nums+                     handleRequests (n - 1) recv send done++     iterations <- randomRIO (50, 500)++     res <- simpleServiceBiDiStreamingCall client $+            ClientBiDiRequest 10 mempty (\_ _ -> handleRequests iterations)+     case res of+       ClientErrorResponse err -> assertFailure ("ClientErrorResponse: " <> show err)+       ClientBiDiResponse _ sts _ ->+         sts @?= StatusOk++main :: IO ()+main = do+  threadDelay 10000000+  withGRPC $ \grpc ->+   withClient grpc (ClientConfig "localhost" 50051 [] Nothing Nothing) $ \client ->+    do service <- simpleServiceClient client++       (defaultMain $ testGroup "Send gRPC requests"+          [ testNormalCall service+          , testClientStreamingCall service+          , testServerStreamingCall service+          , testBiDiStreamingCall service ]) `finally`+         (simpleServiceDone service (ClientNormalRequest SimpleServiceDone 10 mempty))
+ tests/TestServer.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Main where++import Prelude hiding (sum)++import Simple++import Control.Concurrent+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.IO.Class++import Data.Monoid+import Data.Foldable (sum)+import Data.String++import Network.GRPC.LowLevel+import Network.GRPC.HighLevel.Server+import Network.GRPC.HighLevel.Generated (defaultServiceOptions)++handleNormalCall :: ServerRequest 'Normal SimpleServiceRequest SimpleServiceResponse -> IO (ServerResponse 'Normal SimpleServiceResponse)+handleNormalCall (ServerNormalRequest meta (SimpleServiceRequest request nums)) =+  pure (ServerNormalResponse (SimpleServiceResponse request result) mempty StatusOk (StatusDetails ""))+  where result = sum nums++handleClientStreamingCall :: ServerRequest 'ClientStreaming SimpleServiceRequest SimpleServiceResponse -> IO (ServerResponse 'ClientStreaming SimpleServiceResponse)+handleClientStreamingCall (ServerReaderRequest call recvRequest) = go 0 ""+  where go sumAccum nameAccum =+          recvRequest >>= \req ->+          case req of+            Left ioError -> pure (ServerReaderResponse Nothing mempty StatusCancelled (StatusDetails ("handleClientStreamingCall: IO error: " <> fromString (show ioError))))+            Right Nothing ->+              pure (ServerReaderResponse (Just (SimpleServiceResponse nameAccum sumAccum)) mempty StatusOk (StatusDetails ""))+            Right (Just (SimpleServiceRequest name nums)) ->+              go (sumAccum + sum nums) (nameAccum <> name)++handleServerStreamingCall :: ServerRequest 'ServerStreaming SimpleServiceRequest SimpleServiceResponse -> IO (ServerResponse 'ServerStreaming SimpleServiceResponse)+handleServerStreamingCall (ServerWriterRequest call (SimpleServiceRequest requestName nums) sendResponse) = go+  where go = do forM_ nums $ \num ->+                  sendResponse (SimpleServiceResponse requestName num)+                pure (ServerWriterResponse mempty StatusOk (StatusDetails ""))++handleBiDiStreamingCall :: ServerRequest 'BiDiStreaming SimpleServiceRequest SimpleServiceResponse -> IO (ServerResponse 'BiDiStreaming SimpleServiceResponse)+handleBiDiStreamingCall (ServerBiDiRequest call recvRequest sendResponse) = go+  where go = recvRequest >>= \req ->+             case req of+               Left ioError ->+                 pure (ServerBiDiResponse mempty StatusCancelled (StatusDetails ("handleBiDiStreamingCall: IO error: " <> fromString (show ioError))))+               Right Nothing ->+                 pure (ServerBiDiResponse mempty StatusOk (StatusDetails ""))+               Right (Just (SimpleServiceRequest name nums)) ->+                 do sendResponse (SimpleServiceResponse name (sum nums))+                    go++handleDone :: MVar () -> ServerRequest 'Normal SimpleServiceDone SimpleServiceDone -> IO (ServerResponse 'Normal SimpleServiceDone)+handleDone exitVar (ServerNormalRequest _ req) =+  do forkIO (threadDelay 5000 >> putMVar exitVar ())+     pure (ServerNormalResponse req mempty StatusOk (StatusDetails ""))++main :: IO ()+main = do exitVar <- newEmptyMVar++          forkIO $ simpleServiceServer (SimpleService+            { simpleServiceDone = handleDone exitVar+            , simpleServiceNormalCall = handleNormalCall+            , simpleServiceClientStreamingCall = handleClientStreamingCall+            , simpleServiceServerStreamingCall = handleServerStreamingCall+            , simpleServiceBiDiStreamingCall = handleBiDiStreamingCall })+            defaultServiceOptions++          takeMVar exitVar
+ tests/protoc.sh view
@@ -0,0 +1,11 @@+#!/usr/bin/env bash+set -eu++pyTmpDir=$1++python                          \+    -m grpc.tools.protoc        \+    -I tests                    \+    --python_out=$pyTmpDir      \+    --grpc_python_out=$pyTmpDir \+    tests/simple.proto
+ tests/simple-client.sh view
@@ -0,0 +1,13 @@+#!/usr/bin/env bash+set -eu+hsTmpDir=$1++ghc                            \+    --make                     \+    -threaded                  \+    -odir $hsTmpDir            \+    -hidir $hsTmpDir           \+    -o $hsTmpDir/simple-client \+    $hsTmpDir/Simple.hs        \+    tests/TestClient.hs        \+    > /dev/null
+ tests/simple-server.sh view
@@ -0,0 +1,13 @@+#!/usr/bin/env bash+set -eu+hsTmpDir=$1++ghc                            \+    --make                     \+    -threaded                  \+    -odir $hsTmpDir            \+    -hidir $hsTmpDir           \+    -o $hsTmpDir/simple-server \+    $hsTmpDir/Simple.hs        \+    tests/TestServer.hs        \+    > /dev/null
+ tests/simple.proto view
@@ -0,0 +1,24 @@+syntax = "proto3";+package simple;++service SimpleService {+  rpc normalCall (SimpleServiceRequest) returns (SimpleServiceResponse) {}+  rpc clientStreamingCall (stream SimpleServiceRequest) returns (SimpleServiceResponse) {}+  rpc serverStreamingCall (SimpleServiceRequest) returns (stream SimpleServiceResponse) {}+  rpc biDiStreamingCall (stream SimpleServiceRequest) returns (stream SimpleServiceResponse) {}++  rpc done (SimpleServiceDone) returns (SimpleServiceDone) {}+}++message SimpleServiceDone {+}++message SimpleServiceRequest {+  string request = 1;+  repeated fixed32 num = 2;+}++message SimpleServiceResponse {+  string response = 1;+  fixed32 num = 2;+}
+ tests/test-client.py view
@@ -0,0 +1,83 @@+from simple_pb2 import *+from simple_pb2_grpc import *+import grpc+from uuid import uuid4+import random+import Queue++print "Starting python client"++channel = grpc.insecure_channel('localhost:50051')+stub = SimpleServiceStub(channel)++def runTests():+    # Test normal call: return a sum of all numbers sent to it+    print "Test 100 random sums"+    for i in xrange(100):+        randints = [random.randint(0, 1000) for _ in xrange(random.randint(10, 1000))]+        name = "test%d" % i+        response = stub.normalCall(SimpleServiceRequest(request = name, num = randints), timeout = 10)+        assert response.response == name+        assert response.num == sum(randints)++    # Test streaming call: The server response will be the sum of all numbers sent in the request along with a concatenation of the request name+    print "Test 100 random sums (client streaming)"+    for i in xrange(100):+        # avoid globals+        expected_sum = [0]+        expected_response_name = ['']+        def send_requests(esum, ename):+            for _ in xrange(random.randint(5, 50)):+                nums = [random.randint(0, 1000) for _ in xrange(random.randint(10, 100))]+                name = str(uuid4())+                esum[0] += sum(nums)+                ename[0] += name+                yield SimpleServiceRequest(request = name, num = nums)+        response = stub.clientStreamingCall(send_requests(expected_sum, expected_response_name), timeout = 10)+        assert response.response == expected_response_name[0]+        assert response.num == expected_sum[0]++    # Test server streaming call: The server should respond once for each number in the request+    print "Test 100 random server streaming calls"+    for i in xrange(100):+        nums = [random.randint(0, 1000) for _ in xrange(random.randint(0, 1000))]++        for response in stub.serverStreamingCall(SimpleServiceRequest(request = "server streaming", num = nums), timeout = 60):+            assert response.num == nums[0]+            assert response.response == "server streaming"+            nums = nums[1:]++    # Test bidirectional streaming: for each request, we should get a response indicating the sum of all numbers sent in the last request+    print "Test bidirectional streaming"+    for i in xrange(100):+        requests = Queue.Queue()+        def send_requests():+            for _ in xrange(random.randint(5, 50)):+                nums = [random.randint(0, 1000) for _ in xrange(random.randint(10, 100))]+                name = str(uuid4())++                requests.put((name, sum(nums)))++                yield SimpleServiceRequest(request = name, num = nums)++        for response in stub.biDiStreamingCall(send_requests(), timeout = 10):+            (exp_name, exp_sum) = requests.get()++            assert response.response == exp_name+            assert response.num == exp_sum++    print "Sending DONE message to server"+    stub.done(SimpleServiceDone(), timeout = 10)++    print "All python client tests against the generated server were successful"++try:+    runTests()+except Exception as e:+    print "Python client test exception caught: "+    print e.__doc__+    print e.message+    print "Sending DONE message to server before exiting"+    stub.done(SimpleServiceDone(), timeout = 10)+    print "Exiting with failure status"+    exit(1)
+ tests/test-client.sh view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+set -eu++python tests/test-client.py
+ tests/test-server.py view
@@ -0,0 +1,44 @@+from simple_pb2 import *+import simple_pb2_grpc+from uuid import uuid4+from concurrent import futures+import random+import Queue+import grpc++print "Starting python server"++done_queue = Queue.Queue()++class SimpleServiceServer(simple_pb2_grpc.SimpleServiceServicer):+    def done(self, request, context):+        global server+        done_queue.put_nowait(())++        return SimpleServiceDone()++    def normalCall(self, request, context):+        return SimpleServiceResponse(response = "NormalRequest", num = sum(request.num))++    def clientStreamingCall(self, requests, context):+        cur_name = ""+        cur_sum = 0+        for request in requests:+            cur_name += request.request+            cur_sum += sum(request.num)+        return SimpleServiceResponse(response = cur_name, num = cur_sum)++    def serverStreamingCall(self, request, context):+        for num in request.num:+            yield SimpleServiceResponse(response = request.request, num = num)++    def biDiStreamingCall(self, requests, context):+        for request in requests:+            yield SimpleServiceResponse(response = request.request, num = sum(request.num))++server = grpc.server(futures.ThreadPoolExecutor(max_workers=1))+simple_pb2_grpc.add_SimpleServiceServicer_to_server(SimpleServiceServer(), server)+server.add_insecure_port('[::]:50051')+server.start()++done_queue.get()
+ tests/test-server.sh view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+set -eu++python tests/test-server.py