This commit is contained in:
Connor Clark 2016-06-03 14:03:57 -07:00
parent ce56953b24
commit a757e02c30
2 changed files with 34 additions and 16 deletions

View file

@ -18,18 +18,21 @@ import Network.GRPC.LowLevel.Op
-- | Represents the context needed to perform client-side gRPC operations.
data Client = Client {clientChannel :: C.Channel,
clientCQ :: CompletionQueue}
clientCQ :: CompletionQueue,
clientHostPort :: String}
-- | Configuration necessary to set up a client.
data ClientConfig = ClientConfig {clientServerHost :: Host,
clientServerPort :: Int}
createClient :: GRPC -> ClientConfig -> IO Client
createClient grpc ClientConfig{..} = do
let hostPort = (unHost clientServerHost) ++ ":" ++ (show clientServerPort)
chan <- C.grpcInsecureChannelCreate hostPort nullPtr C.reserved
cq <- createCompletionQueue grpc
return $ Client chan cq
createClient grpc conf@ClientConfig{..} = do
let clientHostPort = (unHost clientServerHost)
++ ":"
++ (show clientServerPort)
clientChannel <- C.grpcInsecureChannelCreate clientHostPort nullPtr C.reserved
clientCQ <- createCompletionQueue grpc
return $ Client{..}
destroyClient :: Client -> IO ()
destroyClient Client{..} = do
@ -54,15 +57,15 @@ clientConnectivity Client{..} =
clientRegisterMethod :: Client
-> MethodName
-- ^ method name, e.g. "/foo"
-> Host
-- ^ host name, e.g. "localhost"
-> GRPCMethodType
-> IO RegisteredMethod
clientRegisterMethod Client{..} name host Normal = do
handle <- C.grpcChannelRegisterCall clientChannel (unMethodName name)
(unHost host) C.reserved
return $ RegisteredMethod Normal name host handle
clientRegisterMethod _ _ _ _ = error "Streaming methods not yet implemented."
clientRegisterMethod Client{..} name Normal = do
handle <- C.grpcChannelRegisterCall clientChannel
(unMethodName name)
clientHostPort
C.reserved
return $ RegisteredMethod Normal name (Host clientHostPort) handle
clientRegisterMethod _ _ _ = error "Streaming methods not yet implemented."
-- | Create a new call on the client for a registered method.
-- Returns 'Left' if the CQ is shutting down or if the job to create a call

View file

@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module LowLevelTests (lowLevelTests) where
module LowLevelTests where
import Control.Concurrent.Async
import Control.Monad
@ -22,6 +22,7 @@ lowLevelTests = testGroup "Unit tests of low-level Haskell library"
, testClientRequestNoServer
, testServerAwaitNoClient
, testPayloadLowLevelUnregistered
, testWrongEndpoint
]
testGRPCBracket :: TestTree
@ -60,7 +61,7 @@ payloadLowLevelServer = TestServer $ \grpc -> do
payloadLowLevelClient :: TestClient
payloadLowLevelClient = TestClient $ \grpc ->
withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
method <- clientRegisterMethod client "/foo" "localhost" Normal
method <- clientRegisterMethod client "/foo" Normal
putStrLn "registered method on client."
let reqMeta = M.fromList [("foo_key", "foo_val")]
reqResult <- clientRegisteredRequest client method 10 "Hello!" reqMeta
@ -102,7 +103,7 @@ testClientRequestNoServer :: TestTree
testClientRequestNoServer =
grpcTest "Client - request timeout when server DNE" $ \grpc -> do
withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
method <- clientRegisterMethod client "/foo" "localhost" Normal
method <- clientRegisterMethod client "/foo" Normal
reqResult <- clientRegisteredRequest client method 1 "Hello" M.empty
reqResult @?= (Left GRPCIOTimeout)
@ -133,6 +134,20 @@ testPayloadLowLevel =
grpcTest "Client/Server - low-level (registered) request/response" $
runClientServer payloadLowLevelClient payloadLowLevelServer
payloadWrongEndpoint :: TestClient
payloadWrongEndpoint = TestClient $ \grpc ->
withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
method <- clientRegisterMethod client "/bar" Normal
reqResult <- clientRegisteredRequest client method 1 "" M.empty
reqResult @?= Left (GRPCIOBadStatusCode GrpcStatusDeadlineExceeded
(StatusDetails "Deadline Exceeded"))
testWrongEndpoint :: TestTree
testWrongEndpoint =
grpcTest "Client/Server - client requests unknown endpoint" $
runClientServer payloadLowLevelClient payloadLowLevelServer
testPayloadLowLevelUnregistered :: TestTree
testPayloadLowLevelUnregistered =
grpcTest "Client/Server - low-level unregistered request/response" $