eeva/gRPC-haskell
1
0
Fork 0
mirror of https://github.com/unclechu/gRPC-haskell.git synced 2024-12-25 11:19:44 +01:00
Code Issues Projects Releases Wiki Activity

Fix payload test bugs (#8)

Browse source 
* fix memory mgmt bug in status details strings

* remove flags

* allow server to specify status details
This commit is contained in:
Connor Clark 2016-05-25 13:11:30 -07:00
parent 2ad0465df6
commit 3746383976
12 changed files with 128 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
cbits/grpc_haskell.c
View file

@ -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){

1
src/Network/GRPC/LowLevel.hs
View file

@ -47,6 +47,7 @@ GRPC
, runOps
, Op(..)
, OpRecvResult(..)
, StatusDetails(..)
) where

13
src/Network/GRPC/LowLevel/Client.hs
View file

@ -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."

8
src/Network/GRPC/LowLevel/CompletionQueue.hs
View file

@ -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

65
src/Network/GRPC/LowLevel/Op.hs
View file

@ -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

26
src/Network/GRPC/LowLevel/Server.hs
View file

@ -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."

12
src/Network/GRPC/Unsafe.chs
View file

@ -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'} -> `()'#}

4
src/Network/GRPC/Unsafe/ByteBuffer.chs
View file

@ -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

6
src/Network/GRPC/Unsafe/Metadata.chs
View file

@ -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'#}

6
src/Network/GRPC/Unsafe/Op.chs
View file

@ -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'}
-> `()'#}

24
tests/LowLevelTests.hs
View file

@ -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 ()

5
tests/Properties.hs
View file

@ -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