mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-11-15 15:49:42 +01:00
103 lines
3.1 KiB
Haskell
103 lines
3.1 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module LowLevelTests.Op where
|
|
|
|
import Control.Concurrent
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import Data.ByteString (ByteString)
|
|
import Network.GRPC.LowLevel
|
|
import Network.GRPC.LowLevel.Call
|
|
import Network.GRPC.LowLevel.Client
|
|
import Network.GRPC.LowLevel.Op
|
|
import Network.GRPC.LowLevel.Server
|
|
import Test.Tasty
|
|
import Test.Tasty.HUnit as HU (testCase, (@?=))
|
|
|
|
lowLevelOpTests :: TestTree
|
|
lowLevelOpTests =
|
|
testGroup
|
|
"Synchronous unit tests of low-level Op interface"
|
|
[testCancelFromServer]
|
|
|
|
testCancelFromServer :: TestTree
|
|
testCancelFromServer =
|
|
testCase "Client/Server - client receives server cancellation" $
|
|
runSerialTest $ \grpc ->
|
|
withClientServerUnaryCall grpc $
|
|
\(Client {..}, Server {..}, ClientCall {..}, sc@ServerCall {..}) -> do
|
|
serverCallCancel sc StatusPermissionDenied "TestStatus"
|
|
clientRes <- runOps unsafeCC clientCQ clientRecvOps
|
|
case clientRes of
|
|
Left x -> error $ "Client recv error: " ++ show x
|
|
Right [_, _, OpRecvStatusOnClientResult _ code _details] -> do
|
|
code @?= StatusPermissionDenied
|
|
return $ Right ()
|
|
wrong -> error $ "Unexpected op results: " ++ show wrong
|
|
|
|
runSerialTest :: (GRPC -> IO (Either GRPCIOError ())) -> IO ()
|
|
runSerialTest f =
|
|
withGRPC f >>= \case
|
|
Left x -> error $ show x
|
|
Right () -> return ()
|
|
|
|
withClientServerUnaryCall ::
|
|
GRPC ->
|
|
( ( Client,
|
|
Server,
|
|
ClientCall,
|
|
ServerCall ByteString
|
|
) ->
|
|
IO (Either GRPCIOError a)
|
|
) ->
|
|
IO (Either GRPCIOError a)
|
|
withClientServerUnaryCall grpc f = do
|
|
withClient grpc clientConf $ \c -> do
|
|
crm <- clientRegisterMethodNormal c "/foo"
|
|
withServer grpc serverConf $ \s -> do
|
|
ccVar <- newEmptyMVar
|
|
bracket newEmptyMVar (\v -> putMVar v ()) $ \finished -> do
|
|
_ <- forkIO $
|
|
void $
|
|
withClientCall c crm 10 $ \cc -> do
|
|
putMVar ccVar cc
|
|
-- NOTE: We need to send client ops here or else `withServerCall` hangs,
|
|
-- because registered methods try to do recv ops immediately when
|
|
-- created. If later we want to send payloads or metadata, we'll need
|
|
-- to tweak this.
|
|
_clientRes <- runOps (unsafeCC cc) (clientCQ c) clientEmptySendOps
|
|
takeMVar finished
|
|
pure (Right ())
|
|
let srm = head (normalMethods s)
|
|
cc <- takeMVar ccVar
|
|
withServerCall s srm $ \sc ->
|
|
f (c, s, cc, sc)
|
|
|
|
serverConf :: ServerConfig
|
|
serverConf = ServerConfig "localhost" 50051 [("/foo")] [] [] [] [] Nothing
|
|
|
|
clientConf :: ClientConfig
|
|
clientConf = ClientConfig "localhost" 50051 [] Nothing Nothing
|
|
|
|
clientEmptySendOps :: [Op]
|
|
clientEmptySendOps =
|
|
[ OpSendInitialMetadata mempty,
|
|
OpSendMessage "",
|
|
OpSendCloseFromClient
|
|
]
|
|
|
|
clientRecvOps :: [Op]
|
|
clientRecvOps =
|
|
[ OpRecvInitialMetadata,
|
|
OpRecvMessage,
|
|
OpRecvStatusOnClient
|
|
]
|
|
|
|
serverEmptyRecvOps :: [Op]
|
|
serverEmptyRecvOps =
|
|
[ OpSendInitialMetadata mempty,
|
|
OpRecvMessage,
|
|
OpRecvCloseOnServer
|
|
]
|