mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-06-29 07:58:35 +02:00
315 lines
13 KiB
Haskell
315 lines
13 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module LowLevelTests (lowLevelTests) where
|
|
|
|
import Control.Concurrent.Async
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.Map as M
|
|
import Foreign.Marshal.Alloc
|
|
import Foreign.Ptr
|
|
import Foreign.Storable
|
|
import Network.GRPC.LowLevel
|
|
import Network.GRPC.Unsafe
|
|
import Network.GRPC.Unsafe.ByteBuffer
|
|
import Network.GRPC.Unsafe.Constants
|
|
import Network.GRPC.Unsafe.Metadata
|
|
import Network.GRPC.Unsafe.Op
|
|
import Network.GRPC.Unsafe.Time
|
|
import Test.Tasty
|
|
import Test.Tasty.HUnit as HU (testCase, (@?=))
|
|
|
|
lowLevelTests :: TestTree
|
|
lowLevelTests = testGroup "Unit tests of low-level Haskell library"
|
|
[ testGRPCBracket
|
|
, testCompletionQueueCreateDestroy
|
|
, testServerCreateDestroy
|
|
, testClientCreateDestroy
|
|
, testWithServerCall
|
|
, testWithClientCall
|
|
, testPayloadLowLevel
|
|
, testClientRequestNoServer
|
|
, testServerAwaitNoClient
|
|
, testPayloadLowLevelUnregistered
|
|
, testUnsafePayload
|
|
]
|
|
|
|
testGRPCBracket :: TestTree
|
|
testGRPCBracket = grpcTest "Start/stop GRPC" nop
|
|
|
|
testCompletionQueueCreateDestroy :: TestTree
|
|
testCompletionQueueCreateDestroy =
|
|
grpcTest "Create/destroy completion queue" $ \grpc -> do
|
|
withCompletionQueue grpc nop
|
|
|
|
testServerCreateDestroy :: TestTree
|
|
testServerCreateDestroy =
|
|
grpcTest "Server - start/stop" $ \grpc -> do
|
|
withServer grpc (ServerConfig "localhost" 50051 []) nop
|
|
|
|
testClientCreateDestroy :: TestTree
|
|
testClientCreateDestroy =
|
|
grpcTest "Client - start/stop" $ \grpc -> do
|
|
withClient grpc (ClientConfig "localhost" 50051) nop
|
|
|
|
payloadLowLevelServer :: TestServer
|
|
payloadLowLevelServer = TestServer $ \grpc -> do
|
|
let conf = (ServerConfig "localhost" 50051 [("/foo", "localhost", Normal)])
|
|
withServer grpc conf $ \server -> do
|
|
let method = head (registeredMethods server)
|
|
result <- serverHandleNormalRegisteredCall server method 11 M.empty $
|
|
\reqBody reqMeta ->
|
|
return ("reply test", dummyMeta, dummyMeta,
|
|
StatusDetails "details string")
|
|
case result of
|
|
Left err -> error $ show err
|
|
Right _ -> return ()
|
|
|
|
payloadLowLevelClient :: TestClient
|
|
payloadLowLevelClient = TestClient $ \grpc ->
|
|
withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
|
|
method <- clientRegisterMethod client "/foo" "localhost" Normal
|
|
putStrLn "registered method on client."
|
|
reqResult <- clientRegisteredRequest client method 10 "Hello!" M.empty
|
|
case reqResult of
|
|
Left x -> error $ "Client got error: " ++ show x
|
|
Right (NormalRequestResult respBody initMeta trailingMeta respCode details) -> do
|
|
details @?= "details string"
|
|
respBody @?= "reply test"
|
|
respCode @?= GrpcStatusOk
|
|
|
|
payloadLowLevelClientUnregistered :: TestClient
|
|
payloadLowLevelClientUnregistered = TestClient $ \grpc -> do
|
|
withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
|
|
reqResult <- clientRequest client "/foo" "localhost" 10 "Hello!" M.empty
|
|
case reqResult of
|
|
Left x -> error $ "Client got error: " ++ show x
|
|
Right (NormalRequestResult
|
|
respBody initMeta trailingMeta respCode details) -> do
|
|
respBody @?= "reply test"
|
|
respCode @?= GrpcStatusOk
|
|
details @?= "details string"
|
|
|
|
payloadLowLevelServerUnregistered :: TestServer
|
|
payloadLowLevelServerUnregistered = TestServer $ \grpc -> do
|
|
withServer grpc (ServerConfig "localhost" 50051 []) $ \server -> do
|
|
result <- serverHandleNormalCall server 11 M.empty $
|
|
\reqBody reqMeta -> return ("reply test", M.empty,
|
|
StatusDetails "details string")
|
|
case result of
|
|
Left x -> error $ show x
|
|
Right _ -> return ()
|
|
|
|
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
|
|
reqResult <- clientRegisteredRequest client method 1 "Hello" M.empty
|
|
reqResult @?= (Left GRPCIOTimeout)
|
|
|
|
testServerAwaitNoClient :: TestTree
|
|
testServerAwaitNoClient =
|
|
grpcTest "Server - registered call handler timeout" $ \grpc -> do
|
|
let conf = (ServerConfig "localhost" 50051 [("/foo", "localhost", Normal)])
|
|
withServer grpc conf $ \server -> do
|
|
let method = head (registeredMethods server)
|
|
result <- serverHandleNormalRegisteredCall server method 1 M.empty $
|
|
\_ _ -> return ("", M.empty, M.empty, StatusDetails "details")
|
|
result @?= Left GRPCIOTimeout
|
|
|
|
testServerUnregisteredAwaitNoClient :: TestTree
|
|
testServerUnregisteredAwaitNoClient =
|
|
grpcTest "Server - unregistered call handler timeout" $ \grpc -> do
|
|
let conf = ServerConfig "localhost" 50051 []
|
|
withServer grpc conf $ \server -> do
|
|
result <- serverHandleNormalCall server 10 M.empty $
|
|
\_ _ -> return ("", M.empty, StatusDetails "")
|
|
case result of
|
|
Left err -> error $ show err
|
|
Right _ -> return ()
|
|
|
|
testPayloadLowLevel :: TestTree
|
|
testPayloadLowLevel =
|
|
grpcTest "Client/Server - low-level (registered) request/response" $
|
|
runClientServer payloadLowLevelClient payloadLowLevelServer
|
|
|
|
testPayloadLowLevelUnregistered :: TestTree
|
|
testPayloadLowLevelUnregistered =
|
|
grpcTest "Client/Server - low-level unregistered request/response" $
|
|
runClientServer payloadLowLevelClientUnregistered payloadLowLevelServerUnregistered
|
|
|
|
testWithServerCall :: TestTree
|
|
testWithServerCall =
|
|
grpcTest "Server - Create/destroy call" $ \grpc -> do
|
|
let conf = ServerConfig "localhost" 50051 []
|
|
withServer grpc conf $ \server -> do
|
|
result <- withServerCall server 1 $ const $ return $ Right ()
|
|
result @?= Left GRPCIOTimeout
|
|
|
|
testWithClientCall :: TestTree
|
|
testWithClientCall =
|
|
grpcTest "Client - Create/destroy call" $ \grpc -> do
|
|
let conf = ClientConfig "localhost" 50051
|
|
withClient grpc conf $ \client -> do
|
|
result <- withClientCall client "foo" "localhost" 10 $
|
|
const $ return $ Right ()
|
|
case result of
|
|
Left err -> error $ show err
|
|
Right _ -> return ()
|
|
|
|
assertCqEventComplete :: Event -> IO ()
|
|
assertCqEventComplete e = do
|
|
eventCompletionType e HU.@?= OpComplete
|
|
eventSuccess e HU.@?= True
|
|
|
|
unsafePayloadClient :: TestClient
|
|
unsafePayloadClient = TestClient $ \_grpc -> do
|
|
client <- grpcInsecureChannelCreate "localhost:50051" nullPtr reserved
|
|
cq <- grpcCompletionQueueCreate reserved
|
|
withMetadataArrayPtr $ \initialMetadataRecv -> do
|
|
withMetadataArrayPtr $ \trailingMetadataRecv -> do
|
|
withByteBufferPtr $ \clientRecvBB -> do
|
|
deadline <- secondsToDeadline 5
|
|
pluckDeadline <- secondsToDeadline 10
|
|
clientCall <- grpcChannelCreateCall
|
|
client (Call nullPtr) propagateDefaults cq
|
|
"/foo" "localhost" deadline reserved
|
|
--send request
|
|
withOpArray 6 $ \ops -> do
|
|
opSendInitialMetadataEmpty ops 0
|
|
withByteStringAsByteBuffer "hello world" $ \requestPayload -> do
|
|
opSendMessage ops 1 requestPayload
|
|
opSendCloseClient ops 2
|
|
opRecvInitialMetadata ops 3 initialMetadataRecv
|
|
opRecvMessage ops 4 clientRecvBB
|
|
statusCodePtr <- createStatusCodePtr
|
|
let cstringCapacity = 32
|
|
cStringPtr <- malloc
|
|
cstring <- mallocBytes cstringCapacity
|
|
poke cStringPtr cstring
|
|
opRecvStatusClient ops 5 trailingMetadataRecv statusCodePtr
|
|
cStringPtr
|
|
cstringCapacity
|
|
--send client request
|
|
requestError <- grpcCallStartBatch clientCall ops 6 (tag 1) reserved
|
|
clientRequestCqEvent <- grpcCompletionQueuePluck
|
|
cq (tag 1) pluckDeadline reserved
|
|
assertCqEventComplete clientRequestCqEvent
|
|
requestError HU.@?= CallOk
|
|
free cstring
|
|
free cStringPtr
|
|
destroyStatusCodePtr statusCodePtr
|
|
--verify response received
|
|
responseRecv <- peek clientRecvBB
|
|
responseRecvBS <- copyByteBufferToByteString responseRecv
|
|
responseRecvBS HU.@?= "hello you"
|
|
grpcCompletionQueueShutdown cq
|
|
grpcCallDestroy clientCall
|
|
--TODO: the grpc test drains the cq here
|
|
grpcCompletionQueueDestroy cq
|
|
grpcChannelDestroy client
|
|
|
|
unsafePayloadServer :: TestServer
|
|
unsafePayloadServer = TestServer $ \_grpc -> do
|
|
server <- grpcServerCreate nullPtr reserved
|
|
cq <- grpcCompletionQueueCreate reserved
|
|
grpcServerRegisterCompletionQueue server cq reserved
|
|
_ <- grpcServerAddInsecureHttp2Port server "localhost:50051"
|
|
grpcServerStart server
|
|
serverCallPtr <- malloc
|
|
withMetadataArrayPtr $ \requestMetadataRecv -> do
|
|
withByteBufferPtr $ \recvBufferPtr -> do
|
|
callDetails <- createCallDetails
|
|
requestMetadataRecv' <- peek requestMetadataRecv
|
|
recvRequestError <- grpcServerRequestCall
|
|
server serverCallPtr callDetails
|
|
requestMetadataRecv' cq cq (tag 101)
|
|
pluckDeadline' <- secondsToDeadline 10
|
|
requestCallCqEvent <- grpcCompletionQueuePluck cq (tag 101)
|
|
pluckDeadline'
|
|
reserved
|
|
assertCqEventComplete requestCallCqEvent
|
|
recvRequestError HU.@?= CallOk
|
|
destroyCallDetails callDetails
|
|
--receive request
|
|
withOpArray 2 $ \recvOps -> do
|
|
opSendInitialMetadataEmpty recvOps 0
|
|
opRecvMessage recvOps 1 recvBufferPtr
|
|
serverCall <- peek serverCallPtr
|
|
recvBatchError <- grpcCallStartBatch serverCall recvOps 2
|
|
(tag 102) reserved
|
|
recvBatchError HU.@?= CallOk
|
|
pluckDeadline'' <- secondsToDeadline 10
|
|
recvCqEvent <- grpcCompletionQueuePluck cq (tag 102)
|
|
pluckDeadline''
|
|
reserved
|
|
assertCqEventComplete recvCqEvent
|
|
--send response
|
|
withOpArray 3 $ \respOps -> do
|
|
withByteStringAsByteBuffer "hello you" $ \respbb -> do
|
|
cancelledPtr <- malloc
|
|
opRecvCloseServer respOps 0 cancelledPtr
|
|
opSendMessage respOps 1 respbb
|
|
B.useAsCString "ok" $ \detailsStr ->
|
|
opSendStatusServer respOps 2 0 (MetadataKeyValPtr nullPtr)
|
|
GrpcStatusOk detailsStr
|
|
serverCall <- peek serverCallPtr
|
|
respBatchError <- grpcCallStartBatch serverCall respOps 3
|
|
(tag 103) reserved
|
|
respBatchError HU.@?= CallOk
|
|
pluckDeadline''' <- secondsToDeadline 10
|
|
respCqEvent <- grpcCompletionQueuePluck cq (tag 103)
|
|
pluckDeadline'''
|
|
reserved
|
|
assertCqEventComplete respCqEvent
|
|
--verify data was received
|
|
serverRecv <- peek recvBufferPtr
|
|
serverRecvBS <- copyByteBufferToByteString serverRecv
|
|
serverRecvBS HU.@?= "hello world"
|
|
--shut down
|
|
grpcServerShutdownAndNotify server cq (tag 0)
|
|
pluckDeadline'''' <- secondsToDeadline 10
|
|
shutdownEvent <- grpcCompletionQueuePluck cq (tag 0) pluckDeadline''''
|
|
reserved
|
|
assertCqEventComplete shutdownEvent
|
|
grpcServerCancelAllCalls server
|
|
grpcServerDestroy server
|
|
grpcCompletionQueueShutdown cq
|
|
grpcCompletionQueueDestroy cq
|
|
free serverCallPtr
|
|
|
|
-- | Straightforward translation of the gRPC core test end2end/tests/payload.c
|
|
-- This is intended to test the low-level C bindings, so we use only a few
|
|
-- minimal abstractions on top of it.
|
|
testUnsafePayload :: TestTree
|
|
testUnsafePayload =
|
|
grpcTest "Client/Server - Unsafe request/response" $
|
|
runClientServer unsafePayloadClient unsafePayloadServer
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Utilities and helpers
|
|
|
|
dummyMeta :: M.Map ByteString ByteString
|
|
dummyMeta = M.fromList [("foo","bar")]
|
|
|
|
nop :: Monad m => a -> m ()
|
|
nop = const (return ())
|
|
|
|
-- | Defines a general-purpose GRPC unit test
|
|
grpcTest :: TestName -> (GRPC -> IO ()) -> TestTree
|
|
grpcTest nm = testCase nm . withGRPC
|
|
|
|
newtype TestClient = TestClient (GRPC -> IO ())
|
|
newtype TestServer = TestServer (GRPC -> IO ())
|
|
|
|
-- | Asyncs the given 'TestClient' and 'TestServer' and waits for both to
|
|
-- terminate. TODO: We'll probably want to add toplevel timeouts and better
|
|
-- error reporting.
|
|
runClientServer :: TestClient -> TestServer -> GRPC -> IO ()
|
|
runClientServer (TestClient c) (TestServer s) grpc = do
|
|
withAsync (s grpc) $ \a1 -> do
|
|
withAsync (c grpc) $ \a2 -> do
|
|
wait a1
|
|
wait a2
|