mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-11-05 10:49:42 +01:00
096d399b30
* (wip) Change ClientRWHandler to use an IO action for metadata acqui * Demonstrate placement of WaitForInitialMetadata() in hellos_client * Make hellos cpp server always send metadata first, for now * Show getMD placement in haskell hellos-client * Add prelim bidi metadata exchange behavior tweaks to line up with C++ API conventions
651 lines
24 KiB
Haskell
651 lines
24 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module LowLevelTests where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.Async
|
|
import Control.Monad
|
|
import Control.Monad.Managed
|
|
import Data.ByteString (ByteString,
|
|
isPrefixOf,
|
|
isSuffixOf)
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Set as S
|
|
import GHC.Exts (fromList, toList)
|
|
import Network.GRPC.LowLevel
|
|
import Network.GRPC.LowLevel.GRPC (threadDelaySecs)
|
|
import qualified Network.GRPC.LowLevel.Call.Unregistered as U
|
|
import qualified Network.GRPC.LowLevel.Client.Unregistered as U
|
|
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
|
|
import qualified Pipes as P
|
|
import Test.Tasty
|
|
import Test.Tasty.HUnit as HU (Assertion,
|
|
assertBool,
|
|
assertEqual,
|
|
assertFailure,
|
|
testCase,
|
|
(@?=))
|
|
|
|
lowLevelTests :: TestTree
|
|
lowLevelTests = testGroup "Unit tests of low-level Haskell library"
|
|
[ testGRPCBracket
|
|
, testCompletionQueueCreateDestroy
|
|
, testClientCreateDestroy
|
|
, testClientCall
|
|
, testClientTimeoutNoServer
|
|
, testServerCreateDestroy
|
|
, testMixRegisteredUnregistered
|
|
, testPayload
|
|
, testPayloadUnregistered
|
|
, testServerCancel
|
|
, testGoaway
|
|
, testSlowServer
|
|
, testServerCallExpirationCheck
|
|
, testCustomUserAgent
|
|
, testClientCompression
|
|
, testClientServerCompression
|
|
, testClientStreaming
|
|
, testClientStreamingUnregistered
|
|
, testServerStreaming
|
|
, testServerStreamingUnregistered
|
|
, testBiDiStreaming
|
|
, testBiDiStreamingUnregistered
|
|
]
|
|
|
|
testGRPCBracket :: TestTree
|
|
testGRPCBracket =
|
|
testCase "Start/stop GRPC" $ runManaged $ void mgdGRPC
|
|
|
|
testCompletionQueueCreateDestroy :: TestTree
|
|
testCompletionQueueCreateDestroy =
|
|
testCase "Create/destroy CQ" $ runManaged $ do
|
|
g <- mgdGRPC
|
|
liftIO (withCompletionQueue g nop)
|
|
|
|
testClientCreateDestroy :: TestTree
|
|
testClientCreateDestroy =
|
|
clientOnlyTest "start/stop" nop
|
|
|
|
testClientTimeoutNoServer :: TestTree
|
|
testClientTimeoutNoServer =
|
|
clientOnlyTest "request timeout when server DNE" $ \c -> do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
r <- clientRequest c rm 1 "Hello" mempty
|
|
r @?= Left GRPCIOTimeout
|
|
|
|
testServerCreateDestroy :: TestTree
|
|
testServerCreateDestroy =
|
|
serverOnlyTest "start/stop" (["/foo"],[],[],[]) nop
|
|
|
|
testMixRegisteredUnregistered :: TestTree
|
|
testMixRegisteredUnregistered =
|
|
csTest "server uses unregistered calls to handle unknown endpoints"
|
|
client
|
|
server
|
|
(["/foo"],[],[],[])
|
|
where
|
|
client c = do
|
|
rm1 <- clientRegisterMethodNormal c "/foo"
|
|
rm2 <- clientRegisterMethodNormal c "/bar"
|
|
clientRequest c rm1 1 "Hello" mempty >>= do
|
|
checkReqRslt $ \NormalRequestResult{..} -> do
|
|
rspBody @?= "reply test"
|
|
initMD @?= dummyMeta
|
|
trailMD @?= dummyMeta
|
|
clientRequest c rm2 1 "bad endpoint" mempty >>= do
|
|
checkReqRslt $ \NormalRequestResult{..} -> do
|
|
rspBody @?= ""
|
|
return ()
|
|
server s = do
|
|
concurrently regThread unregThread
|
|
return ()
|
|
where regThread = do
|
|
let rm = head (normalMethods s)
|
|
_r <- serverHandleNormalCall s rm dummyMeta $ \c -> do
|
|
payload c @?= "Hello"
|
|
return ("reply test", dummyMeta, StatusOk, "")
|
|
return ()
|
|
unregThread = do
|
|
U.serverHandleNormalCall s mempty $ \call _ -> do
|
|
U.callMethod call @?= "/bar"
|
|
return ("", mempty, StatusOk,
|
|
StatusDetails "Wrong endpoint")
|
|
return ()
|
|
|
|
-- TODO: There seems to be a race here (and in other client/server pairs, of
|
|
-- course) about what gets reported when there is a failure. E.g., if one of the
|
|
-- Assertions fails in the request processing block for the server, we /may/ get
|
|
-- that error reported accurately as a call cancellation on the client, rather
|
|
-- than a useful error about the failure on the server. Maybe we'll need to
|
|
-- tweak EH behavior / async use.
|
|
testPayload :: TestTree
|
|
testPayload =
|
|
csTest "registered normal request/response" client server (["/foo"],[],[],[])
|
|
where
|
|
clientMD = [ ("foo_key", "foo_val")
|
|
, ("bar_key", "bar_val")
|
|
, ("bar_key", "bar_repeated_val")]
|
|
client c = do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
clientRequest c rm 10 "Hello!" clientMD >>= do
|
|
checkReqRslt $ \NormalRequestResult{..} -> do
|
|
rspCode @?= StatusOk
|
|
rspBody @?= "reply test"
|
|
details @?= "details string"
|
|
initMD @?= dummyMeta
|
|
trailMD @?= dummyMeta
|
|
server s = do
|
|
let rm = head (normalMethods s)
|
|
r <- serverHandleNormalCall s rm dummyMeta $ \c -> do
|
|
payload c @?= "Hello!"
|
|
checkMD "Server metadata mismatch" clientMD (metadata c)
|
|
return ("reply test", dummyMeta, StatusOk, "details string")
|
|
r @?= Right ()
|
|
|
|
testServerCancel :: TestTree
|
|
testServerCancel =
|
|
csTest "server cancel call" client server (["/foo"],[],[],[])
|
|
where
|
|
client c = do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
Left (GRPCIOBadStatusCode s _) <- clientRequest c rm 10 "" mempty
|
|
s @?= StatusCancelled
|
|
server s = do
|
|
let rm = head (normalMethods s)
|
|
r <- serverHandleNormalCall s rm mempty $ \c -> do
|
|
serverCallCancel c StatusCancelled ""
|
|
return (mempty, mempty, StatusCancelled, "")
|
|
r @?= Right ()
|
|
|
|
testServerStreaming :: TestTree
|
|
testServerStreaming =
|
|
csTest "server streaming" client server ([],[],["/feed"],[])
|
|
where
|
|
clientInitMD = [("client","initmd")]
|
|
serverInitMD = [("server","initmd")]
|
|
clientPay = "FEED ME!"
|
|
pays = ["ONE", "TWO", "THREE", "FOUR"] :: [ByteString]
|
|
|
|
client c = do
|
|
rm <- clientRegisterMethodServerStreaming c "/feed"
|
|
eea <- clientReader c rm 10 clientPay clientInitMD $ \initMD recv -> do
|
|
checkMD "Server initial metadata mismatch" serverInitMD initMD
|
|
forM_ pays $ \p -> recv `is` Right (Just p)
|
|
recv `is` Right Nothing
|
|
eea @?= Right (dummyMeta, StatusOk, "dtls")
|
|
|
|
server s = do
|
|
let rm = head (sstreamingMethods s)
|
|
r <- serverWriter s rm serverInitMD $ \sc send -> do
|
|
checkMD "Server request metadata mismatch" clientInitMD (metadata sc)
|
|
payload sc @?= clientPay
|
|
forM_ pays $ \p -> send p `is` Right ()
|
|
return (dummyMeta, StatusOk, "dtls")
|
|
r @?= Right ()
|
|
|
|
-- TODO: these unregistered streaming tests are basically the same as the
|
|
-- registered ones. Reduce duplication.
|
|
-- TODO: Once client-side unregistered streaming functions are added, switch
|
|
-- to using them in these tests.
|
|
testServerStreamingUnregistered :: TestTree
|
|
testServerStreamingUnregistered =
|
|
csTest "unregistered server streaming" client server ([],[],[],[])
|
|
where
|
|
clientInitMD = [("client","initmd")]
|
|
serverInitMD = [("server","initmd")]
|
|
clientPay = "FEED ME!"
|
|
pays = ["ONE", "TWO", "THREE", "FOUR"] :: [ByteString]
|
|
|
|
client c = do
|
|
rm <- clientRegisterMethodServerStreaming c "/feed"
|
|
eea <- clientReader c rm 10 clientPay clientInitMD $ \initMD recv -> do
|
|
checkMD "Server initial metadata mismatch" serverInitMD initMD
|
|
forM_ pays $ \p -> recv `is` Right (Just p)
|
|
recv `is` Right Nothing
|
|
eea @?= Right (dummyMeta, StatusOk, "dtls")
|
|
|
|
server s = U.withServerCallAsync s $ \call -> do
|
|
r <- U.serverWriter s call serverInitMD $ \sc send -> do
|
|
checkMD "Server request metadata mismatch" clientInitMD (metadata sc)
|
|
payload sc @?= clientPay
|
|
forM_ pays $ \p -> send p `is` Right ()
|
|
return (dummyMeta, StatusOk, "dtls")
|
|
r @?= Right ()
|
|
|
|
testClientStreaming :: TestTree
|
|
testClientStreaming =
|
|
csTest "client streaming" client server ([],["/slurp"],[],[])
|
|
where
|
|
clientInitMD = [("a","b")]
|
|
serverInitMD = [("x","y")]
|
|
trailMD = dummyMeta
|
|
serverRsp = "serverReader reply"
|
|
serverDtls = "deets"
|
|
serverStatus = StatusOk
|
|
pays = ["P_ONE", "P_TWO", "P_THREE"] :: [ByteString]
|
|
|
|
client c = do
|
|
rm <- clientRegisterMethodClientStreaming c "/slurp"
|
|
eea <- clientWriter c rm 10 clientInitMD $ \send -> do
|
|
-- liftIO $ checkMD "Server initial metadata mismatch" serverInitMD initMD
|
|
forM_ pays $ \p -> send p `is` Right ()
|
|
eea @?= Right (Just serverRsp, serverInitMD, trailMD, serverStatus, serverDtls)
|
|
|
|
server s = do
|
|
let rm = head (cstreamingMethods s)
|
|
eea <- serverReader s rm serverInitMD $ \sc recv -> do
|
|
checkMD "Client request metadata mismatch" clientInitMD (metadata sc)
|
|
forM_ pays $ \p -> recv `is` Right (Just p)
|
|
recv `is` Right Nothing
|
|
return (Just serverRsp, trailMD, serverStatus, serverDtls)
|
|
eea @?= Right ()
|
|
|
|
testClientStreamingUnregistered :: TestTree
|
|
testClientStreamingUnregistered =
|
|
csTest "unregistered client streaming" client server ([],[],[],[])
|
|
where
|
|
clientInitMD = [("a","b")]
|
|
serverInitMD = [("x","y")]
|
|
trailMD = dummyMeta
|
|
serverRsp = "serverReader reply"
|
|
serverDtls = "deets"
|
|
serverStatus = StatusOk
|
|
pays = ["P_ONE", "P_TWO", "P_THREE"] :: [ByteString]
|
|
|
|
client c = do
|
|
rm <- clientRegisterMethodClientStreaming c "/slurp"
|
|
eea <- clientWriter c rm 10 clientInitMD $ \send -> do
|
|
-- liftIO $ checkMD "Server initial metadata mismatch" serverInitMD initMD
|
|
forM_ pays $ \p -> send p `is` Right ()
|
|
eea @?= Right (Just serverRsp, serverInitMD, trailMD, serverStatus, serverDtls)
|
|
|
|
server s = U.withServerCallAsync s $ \call -> do
|
|
eea <- U.serverReader s call serverInitMD $ \sc recv -> do
|
|
checkMD "Client request metadata mismatch" clientInitMD (metadata sc)
|
|
forM_ pays $ \p -> recv `is` Right (Just p)
|
|
recv `is` Right Nothing
|
|
return (Just serverRsp, trailMD, serverStatus, serverDtls)
|
|
eea @?= Right ()
|
|
|
|
testBiDiStreaming :: TestTree
|
|
testBiDiStreaming =
|
|
csTest "bidirectional streaming" client server ([],[],[],["/bidi"])
|
|
where
|
|
clientInitMD = [("bidi-streaming","client")]
|
|
serverInitMD = [("bidi-streaming","server")]
|
|
trailMD = dummyMeta
|
|
serverStatus = StatusOk
|
|
serverDtls = "deets"
|
|
|
|
client c = do
|
|
rm <- clientRegisterMethodBiDiStreaming c "/bidi"
|
|
eea <- clientRW c rm 10 clientInitMD $ \getMD recv send writesDone -> do
|
|
either clientFail (checkMD "Server rsp metadata mismatch" serverInitMD) =<< getMD
|
|
send "cw0" `is` Right ()
|
|
recv `is` Right (Just "sw0")
|
|
send "cw1" `is` Right ()
|
|
recv `is` Right (Just "sw1")
|
|
recv `is` Right (Just "sw2")
|
|
writesDone `is` Right ()
|
|
recv `is` Right Nothing
|
|
eea @?= Right (trailMD, serverStatus, serverDtls)
|
|
|
|
server s = do
|
|
let rm = head (bidiStreamingMethods s)
|
|
eea <- serverRW s rm serverInitMD $ \sc recv send -> do
|
|
checkMD "Client request metadata mismatch" clientInitMD (metadata sc)
|
|
recv `is` Right (Just "cw0")
|
|
send "sw0" `is` Right ()
|
|
recv `is` Right (Just "cw1")
|
|
send "sw1" `is` Right ()
|
|
send "sw2" `is` Right ()
|
|
recv `is` Right Nothing
|
|
return (trailMD, serverStatus, serverDtls)
|
|
eea @?= Right ()
|
|
|
|
testBiDiStreamingUnregistered :: TestTree
|
|
testBiDiStreamingUnregistered =
|
|
csTest "unregistered bidirectional streaming" client server ([],[],[],[])
|
|
where
|
|
clientInitMD = [("bidi-streaming","client")]
|
|
serverInitMD = [("bidi-streaming","server")]
|
|
trailMD = dummyMeta
|
|
serverStatus = StatusOk
|
|
serverDtls = "deets"
|
|
|
|
client c = do
|
|
rm <- clientRegisterMethodBiDiStreaming c "/bidi"
|
|
eea <- clientRW c rm 10 clientInitMD $ \getMD recv send writesDone -> do
|
|
either clientFail (checkMD "Server rsp metadata mismatch" serverInitMD) =<< getMD
|
|
send "cw0" `is` Right ()
|
|
recv `is` Right (Just "sw0")
|
|
send "cw1" `is` Right ()
|
|
recv `is` Right (Just "sw1")
|
|
recv `is` Right (Just "sw2")
|
|
writesDone `is` Right ()
|
|
recv `is` Right Nothing
|
|
eea @?= Right (trailMD, serverStatus, serverDtls)
|
|
|
|
server s = U.withServerCallAsync s $ \call -> do
|
|
eea <- U.serverRW s call serverInitMD $ \sc recv send -> do
|
|
checkMD "Client request metadata mismatch" clientInitMD (metadata sc)
|
|
recv `is` Right (Just "cw0")
|
|
send "sw0" `is` Right ()
|
|
recv `is` Right (Just "cw1")
|
|
send "sw1" `is` Right ()
|
|
send "sw2" `is` Right ()
|
|
recv `is` Right Nothing
|
|
return (trailMD, serverStatus, serverDtls)
|
|
eea @?= Right ()
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Unregistered tests
|
|
|
|
testClientCall :: TestTree
|
|
testClientCall =
|
|
clientOnlyTest "create/destroy call" $ \c -> do
|
|
r <- U.withClientCall c "/foo" 10 $ const $ return $ Right ()
|
|
r @?= Right ()
|
|
|
|
testServerCall :: TestTree
|
|
testServerCall =
|
|
serverOnlyTest "create/destroy call" ([],[],[],[]) $ \s -> do
|
|
r <- U.withServerCall s $ const $ return $ Right ()
|
|
r @?= Left GRPCIOTimeout
|
|
|
|
testPayloadUnregistered :: TestTree
|
|
testPayloadUnregistered =
|
|
csTest "unregistered normal request/response" client server ([],[],[],[])
|
|
where
|
|
client c =
|
|
U.clientRequest c "/foo" 10 "Hello!" mempty >>= do
|
|
checkReqRslt $ \NormalRequestResult{..} -> do
|
|
rspCode @?= StatusOk
|
|
rspBody @?= "reply test"
|
|
details @?= "details string"
|
|
server s = do
|
|
r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{..} body -> do
|
|
body @?= "Hello!"
|
|
callMethod @?= "/foo"
|
|
return ("reply test", mempty, StatusOk, "details string")
|
|
r @?= Right ()
|
|
|
|
testGoaway :: TestTree
|
|
testGoaway =
|
|
csTest "Client handles server shutdown gracefully"
|
|
client
|
|
server
|
|
(["/foo"],[],[],[])
|
|
where
|
|
client c = do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
clientRequest c rm 10 "" mempty
|
|
clientRequest c rm 10 "" mempty
|
|
lastResult <- clientRequest c rm 1 "" mempty
|
|
assertBool "Client handles server shutdown gracefully" $
|
|
lastResult == badStatus StatusUnavailable
|
|
||
|
|
lastResult == badStatus StatusDeadlineExceeded
|
|
||
|
|
lastResult == Left GRPCIOTimeout
|
|
server s = do
|
|
let rm = head (normalMethods s)
|
|
serverHandleNormalCall s rm mempty dummyHandler
|
|
serverHandleNormalCall s rm mempty dummyHandler
|
|
return ()
|
|
|
|
testSlowServer :: TestTree
|
|
testSlowServer =
|
|
csTest "Client handles slow server response" client server (["/foo"],[],[],[])
|
|
where
|
|
client c = do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
result <- clientRequest c rm 1 "" mempty
|
|
result @?= badStatus StatusDeadlineExceeded
|
|
server s = do
|
|
let rm = head (normalMethods s)
|
|
serverHandleNormalCall s rm mempty $ \_ -> do
|
|
threadDelay (2*10^(6 :: Int))
|
|
return dummyResp
|
|
return ()
|
|
|
|
testServerCallExpirationCheck :: TestTree
|
|
testServerCallExpirationCheck =
|
|
csTest "Check for call expiration" client server (["/foo"],[],[],[])
|
|
where
|
|
client c = do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
void $ clientRequest c rm 3 "" mempty
|
|
server s = do
|
|
let rm = head (normalMethods s)
|
|
serverHandleNormalCall s rm mempty $ \c -> do
|
|
exp1 <- serverCallIsExpired c
|
|
assertBool "Call isn't expired when handler starts" $ not exp1
|
|
threadDelaySecs 1
|
|
exp2 <- serverCallIsExpired c
|
|
assertBool "Call isn't expired after 1 second" $ not exp2
|
|
threadDelaySecs 3
|
|
exp3 <- serverCallIsExpired c
|
|
assertBool "Call is expired after 4 seconds" exp3
|
|
return dummyResp
|
|
return ()
|
|
|
|
testCustomUserAgent :: TestTree
|
|
testCustomUserAgent =
|
|
csTest' "Server sees custom user agent prefix/suffix" client server
|
|
where
|
|
clientArgs = [UserAgentPrefix "prefix!", UserAgentSuffix "suffix!"]
|
|
client =
|
|
TestClient (ClientConfig "localhost" 50051 clientArgs) $
|
|
\c -> do rm <- clientRegisterMethodNormal c "/foo"
|
|
void $ clientRequest c rm 4 "" mempty
|
|
server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do
|
|
let rm = head (normalMethods s)
|
|
serverHandleNormalCall s rm mempty $ \c -> do
|
|
ua <- case toList $ (unMap $ metadata c) M.! "user-agent" of
|
|
[] -> fail "user-agent missing from metadata."
|
|
[ua] -> return ua
|
|
_ -> fail "multiple user-agent keys."
|
|
assertBool "User agent prefix is present" $ isPrefixOf "prefix!" ua
|
|
assertBool "User agent suffix is present" $ isSuffixOf "suffix!" ua
|
|
return dummyResp
|
|
return ()
|
|
|
|
testClientCompression :: TestTree
|
|
testClientCompression =
|
|
csTest' "client-only compression: no errors" client server
|
|
where
|
|
client =
|
|
TestClient (ClientConfig
|
|
"localhost"
|
|
50051
|
|
[CompressionAlgArg GrpcCompressDeflate]) $ \c -> do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
void $ clientRequest c rm 1 "hello" mempty
|
|
server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do
|
|
let rm = head (normalMethods s)
|
|
serverHandleNormalCall s rm mempty $ \c -> do
|
|
payload c @?= "hello"
|
|
return dummyResp
|
|
return ()
|
|
|
|
testClientServerCompression :: TestTree
|
|
testClientServerCompression =
|
|
csTest' "client/server compression: no errors" client server
|
|
where
|
|
cconf = ClientConfig "localhost"
|
|
50051
|
|
[CompressionAlgArg GrpcCompressDeflate]
|
|
client = TestClient cconf $ \c -> do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
clientRequest c rm 1 "hello" mempty >>= do
|
|
checkReqRslt $ \NormalRequestResult{..} -> do
|
|
rspCode @?= StatusOk
|
|
rspBody @?= "hello"
|
|
details @?= ""
|
|
initMD @?= dummyMeta
|
|
trailMD @?= dummyMeta
|
|
return ()
|
|
sconf = ServerConfig "localhost"
|
|
50051
|
|
["/foo"] [] [] []
|
|
[CompressionAlgArg GrpcCompressDeflate]
|
|
server = TestServer sconf $ \s -> do
|
|
let rm = head (normalMethods s)
|
|
serverHandleNormalCall s rm dummyMeta $ \sc -> do
|
|
payload sc @?= "hello"
|
|
return ("hello", dummyMeta, StatusOk, StatusDetails "")
|
|
return ()
|
|
|
|
testClientServerCompressionLvl :: TestTree
|
|
testClientServerCompressionLvl =
|
|
csTest' "client/server compression: no errors" client server
|
|
where
|
|
cconf = ClientConfig "localhost"
|
|
50051
|
|
[CompressionLevelArg GrpcCompressLevelHigh]
|
|
client = TestClient cconf $ \c -> do
|
|
rm <- clientRegisterMethodNormal c "/foo"
|
|
clientRequest c rm 1 "hello" mempty >>= do
|
|
checkReqRslt $ \NormalRequestResult{..} -> do
|
|
rspCode @?= StatusOk
|
|
rspBody @?= "hello"
|
|
details @?= ""
|
|
initMD @?= dummyMeta
|
|
trailMD @?= dummyMeta
|
|
return ()
|
|
sconf = ServerConfig "localhost"
|
|
50051
|
|
["/foo"] [] [] []
|
|
[CompressionLevelArg GrpcCompressLevelLow]
|
|
server = TestServer sconf $ \s -> do
|
|
let rm = head (normalMethods s)
|
|
serverHandleNormalCall s rm dummyMeta $ \sc -> do
|
|
payload sc @?= "hello"
|
|
return ("hello", dummyMeta, StatusOk, StatusDetails "")
|
|
return ()
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Utilities and helpers
|
|
|
|
is :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()
|
|
is act x = act >>= liftIO . (@?= x)
|
|
|
|
dummyMeta :: MetadataMap
|
|
dummyMeta = [("foo","bar")]
|
|
|
|
dummyResp :: (ByteString, MetadataMap, StatusCode, StatusDetails)
|
|
dummyResp = ("", mempty, StatusOk, StatusDetails "")
|
|
|
|
dummyHandler :: ServerCall a
|
|
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
|
|
dummyHandler _ = return dummyResp
|
|
|
|
dummyResult' :: StatusDetails
|
|
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
|
|
dummyResult' = return . (mempty, mempty, StatusOk, )
|
|
|
|
badStatus :: StatusCode -> Either GRPCIOError a
|
|
badStatus st = Left . GRPCIOBadStatusCode st $ case st of
|
|
StatusDeadlineExceeded -> "Deadline Exceeded"
|
|
StatusCancelled -> "Received RST_STREAM err=8"
|
|
_ -> mempty
|
|
|
|
nop :: Monad m => a -> m ()
|
|
nop = const (return ())
|
|
|
|
serverOnlyTest :: TestName
|
|
-> ([MethodName],[MethodName],[MethodName],[MethodName])
|
|
-> (Server -> IO ())
|
|
-> TestTree
|
|
serverOnlyTest nm ms =
|
|
testCase ("Server - " ++ nm) . runTestServer . TestServer (serverConf ms)
|
|
|
|
clientOnlyTest :: TestName -> (Client -> IO ()) -> TestTree
|
|
clientOnlyTest nm =
|
|
testCase ("Client - " ++ nm) . runTestClient . stdTestClient
|
|
|
|
csTest :: TestName
|
|
-> (Client -> IO ())
|
|
-> (Server -> IO ())
|
|
-> ([MethodName],[MethodName],[MethodName],[MethodName])
|
|
-> TestTree
|
|
csTest nm c s ms =
|
|
csTest' nm (stdTestClient c) (TestServer (serverConf ms) s)
|
|
|
|
csTest' :: TestName -> TestClient -> TestServer -> TestTree
|
|
csTest' nm tc ts =
|
|
testCase ("Client/Server - " ++ nm)
|
|
$ void (s `concurrently` c)
|
|
where
|
|
-- We use a small delay to give the server a head start
|
|
c = threadDelay 100000 >> runTestClient tc
|
|
s = runTestServer ts
|
|
|
|
-- | @checkMD msg expected actual@ fails when keys from @expected@ are not in
|
|
-- @actual@, or when values differ for matching keys.
|
|
checkMD :: String -> MetadataMap -> MetadataMap -> Assertion
|
|
checkMD desc expected actual =
|
|
assertEqual desc expected' (actual' `S.intersection` expected')
|
|
where
|
|
expected' = fromList . toList $ expected
|
|
actual' = fromList . toList $ actual
|
|
|
|
checkReqRslt :: Show a => (b -> Assertion) -> Either a b -> Assertion
|
|
checkReqRslt = either clientFail
|
|
|
|
-- | The consumer which asserts that the next value it consumes is equal to the
|
|
-- given value; string parameter used as in 'assertEqual'.
|
|
assertConsumeEq :: (Eq a, Show a) => String -> a -> P.Consumer a IO ()
|
|
assertConsumeEq s v = P.lift . assertEqual s v =<< P.await
|
|
|
|
clientFail :: Show a => a -> Assertion
|
|
clientFail = assertFailure . ("Client error: " ++). show
|
|
|
|
data TestClient = TestClient ClientConfig (Client -> IO ())
|
|
|
|
runTestClient :: TestClient -> IO ()
|
|
runTestClient (TestClient conf f) =
|
|
runManaged $ mgdGRPC >>= mgdClient conf >>= liftIO . f
|
|
|
|
stdTestClient :: (Client -> IO ()) -> TestClient
|
|
stdTestClient = TestClient stdClientConf
|
|
|
|
stdClientConf :: ClientConfig
|
|
stdClientConf = ClientConfig "localhost" 50051 []
|
|
|
|
data TestServer = TestServer ServerConfig (Server -> IO ())
|
|
|
|
runTestServer :: TestServer -> IO ()
|
|
runTestServer (TestServer conf f) =
|
|
runManaged $ mgdGRPC >>= mgdServer conf >>= liftIO . f
|
|
|
|
defServerConf :: ServerConfig
|
|
defServerConf = ServerConfig "localhost" 50051 [] [] [] [] []
|
|
|
|
serverConf :: ([MethodName],[MethodName],[MethodName],[MethodName])
|
|
-> ServerConfig
|
|
serverConf (ns, cs, ss, bs) =
|
|
defServerConf {methodsToRegisterNormal = ns,
|
|
methodsToRegisterClientStreaming = cs,
|
|
methodsToRegisterServerStreaming = ss,
|
|
methodsToRegisterBiDiStreaming = bs}
|
|
|
|
mgdGRPC :: Managed GRPC
|
|
mgdGRPC = managed withGRPC
|
|
|
|
mgdClient :: ClientConfig -> GRPC -> Managed Client
|
|
mgdClient conf g = managed $ withClient g conf
|
|
|
|
mgdServer :: ServerConfig -> GRPC -> Managed Server
|
|
mgdServer conf g = managed $ withServer g conf
|