mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-11-23 03:29:42 +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
Joel Stanley
parent
16208697fa
commit
8a0eef8ab7
12 changed files with 378 additions and 59 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'}
|
||||
-> `()'#}
|
||||
|
|
|
|||
|
|
@ -26,11 +26,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.
|
||||
, testPayload
|
||||
, testPayloadLowLevelUnregistered
|
||||
]
|
||||
|
||||
dummyMeta :: M.Map ByteString ByteString
|
||||
|
|
@ -63,7 +62,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 ()
|
||||
|
|
@ -76,7 +77,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
|
||||
|
||||
|
|
@ -86,15 +88,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 ()
|
||||
|
|
@ -114,7 +119,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
|
||||
|
|
@ -124,7 +129,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 ()
|
||||
|
|
|
|||
|
|
@ -1,6 +1,251 @@
|
|||
<<<<<<< HEAD
|
||||
import LowLevelTests
|
||||
import Test.Tasty
|
||||
import UnsafeTests
|
||||
=======
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Network.GRPC.Unsafe
|
||||
import Network.GRPC.Unsafe.Slice
|
||||
import Network.GRPC.Unsafe.ByteBuffer
|
||||
import Network.GRPC.Unsafe.Time
|
||||
import Network.GRPC.Unsafe.Metadata
|
||||
import Network.GRPC.Unsafe.Op
|
||||
import Network.GRPC.Unsafe.Constants
|
||||
import qualified Data.ByteString as B
|
||||
import Foreign.Marshal.Alloc
|
||||
import Foreign.Storable
|
||||
import Foreign.Ptr
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit as HU
|
||||
|
||||
import LowLevelTests
|
||||
|
||||
roundtripSlice :: B.ByteString -> TestTree
|
||||
roundtripSlice bs = testCase "Slice C bindings roundtrip" $ do
|
||||
slice <- byteStringToSlice bs
|
||||
unslice <- sliceToByteString slice
|
||||
bs HU.@?= unslice
|
||||
freeSlice slice
|
||||
|
||||
roundtripByteBuffer :: B.ByteString -> TestTree
|
||||
roundtripByteBuffer bs = testCase "ByteBuffer C bindings roundtrip" $ do
|
||||
slice <- byteStringToSlice bs
|
||||
buffer <- grpcRawByteBufferCreate slice 1
|
||||
reader <- byteBufferReaderCreate buffer
|
||||
readSlice <- grpcByteBufferReaderReadall reader
|
||||
bs' <- sliceToByteString readSlice
|
||||
bs' HU.@?= bs
|
||||
--clean up
|
||||
freeSlice slice
|
||||
byteBufferReaderDestroy reader
|
||||
grpcByteBufferDestroy buffer
|
||||
freeSlice readSlice
|
||||
|
||||
currTimeMillis :: ClockType -> IO Int
|
||||
currTimeMillis t = do
|
||||
gprT <- gprNow t
|
||||
tMillis <- gprTimeToMillis gprT
|
||||
timespecDestroy gprT
|
||||
return tMillis
|
||||
|
||||
testNow :: TestTree
|
||||
testNow = testCase "create and destroy various clock types" $ do
|
||||
_ <- currTimeMillis GprClockMonotonic
|
||||
_ <- currTimeMillis GprClockRealtime
|
||||
_ <- currTimeMillis GprClockPrecise
|
||||
return ()
|
||||
|
||||
testMetadata :: TestTree
|
||||
testMetadata = testCase "metadata setter/getter C bindings roundtrip" $ do
|
||||
m <- metadataAlloc 3
|
||||
setMetadataKeyVal "hello" "world" m 0
|
||||
setMetadataKeyVal "foo" "bar" m 1
|
||||
setMetadataKeyVal "Haskell" "Curry" m 2
|
||||
k0 <- getMetadataKey m 0
|
||||
v0 <- getMetadataVal m 0
|
||||
k1 <- getMetadataKey m 1
|
||||
v1 <- getMetadataVal m 1
|
||||
k2 <- getMetadataKey m 2
|
||||
v2 <- getMetadataVal m 2
|
||||
k0 HU.@?= "hello"
|
||||
v0 HU.@?= "world"
|
||||
k1 HU.@?= "foo"
|
||||
v1 HU.@?= "bar"
|
||||
k2 HU.@?= "Haskell"
|
||||
v2 HU.@?= "Curry"
|
||||
metadataFree m
|
||||
|
||||
assertCqEventComplete :: Event -> IO ()
|
||||
assertCqEventComplete e = do
|
||||
eventCompletionType e HU.@?= OpComplete
|
||||
eventSuccess e HU.@?= True
|
||||
|
||||
testPayloadClient :: IO ()
|
||||
testPayloadClient = 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
|
||||
|
||||
testPayloadServer :: IO ()
|
||||
testPayloadServer = 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.
|
||||
testPayload :: TestTree
|
||||
testPayload = testCase "low-level C bindings request/response " $ do
|
||||
grpcInit
|
||||
withAsync testPayloadServer $ \a1 -> do
|
||||
withAsync testPayloadClient $ \a2 -> do
|
||||
() <- wait a1
|
||||
wait a2
|
||||
grpcShutdown
|
||||
putStrLn "Done."
|
||||
|
||||
testCreateDestroyMetadata :: TestTree
|
||||
testCreateDestroyMetadata = testCase "create/destroy metadataArrayPtr " $ do
|
||||
grpcInit
|
||||
withMetadataArrayPtr $ const (return ())
|
||||
grpcShutdown
|
||||
|
||||
testCreateDestroyMetadataKeyVals :: TestTree
|
||||
testCreateDestroyMetadataKeyVals = testCase "create/destroy metadata k/vs " $ do
|
||||
grpcInit
|
||||
withMetadataKeyValPtr 10 $ const (return ())
|
||||
grpcShutdown
|
||||
|
||||
testCreateDestroyDeadline :: TestTree
|
||||
testCreateDestroyDeadline = testCase "create/destroy deadline " $ do
|
||||
grpcInit
|
||||
withDeadlineSeconds 10 $ const (return ())
|
||||
grpcShutdown
|
||||
|
||||
unsafeTests :: TestTree
|
||||
unsafeTests = testGroup "Unit tests for unsafe C bindings."
|
||||
[testPayload,
|
||||
roundtripSlice "Hello, world!",
|
||||
roundtripByteBuffer "Hwaet! We gardena in geardagum...",
|
||||
testMetadata,
|
||||
testNow,
|
||||
testCreateDestroyMetadata,
|
||||
testCreateDestroyMetadataKeyVals,
|
||||
testCreateDestroyDeadline
|
||||
]
|
||||
|
||||
allTests :: TestTree
|
||||
allTests = testGroup "All tests"
|
||||
[ unsafeTests,
|
||||
lowLevelTests]
|
||||
>>>>>>> Fix payload test bugs (#8)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain $ testGroup "GRPC Unit Tests"
|
||||
|
|
|
|||
Loading…
Reference in a new issue