From 37463839765d0d5b431758eb33b23f8f95a4f3b1 Mon Sep 17 00:00:00 2001 From: Connor Clark Date: Wed, 25 May 2016 13:11:30 -0700 Subject: [PATCH] Fix payload test bugs (#8) * fix memory mgmt bug in status details strings * remove flags * allow server to specify status details --- cbits/grpc_haskell.c | 10 ++- src/Network/GRPC/LowLevel.hs | 1 + src/Network/GRPC/LowLevel/Client.hs | 13 +++- src/Network/GRPC/LowLevel/CompletionQueue.hs | 8 ++- src/Network/GRPC/LowLevel/Op.hs | 65 +++++++++++++------- src/Network/GRPC/LowLevel/Server.hs | 26 +++++--- src/Network/GRPC/Unsafe.chs | 12 ++-- src/Network/GRPC/Unsafe/ByteBuffer.chs | 4 ++ src/Network/GRPC/Unsafe/Metadata.chs | 6 ++ src/Network/GRPC/Unsafe/Op.chs | 6 +- tests/LowLevelTests.hs | 24 +++++--- tests/Properties.hs | 5 +- 12 files changed, 128 insertions(+), 52 deletions(-) diff --git a/cbits/grpc_haskell.c b/cbits/grpc_haskell.c index 320da31..cd3d53e 100644 --- a/cbits/grpc_haskell.c +++ b/cbits/grpc_haskell.c @@ -131,6 +131,10 @@ grpc_metadata_array** metadata_array_create(){ grpc_metadata_array **retval = malloc(sizeof(grpc_metadata_array*)); *retval = malloc(sizeof(grpc_metadata_array)); grpc_metadata_array_init(*retval); + #ifdef GRPC_HASKELL_DEBUG + printf("C wrapper: metadata_array_create debug: %p %p %p\n", retval, *retval, + (*retval)->metadata); + #endif return retval; } @@ -299,7 +303,11 @@ void op_send_status_server(grpc_op *op_array, size_t i, } grpc_status_code* create_status_code_ptr(){ - return malloc(sizeof(grpc_status_code)); + grpc_status_code* retval = malloc(sizeof(grpc_status_code)); + #ifdef GRPC_HASKELL_DEBUG + printf("C wrapper: create_status_code_ptr debug: %p\n", retval); + #endif + return retval; } grpc_status_code deref_status_code_ptr(grpc_status_code* p){ diff --git a/src/Network/GRPC/LowLevel.hs b/src/Network/GRPC/LowLevel.hs index ae348a5..5b94400 100644 --- a/src/Network/GRPC/LowLevel.hs +++ b/src/Network/GRPC/LowLevel.hs @@ -47,6 +47,7 @@ GRPC , runOps , Op(..) , OpRecvResult(..) +, StatusDetails(..) ) where diff --git a/src/Network/GRPC/LowLevel/Client.hs b/src/Network/GRPC/LowLevel/Client.hs index eea43c1..efb96ef 100644 --- a/src/Network/GRPC/LowLevel/Client.hs +++ b/src/Network/GRPC/LowLevel/Client.hs @@ -114,9 +114,10 @@ withClientCall client method host timeout f = do data NormalRequestResult = NormalRequestResult ByteString - MetadataMap --init metadata + (Maybe MetadataMap) --init metadata MetadataMap --trailing metadata C.StatusCode + StatusDetails deriving (Show, Eq) -- | Function for assembling call result when the 'MethodType' is 'Normal'. @@ -128,8 +129,14 @@ compileNormalRequestResults -- core use cases easy. [OpRecvInitialMetadataResult m, OpRecvMessageResult body, - OpRecvStatusOnClientResult m2 status] - = NormalRequestResult body m m2 status + OpRecvStatusOnClientResult m2 status details] + = NormalRequestResult body (Just m) m2 status (StatusDetails details) + -- TODO: it seems registered request responses on the server + -- don't send initial metadata. Hence the 'Maybe'. Investigate. +compileNormalRequestResults + [OpRecvMessageResult body, + OpRecvStatusOnClientResult m2 status details] + = NormalRequestResult body Nothing m2 status (StatusDetails details) compileNormalRequestResults _ = --TODO: impossible case should be enforced by more precise types. error "non-normal request input to compileNormalRequestResults." diff --git a/src/Network/GRPC/LowLevel/CompletionQueue.hs b/src/Network/GRPC/LowLevel/CompletionQueue.hs index e8d4b3a..b7af4c4 100644 --- a/src/Network/GRPC/LowLevel/CompletionQueue.hs +++ b/src/Network/GRPC/LowLevel/CompletionQueue.hs @@ -30,6 +30,7 @@ import Control.Concurrent.STM.TVar (TVar, newTVarIO, modifyTVar', readTVar, writeTVar) import Control.Exception (bracket) import Data.IORef (IORef, newIORef, atomicModifyIORef') +import Data.List (intersperse) import Foreign.Marshal.Alloc (malloc, free) import Foreign.Ptr (nullPtr, plusPtr) import Foreign.Storable (peek) @@ -188,7 +189,8 @@ startBatch :: CompletionQueue -> C.Call -> C.OpArray -> Int -> C.Tag -> IO (Either GRPCIOError ()) startBatch cq@CompletionQueue{..} call opArray opArraySize tag = withPermission Push cq $ fmap throwIfCallError $ do - grpcDebug "startBatch: calling grpc_call_start_batch." + grpcDebug $ "startBatch: calling grpc_call_start_batch with pointers: " + ++ show call ++ " " ++ show opArray res <- C.grpcCallStartBatch call opArray opArraySize tag C.reserved grpcDebug "startBatch: grpc_call_start_batch call returned." return res @@ -230,6 +232,10 @@ channelCreateRegisteredCall :: C.Channel -> C.Call -> C.PropagationMask channelCreateRegisteredCall chan parent mask cq@CompletionQueue{..} handle deadline = withPermission Push cq $ do + grpcDebug $ "channelCreateRegisteredCall: call with " + ++ concat (intersperse " " [show chan, show parent, show mask, + show unsafeCQ, show handle, + show deadline]) call <- C.grpcChannelCreateRegisteredCall chan parent mask unsafeCQ handle deadline C.reserved return $ Right $ ClientCall call diff --git a/src/Network/GRPC/LowLevel/Op.hs b/src/Network/GRPC/LowLevel/Op.hs index 4f788bc..7a82e08 100644 --- a/src/Network/GRPC/LowLevel/Op.hs +++ b/src/Network/GRPC/LowLevel/Op.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Network.GRPC.LowLevel.Op where @@ -6,10 +7,12 @@ import Control.Exception import qualified Data.ByteString as B import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) +import Data.String (IsString) +import Foreign.C.String (CString) import Foreign.C.Types (CInt) -import Foreign.Marshal.Alloc (malloc, free) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) +import Foreign.Marshal.Alloc (malloc, mallocBytes, free) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peek, poke) import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe.Metadata as C import qualified Network.GRPC.Unsafe.ByteBuffer as C @@ -21,13 +24,15 @@ import Network.GRPC.LowLevel.Call type MetadataMap = M.Map B.ByteString B.ByteString +newtype StatusDetails = StatusDetails B.ByteString deriving (Show, Eq, IsString) + -- | Sum describing all possible send and receive operations that can be batched -- and executed by gRPC. Usually these are processed in a handful of -- combinations depending on the 'MethodType' of the call being run. data Op = OpSendInitialMetadata MetadataMap | OpSendMessage B.ByteString | OpSendCloseFromClient - | OpSendStatusFromServer MetadataMap C.StatusCode --TODO: Issue #6 + | OpSendStatusFromServer MetadataMap C.StatusCode StatusDetails | OpRecvInitialMetadata | OpRecvMessage | OpRecvStatusOnClient @@ -42,10 +47,19 @@ data OpContext = | OpSendMessageContext C.ByteBuffer | OpSendCloseFromClientContext | OpSendStatusFromServerContext C.MetadataKeyValPtr Int C.StatusCode + B.ByteString | OpRecvInitialMetadataContext (Ptr C.MetadataArray) | OpRecvMessageContext (Ptr C.ByteBuffer) | OpRecvStatusOnClientContext (Ptr C.MetadataArray) (Ptr C.StatusCode) + (Ptr CString) | OpRecvCloseOnServerContext (Ptr CInt) + deriving Show + +-- | Length we pass to gRPC for receiving status details +-- when processing 'OpRecvStatusOnClient'. It appears that gRPC actually ignores +-- this length and reallocates a longer string if necessary. +defaultStatusStringLen :: Int +defaultStatusStringLen = 128 -- | Allocates and initializes the 'Opcontext' corresponding to the given 'Op'. createOpContext :: Op -> IO OpContext @@ -56,19 +70,23 @@ createOpContext (OpSendInitialMetadata m) = createOpContext (OpSendMessage bs) = fmap OpSendMessageContext (C.createByteBuffer bs) createOpContext (OpSendCloseFromClient) = return OpSendCloseFromClientContext -createOpContext (OpSendStatusFromServer m code) = +createOpContext (OpSendStatusFromServer m code (StatusDetails str)) = OpSendStatusFromServerContext <$> C.createMetadata m <*> return (M.size m) <*> return code + <*> return str createOpContext OpRecvInitialMetadata = fmap OpRecvInitialMetadataContext C.metadataArrayCreate createOpContext OpRecvMessage = fmap OpRecvMessageContext C.createReceivingByteBuffer -createOpContext OpRecvStatusOnClient = - OpRecvStatusOnClientContext - <$> C.metadataArrayCreate - <*> C.createStatusCodePtr +createOpContext OpRecvStatusOnClient = do + pmetadata <- C.metadataArrayCreate + pstatus <- C.createStatusCodePtr + pstr <- malloc + cstring <- mallocBytes defaultStatusStringLen + poke pstr cstring + return $ OpRecvStatusOnClientContext pmetadata pstatus pstr createOpContext OpRecvCloseOnServer = fmap OpRecvCloseOnServerContext $ malloc @@ -81,15 +99,15 @@ setOpArray arr i (OpSendMessageContext bb) = C.opSendMessage arr i bb setOpArray arr i OpSendCloseFromClientContext = C.opSendCloseClient arr i -setOpArray arr i (OpSendStatusFromServerContext kvs l code) = - C.opSendStatusServer arr i l kvs code "" --TODO: Issue #6 +setOpArray arr i (OpSendStatusFromServerContext kvs l code details) = + B.useAsCString details $ \cstr -> + C.opSendStatusServer arr i l kvs code cstr setOpArray arr i (OpRecvInitialMetadataContext pmetadata) = C.opRecvInitialMetadata arr i pmetadata setOpArray arr i (OpRecvMessageContext pbb) = C.opRecvMessage arr i pbb -setOpArray arr i (OpRecvStatusOnClientContext pmetadata pstatus) = do - pCString <- malloc --TODO: Issue #6 - C.opRecvStatusClient arr i pmetadata pstatus pCString 0 +setOpArray arr i (OpRecvStatusOnClientContext pmetadata pstatus pstr) = do + C.opRecvStatusClient arr i pmetadata pstatus pstr defaultStatusStringLen setOpArray arr i (OpRecvCloseOnServerContext pcancelled) = do C.opRecvCloseServer arr i pcancelled @@ -98,15 +116,18 @@ freeOpContext :: OpContext -> IO () freeOpContext (OpSendInitialMetadataContext m _) = C.metadataFree m freeOpContext (OpSendMessageContext bb) = C.grpcByteBufferDestroy bb freeOpContext OpSendCloseFromClientContext = return () -freeOpContext (OpSendStatusFromServerContext metadata _ _) = +freeOpContext (OpSendStatusFromServerContext metadata _ _ _) = C.metadataFree metadata freeOpContext (OpRecvInitialMetadataContext metadata) = C.metadataArrayDestroy metadata freeOpContext (OpRecvMessageContext pbb) = C.destroyReceivingByteBuffer pbb -freeOpContext (OpRecvStatusOnClientContext metadata pcode) = +freeOpContext (OpRecvStatusOnClientContext metadata pcode pstr) = do C.metadataArrayDestroy metadata - >> C.destroyStatusCodePtr pcode + C.destroyStatusCodePtr pcode + str <- peek pstr + free str + free pstr freeOpContext (OpRecvCloseOnServerContext pcancelled) = grpcDebug ("freeOpContext: freeing pcancelled: " ++ show pcancelled) >> free pcancelled @@ -125,7 +146,7 @@ withOpArray n = bracket (C.opArrayCreate n) data OpRecvResult = OpRecvInitialMetadataResult MetadataMap | OpRecvMessageResult B.ByteString - | OpRecvStatusOnClientResult MetadataMap C.StatusCode + | OpRecvStatusOnClientResult MetadataMap C.StatusCode B.ByteString | OpRecvCloseOnServerResult Bool -- ^ True if call was cancelled. deriving (Eq, Show) @@ -145,12 +166,14 @@ resultFromOpContext (OpRecvMessageContext pbb) = do bs <- C.copyByteBufferToByteString bb grpcDebug "resultFromOpContext: bb copied." return $ Just $ OpRecvMessageResult bs -resultFromOpContext (OpRecvStatusOnClientContext pmetadata pcode) = do +resultFromOpContext (OpRecvStatusOnClientContext pmetadata pcode pstr) = do grpcDebug "resultFromOpContext: OpRecvStatusOnClientContext" metadata <- peek pmetadata metadataMap <- C.getAllMetadataArray metadata code <- C.derefStatusCodePtr pcode - return $ Just $ OpRecvStatusOnClientResult metadataMap code + cstr <- peek pstr + statusInfo <- B.packCString cstr + return $ Just $ OpRecvStatusOnClientResult metadataMap code statusInfo resultFromOpContext (OpRecvCloseOnServerContext pcancelled) = do grpcDebug "resultFromOpContext: OpRecvCloseOnServerContext" cancelled <- fmap (\x -> if x > 0 then True else False) @@ -185,7 +208,7 @@ runOps call cq ops timeLimit = withOpArray l $ \opArray -> do grpcDebug "runOps: created op array." withOpContexts ops $ \contexts -> do - grpcDebug "runOps: allocated op contexts." + grpcDebug $ "runOps: allocated op contexts: " ++ show contexts sequence_ $ zipWith (setOpArray opArray) [0..l-1] contexts tag <- newTag cq callError <- startBatch cq (internalCall call) opArray l tag diff --git a/src/Network/GRPC/LowLevel/Server.hs b/src/Network/GRPC/LowLevel/Server.hs index 29f974d..d1d95b1 100644 --- a/src/Network/GRPC/LowLevel/Server.hs +++ b/src/Network/GRPC/LowLevel/Server.hs @@ -2,6 +2,7 @@ module Network.GRPC.LowLevel.Server where +import Control.Concurrent (threadDelay) import Control.Exception (bracket, finally) import Control.Monad import Data.ByteString (ByteString) @@ -159,11 +160,12 @@ serverOpsGetNormalCall initMetadata = serverOpsSendNormalResponse :: ByteString -> MetadataMap -> C.StatusCode + -> StatusDetails -> [Op] -serverOpsSendNormalResponse body metadata code = +serverOpsSendNormalResponse body metadata code details = [OpRecvCloseOnServer, OpSendMessage body, - OpSendStatusFromServer metadata code] + OpSendStatusFromServer metadata code details] serverOpsSendNormalRegisteredResponse :: ByteString -> MetadataMap @@ -171,12 +173,14 @@ serverOpsSendNormalRegisteredResponse :: ByteString -> MetadataMap -- ^ trailing metadata -> C.StatusCode + -> StatusDetails -> [Op] -serverOpsSendNormalRegisteredResponse body initMetadata trailingMeta code = +serverOpsSendNormalRegisteredResponse + body initMetadata trailingMeta code details = [OpSendInitialMetadata initMetadata, OpRecvCloseOnServer, OpSendMessage body, - OpSendStatusFromServer trailingMeta code] + OpSendStatusFromServer trailingMeta code details] -- TODO: we will want to replace this with some more general concept that also -- works with streaming calls in the future. @@ -189,7 +193,8 @@ serverHandleNormalRegisteredCall :: Server -> (ByteString -> MetadataMap -> IO (ByteString, MetadataMap, - MetadataMap)) + MetadataMap, + StatusDetails)) -- ^ Handler function takes a request body and -- metadata and returns a response body and -- metadata. @@ -209,10 +214,10 @@ serverHandleNormalRegisteredCall s@Server{..} rm timeLimit initMetadata f = do requestBody <- C.copyByteBufferToByteString payload metadataArray <- peek $ requestMetadataRecv call metadata <- C.getAllMetadataArray metadataArray - (respBody, initMeta, trailingMeta) <- f requestBody metadata + (respBody, initMeta, trailingMeta, details) <- f requestBody metadata let status = C.GrpcStatusOk let respOps = serverOpsSendNormalRegisteredResponse - respBody initMeta trailingMeta status + respBody initMeta trailingMeta status details respOpsResults <- runOps call serverCQ respOps timeLimit grpcDebug "serverHandleNormalRegisteredCall: finished response ops." case respOpsResults of @@ -226,7 +231,7 @@ serverHandleNormalCall :: Server -> TimeoutSeconds -> MetadataMap -- ^ Initial metadata. -> (ByteString -> MetadataMap - -> IO (ByteString, MetadataMap)) + -> IO (ByteString, MetadataMap, StatusDetails)) -- ^ Handler function takes a request body and -- metadata and returns a response body and metadata. -> IO (Either GRPCIOError ()) @@ -239,9 +244,10 @@ serverHandleNormalCall s@Server{..} timeLimit initMetadata f = do Left x -> return $ Left x Right [OpRecvMessageResult body] -> do --TODO: we need to get client metadata - (respBody, respMetadata) <- f body M.empty + (respBody, respMetadata, details) <- f body M.empty let status = C.GrpcStatusOk - let respOps = serverOpsSendNormalResponse respBody respMetadata status + let respOps = serverOpsSendNormalResponse + respBody respMetadata status details respOpsResults <- runOps call serverCQ respOps timeLimit case respOpsResults of Left x -> do grpcDebug "serverHandleNormalCall: resp failed." diff --git a/src/Network/GRPC/Unsafe.chs b/src/Network/GRPC/Unsafe.chs index 185bf92..fa3f9f2 100644 --- a/src/Network/GRPC/Unsafe.chs +++ b/src/Network/GRPC/Unsafe.chs @@ -1,3 +1,5 @@ +{-# LANGUAGE StandaloneDeriving #-} + module Network.GRPC.Unsafe where import Control.Monad @@ -20,9 +22,13 @@ import Network.GRPC.Unsafe.Constants {#pointer *grpc_completion_queue as CompletionQueue newtype #} +deriving instance Show CompletionQueue + -- | Represents a connection to a server. Created on the client side. {#pointer *grpc_channel as Channel newtype #} +deriving instance Show Channel + -- | Represents a server. Created on the server side. {#pointer *grpc_server as Server newtype #} @@ -30,13 +36,11 @@ import Network.GRPC.Unsafe.Constants -- type is abstract; we have no access to its fields. {#pointer *grpc_call as Call newtype #} -instance Show Call where - show (Call ptr) = show ptr +deriving instance Show Call {#pointer *grpc_call_details as CallDetails newtype #} -instance Show CallDetails where - show (CallDetails ptr) = show ptr +deriving instance Show CallDetails {#fun create_call_details as ^ {} -> `CallDetails'#} {#fun destroy_call_details as ^ {`CallDetails'} -> `()'#} diff --git a/src/Network/GRPC/Unsafe/ByteBuffer.chs b/src/Network/GRPC/Unsafe/ByteBuffer.chs index 39d573f..49072a9 100644 --- a/src/Network/GRPC/Unsafe/ByteBuffer.chs +++ b/src/Network/GRPC/Unsafe/ByteBuffer.chs @@ -1,3 +1,5 @@ +{-# LANGUAGE StandaloneDeriving #-} + module Network.GRPC.Unsafe.ByteBuffer where #include @@ -21,6 +23,8 @@ import Foreign.Storable -- Must be destroyed manually with 'grpcByteBufferDestroy'. {#pointer *grpc_byte_buffer as ByteBuffer newtype #} +deriving instance Show ByteBuffer + --Trivial Storable instance because 'ByteBuffer' type is a pointer. instance Storable ByteBuffer where sizeOf (ByteBuffer r) = sizeOf r diff --git a/src/Network/GRPC/Unsafe/Metadata.chs b/src/Network/GRPC/Unsafe/Metadata.chs index da6174d..13264fd 100644 --- a/src/Network/GRPC/Unsafe/Metadata.chs +++ b/src/Network/GRPC/Unsafe/Metadata.chs @@ -1,3 +1,5 @@ +{-# LANGUAGE StandaloneDeriving #-} + module Network.GRPC.Unsafe.Metadata where import Control.Exception @@ -18,6 +20,8 @@ import Foreign.Storable -- is intended to be used when sending metadata. {#pointer *grpc_metadata as MetadataKeyValPtr newtype#} +deriving instance Show MetadataKeyValPtr + -- | Represents a pointer to a grpc_metadata_array. Must be destroyed with -- 'metadataArrayDestroy'. This type is intended for receiving metadata. -- This can be populated by passing it to e.g. 'grpcServerRequestCall'. @@ -25,6 +29,8 @@ import Foreign.Storable -- and length from this type. {#pointer *grpc_metadata_array as MetadataArray newtype#} +deriving instance Show MetadataArray + {#fun metadata_array_get_metadata as ^ {`MetadataArray'} -> `MetadataKeyValPtr'#} diff --git a/src/Network/GRPC/Unsafe/Op.chs b/src/Network/GRPC/Unsafe/Op.chs index 0d7ccf2..7205682 100644 --- a/src/Network/GRPC/Unsafe/Op.chs +++ b/src/Network/GRPC/Unsafe/Op.chs @@ -1,3 +1,5 @@ +{-# LANGUAGE StandaloneDeriving #-} + module Network.GRPC.Unsafe.Op where import Control.Exception @@ -34,6 +36,8 @@ import Foreign.Ptr -- 'opArrayDestroy'. {#pointer *grpc_op as OpArray newtype #} +deriving instance Show OpArray + -- | Creates an empty 'OpArray' with space for the given number of ops. {#fun op_array_create as ^ {`Int'} -> `OpArray'#} @@ -98,5 +102,5 @@ withOpArray n f = bracket (opArrayCreate n) (flip opArrayDestroy n) f -- Metadata and string are copied when creating the op, and can be safely -- destroyed immediately after calling this function. {#fun op_send_status_server as ^ - {`OpArray', `Int', `Int', `MetadataKeyValPtr', `StatusCode', `String'} + {`OpArray', `Int', `Int', `MetadataKeyValPtr', `StatusCode', `CString'} -> `()'#} diff --git a/tests/LowLevelTests.hs b/tests/LowLevelTests.hs index 4a570ba..a8d0f48 100644 --- a/tests/LowLevelTests.hs +++ b/tests/LowLevelTests.hs @@ -17,10 +17,10 @@ lowLevelTests = testGroup "Unit tests of low-level Haskell library" , testClientCreateDestroy , testWithServerCall , testWithClientCall - --, testPayloadLowLevel --TODO: currently crashing from free on unalloced ptr - --, testClientRequestNoServer --TODO: succeeds when no other tests run. + , testPayloadLowLevel + , testClientRequestNoServer , testServerAwaitNoClient - --, testPayloadLowLevelUnregistered --TODO: succeeds when no other tests run. + , testPayloadLowLevelUnregistered ] dummyMeta :: M.Map ByteString ByteString @@ -53,7 +53,9 @@ testPayloadLowLevelServer grpc = do withServer grpc conf $ \server -> do let method = head (registeredMethods server) result <- serverHandleNormalRegisteredCall server method 11 M.empty $ - \reqBody reqMeta -> return ("reply test", dummyMeta, dummyMeta) + \reqBody reqMeta -> + return ("reply test", dummyMeta, dummyMeta, + StatusDetails "details string") case result of Left err -> error $ show err Right _ -> return () @@ -66,7 +68,8 @@ testPayloadLowLevelClient grpc = 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) -> do + Right (NormalRequestResult respBody initMeta trailingMeta respCode details) -> do + details @?= "details string" respBody @?= "reply test" respCode @?= GrpcStatusOk @@ -76,15 +79,18 @@ testPayloadLowLevelClientUnregistered grpc = 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) -> do + Right (NormalRequestResult + respBody initMeta trailingMeta respCode details) -> do respBody @?= "reply test" respCode @?= GrpcStatusOk + details @?= "details string" testPayloadLowLevelServerUnregistered :: GRPC -> IO () testPayloadLowLevelServerUnregistered grpc = do withServer grpc (ServerConfig "localhost" 50051 []) $ \server -> do result <- serverHandleNormalCall server 11 M.empty $ - \reqBody reqMeta -> return ("reply test", M.empty) + \reqBody reqMeta -> return ("reply test", M.empty, + StatusDetails "details string") case result of Left x -> error $ show x Right _ -> return () @@ -104,7 +110,7 @@ testServerAwaitNoClient = testCase "server wait times out when no client " $ do withServer grpc conf $ \server -> do let method = head (registeredMethods server) result <- serverHandleNormalRegisteredCall server method 1 M.empty $ - \_ _ -> return ("", M.empty, M.empty) + \_ _ -> return ("", M.empty, M.empty, StatusDetails "details") result @?= Left GRPCIOTimeout testServerUnregisteredAwaitNoClient :: TestTree @@ -114,7 +120,7 @@ testServerUnregisteredAwaitNoClient = let conf = ServerConfig "localhost" 50051 [] withServer grpc conf $ \server -> do result <- serverHandleNormalCall server 10 M.empty $ - \_ _ -> return ("", M.empty) + \_ _ -> return ("", M.empty, StatusDetails "") case result of Left err -> error $ show err Right _ -> return () diff --git a/tests/Properties.hs b/tests/Properties.hs index 6208951..7637bbe 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -165,8 +165,9 @@ testPayloadServer = do cancelledPtr <- malloc opRecvCloseServer respOps 0 cancelledPtr opSendMessage respOps 1 respbb - opSendStatusServer respOps 2 0 (MetadataKeyValPtr nullPtr) - GrpcStatusOk "ok" + B.useAsCString "ok" $ \detailsStr -> + opSendStatusServer respOps 2 0 (MetadataKeyValPtr nullPtr) + GrpcStatusOk detailsStr serverCall <- peek serverCallPtr respBatchError <- grpcCallStartBatch serverCall respOps 3 (tag 103) reserved