mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-11-26 21:19:43 +01:00
Fix payload test bugs (#8)
* fix memory mgmt bug in status details strings * remove flags * allow server to specify status details
This commit is contained in:
Connor Clark
parent
2ad0465df6
commit
3746383976
12 changed files with 128 additions and 52 deletions
|
|
@ -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){
|
||||
|
|
|
|||
|
|
@ -47,6 +47,7 @@ GRPC
|
|||
, runOps
|
||||
, Op(..)
|
||||
, OpRecvResult(..)
|
||||
, StatusDetails(..)
|
||||
|
||||
) where
|
||||
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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'} -> `()'#}
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
module Network.GRPC.Unsafe.ByteBuffer where
|
||||
|
||||
#include <grpc/grpc.h>
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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'#}
|
||||
|
||||
|
|
|
|||
|
|
@ -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'}
|
||||
-> `()'#}
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -165,8 +165,9 @@ testPayloadServer = do
|
|||
cancelledPtr <- malloc
|
||||
opRecvCloseServer respOps 0 cancelledPtr
|
||||
opSendMessage respOps 1 respbb
|
||||
B.useAsCString "ok" $ \detailsStr ->
|
||||
opSendStatusServer respOps 2 0 (MetadataKeyValPtr nullPtr)
|
||||
GrpcStatusOk "ok"
|
||||
GrpcStatusOk detailsStr
|
||||
serverCall <- peek serverCallPtr
|
||||
respBatchError <- grpcCallStartBatch serverCall respOps 3
|
||||
(tag 103) reserved
|
||||
|
|
|
|||
Loading…
Reference in a new issue