diff --git a/examples/echo/echo-hs/Echo.hs b/examples/echo/echo-hs/Echo.hs --- a/examples/echo/echo-hs/Echo.hs +++ b/examples/echo/echo-hs/Echo.hs @@ -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)]}}) diff --git a/examples/echo/echo-hs/EchoClient.hs b/examples/echo/echo-hs/EchoClient.hs --- a/examples/echo/echo-hs/EchoClient.hs +++ b/examples/echo/echo-hs/EchoClient.hs @@ -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) diff --git a/examples/hellos/hellos-client/Main.hs b/examples/hellos/hellos-client/Main.hs --- a/examples/hellos/hellos-client/Main.hs +++ b/examples/hellos/hellos-client/Main.hs @@ -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 diff --git a/examples/tutorial/Arithmetic.hs b/examples/tutorial/Arithmetic.hs --- a/examples/tutorial/Arithmetic.hs +++ b/examples/tutorial/Arithmetic.hs @@ -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)]}}) diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal --- a/grpc-haskell.cabal +++ b/grpc-haskell.cabal @@ -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 diff --git a/src/Network/GRPC/HighLevel/Client.hs b/src/Network/GRPC/HighLevel/Client.hs --- a/src/Network/GRPC/HighLevel/Client.hs +++ b/src/Network/GRPC/HighLevel/Client.hs @@ -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 diff --git a/tests/GeneratedTests.hs b/tests/GeneratedTests.hs --- a/tests/GeneratedTests.hs +++ b/tests/GeneratedTests.hs @@ -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 diff --git a/tests/TestClient.hs b/tests/TestClient.hs new file mode 100644 --- /dev/null +++ b/tests/TestClient.hs @@ -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)) diff --git a/tests/TestServer.hs b/tests/TestServer.hs new file mode 100644 --- /dev/null +++ b/tests/TestServer.hs @@ -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 diff --git a/tests/protoc.sh b/tests/protoc.sh new file mode 100644 --- /dev/null +++ b/tests/protoc.sh @@ -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 diff --git a/tests/simple-client.sh b/tests/simple-client.sh new file mode 100644 --- /dev/null +++ b/tests/simple-client.sh @@ -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 diff --git a/tests/simple-server.sh b/tests/simple-server.sh new file mode 100644 --- /dev/null +++ b/tests/simple-server.sh @@ -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 diff --git a/tests/simple.proto b/tests/simple.proto new file mode 100644 --- /dev/null +++ b/tests/simple.proto @@ -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; +} diff --git a/tests/test-client.py b/tests/test-client.py new file mode 100644 --- /dev/null +++ b/tests/test-client.py @@ -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) diff --git a/tests/test-client.sh b/tests/test-client.sh new file mode 100644 --- /dev/null +++ b/tests/test-client.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +set -eu + +python tests/test-client.py diff --git a/tests/test-server.py b/tests/test-server.py new file mode 100644 --- /dev/null +++ b/tests/test-server.py @@ -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() diff --git a/tests/test-server.sh b/tests/test-server.sh new file mode 100644 --- /dev/null +++ b/tests/test-server.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +set -eu + +python tests/test-server.py