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

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

src/Network/GRPC/LowLevel.hs

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

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]
+   OpRecvStatusOnClientResult m2 status details]
-    = NormalRequestResult body m m2 status
+    = 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."

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

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.Marshal.Alloc (malloc, mallocBytes, free)
-import           Foreign.Ptr (Ptr)
+import           Foreign.Ptr (Ptr, nullPtr)
-import           Foreign.Storable (peek)
+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 =
+createOpContext OpRecvStatusOnClient = do
-  OpRecvStatusOnClientContext
+  pmetadata <- C.metadataArrayCreate
-  <$> C.metadataArrayCreate
+  pstatus <- C.createStatusCodePtr
-  <*> 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) =
+setOpArray arr i (OpSendStatusFromServerContext kvs l code details) =
-  C.opSendStatusServer arr i l kvs code "" --TODO: Issue #6
+  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
+setOpArray arr i (OpRecvStatusOnClientContext pmetadata pstatus pstr) = do
-  pCString <- malloc --TODO: Issue #6
+  C.opRecvStatusClient arr i pmetadata pstatus pstr defaultStatusStringLen
-  C.opRecvStatusClient arr i pmetadata pstatus pCString 0
 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

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

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
+deriving instance Show Call
-  show (Call ptr) = show ptr
 
 {#pointer *grpc_call_details as CallDetails newtype #}
 
-instance Show CallDetails where
+deriving instance Show CallDetails
-  show (CallDetails ptr) = show ptr
 
 {#fun create_call_details as ^ {} -> `CallDetails'#}
 {#fun destroy_call_details as ^ {`CallDetails'} -> `()'#}

src/Network/GRPC/Unsafe/ByteBuffer.chs

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

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

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

tests/LowLevelTests.hs

@@ -20,18 +20,17 @@ import           Test.Tasty.HUnit               as HU (testCase, (@?=))
 
 lowLevelTests :: TestTree
 lowLevelTests = testGroup "Unit tests of low-level Haskell library"
-  [ testGRPCBracket
+  [  testGRPCBracket
-  , testCompletionQueueCreateDestroy
+   , testCompletionQueueCreateDestroy
-  , testServerCreateDestroy
+   , testServerCreateDestroy
-  , testClientCreateDestroy
+   , testClientCreateDestroy
-  , testWithServerCall
+   , testWithServerCall
-  , testWithClientCall
+   , testWithClientCall
-  -- , testPayloadLowLevel --TODO: currently crashing from free on unalloced ptr
+   , testPayloadLowLevel
-  -- , testClientRequestNoServer --TODO: succeeds when no other tests run.
+   , testClientRequestNoServer
-  , testServerAwaitNoClient
+   , testServerAwaitNoClient
-  -- , testPayloadLowLevelUnregistered --TODO: succeeds when no other tests run.
+   , testPayloadLowLevelUnregistered
-  , testPayload
+   ]
-  ]
 
 dummyMeta :: M.Map ByteString ByteString
 dummyMeta = M.fromList [("foo","bar")]
@@ -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 ()

tests/Properties.hs

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