{-# 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
]