diff --git a/cbits/grpc_haskell.c b/cbits/grpc_haskell.c --- a/cbits/grpc_haskell.c +++ b/cbits/grpc_haskell.c @@ -210,33 +210,8 @@ #ifdef GRPC_HASKELL_DEBUG printf("C wrapper: entered op_array_destroy\n"); #endif - for(int i = 0; i < n; i++){ - grpc_op* op = op_array + i; - switch (op->op) { - case GRPC_OP_SEND_INITIAL_METADATA: - metadata_free(op->data.send_initial_metadata.metadata); - break; - case GRPC_OP_SEND_MESSAGE: - grpc_byte_buffer_destroy(op->data.send_message.send_message); - break; - case GRPC_OP_SEND_CLOSE_FROM_CLIENT: - break; - case GRPC_OP_SEND_STATUS_FROM_SERVER: - grpc_haskell_free("op_array_destroy: GRPC_OP_SEND_STATUS_FROM_SERVER", - op->data.send_status_from_server.trailing_metadata); - grpc_haskell_free("op_array_destroy: GRPC_OP_SEND_STATUS_FROM_SERVER", - (char*)(op->data.send_status_from_server.status_details)); - break; - case GRPC_OP_RECV_INITIAL_METADATA: - break; - case GRPC_OP_RECV_MESSAGE: - break; - case GRPC_OP_RECV_STATUS_ON_CLIENT: - break; - case GRPC_OP_RECV_CLOSE_ON_SERVER: - break; - } - } + // This only destroys the array, the values in the array + // are freed in freeOpContext grpc_haskell_free("op_array_destroy", op_array); } @@ -530,7 +505,7 @@ grpc_call_credentials* grpc_metadata_credentials_create_from_plugin_( grpc_metadata_credentials_plugin* plugin){ - return grpc_metadata_credentials_create_from_plugin(*plugin, NULL); + return grpc_metadata_credentials_create_from_plugin(*plugin, GRPC_PRIVACY_AND_INTEGRITY, NULL); } //This is a hack to work around GHC being unable to deal with raw struct params. diff --git a/grpc-haskell-core.cabal b/grpc-haskell-core.cabal --- a/grpc-haskell-core.cabal +++ b/grpc-haskell-core.cabal @@ -1,5 +1,5 @@ name: grpc-haskell-core -version: 0.0.0.0 +version: 0.1.0 synopsis: Haskell implementation of gRPC layered on shared C library. homepage: https://github.com/awakenetworks/gRPC-haskell license: Apache-2.0 diff --git a/src/Network/GRPC/LowLevel/Server/Unregistered.hs b/src/Network/GRPC/LowLevel/Server/Unregistered.hs --- a/src/Network/GRPC/LowLevel/Server/Unregistered.hs +++ b/src/Network/GRPC/LowLevel/Server/Unregistered.hs @@ -48,7 +48,7 @@ -> (ServerCall -> IO ()) -> IO () withServerCallAsync s f = mask $ \unmask -> - serverCreateCall s >>= \case + unmask (serverCreateCall s) >>= \case Left e -> do grpcDebug $ "withServerCallAsync: call error: " ++ show e return () Right c -> do wasForkSuccess <- forkServer s handler diff --git a/src/Network/GRPC/Unsafe.chs b/src/Network/GRPC/Unsafe.chs --- a/src/Network/GRPC/Unsafe.chs +++ b/src/Network/GRPC/Unsafe.chs @@ -219,9 +219,6 @@ unTag `Tag'} -> `()'#} -{#fun grpc_channel_ping as ^ - {`Channel', `CompletionQueue', unTag `Tag',unReserved `Reserved'} -> `()' #} - {#fun grpc_channel_destroy as ^ {`Channel'} -> `()'#} -- | Starts executing a batch of ops in the given 'OpArray'. Does not block. diff --git a/src/Network/GRPC/Unsafe/Op.chs b/src/Network/GRPC/Unsafe/Op.chs --- a/src/Network/GRPC/Unsafe/Op.chs +++ b/src/Network/GRPC/Unsafe/Op.chs @@ -4,7 +4,6 @@ {#import Network.GRPC.Unsafe.Slice#} -import Control.Exception import Foreign.C.Types import Foreign.Ptr {#import Network.GRPC.Unsafe.ByteBuffer#} @@ -46,10 +45,6 @@ -- | Destroys an 'OpArray' of the given size. {#fun unsafe op_array_destroy as ^ {`OpArray', `Int'} -> `()'#} - --- | brackets creating and destroying an 'OpArray' with the given size. -withOpArray :: Int -> (OpArray -> IO a) -> IO a -withOpArray n f = bracket (opArrayCreate n) (flip opArrayDestroy n) f -- | Creates an op of type GRPC_OP_SEND_INITIAL_METADATA at the specified -- index of the given 'OpArray', containing the given diff --git a/tests/LowLevelTests/Op.hs b/tests/LowLevelTests/Op.hs --- a/tests/LowLevelTests/Op.hs +++ b/tests/LowLevelTests/Op.hs @@ -1,60 +1,77 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module LowLevelTests.Op where -import Data.ByteString (ByteString) -import Test.Tasty -import Test.Tasty.HUnit as HU (testCase, (@?=)) - -import Network.GRPC.LowLevel -import Network.GRPC.LowLevel.Call -import Network.GRPC.LowLevel.Client -import Network.GRPC.LowLevel.Server -import Network.GRPC.LowLevel.Op +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.ByteString (ByteString) +import Network.GRPC.LowLevel +import Network.GRPC.LowLevel.Call +import Network.GRPC.LowLevel.Client +import Network.GRPC.LowLevel.Op +import Network.GRPC.LowLevel.Server +import Test.Tasty +import Test.Tasty.HUnit as HU (testCase, (@?=)) lowLevelOpTests :: TestTree -lowLevelOpTests = testGroup "Synchronous unit tests of low-level Op interface" - [testCancelFromServer] +lowLevelOpTests = + testGroup + "Synchronous unit tests of low-level Op interface" + [testCancelFromServer] testCancelFromServer :: TestTree testCancelFromServer = testCase "Client/Server - client receives server cancellation" $ - runSerialTest $ \grpc -> - withClientServerUnaryCall grpc $ - \(Client{..}, Server{..}, ClientCall{..}, sc@ServerCall{..}) -> do - serverCallCancel sc StatusPermissionDenied "TestStatus" - clientRes <- runOps unsafeCC clientCQ clientRecvOps - case clientRes of - Left x -> error $ "Client recv error: " ++ show x - Right [_,_,OpRecvStatusOnClientResult _ code _details] -> do - code @?= StatusPermissionDenied - return $ Right () - wrong -> error $ "Unexpected op results: " ++ show wrong - + runSerialTest $ \grpc -> + withClientServerUnaryCall grpc $ + \(Client {..}, Server {..}, ClientCall {..}, sc@ServerCall {..}) -> do + serverCallCancel sc StatusPermissionDenied "TestStatus" + clientRes <- runOps unsafeCC clientCQ clientRecvOps + case clientRes of + Left x -> error $ "Client recv error: " ++ show x + Right [_, _, OpRecvStatusOnClientResult _ code _details] -> do + code @?= StatusPermissionDenied + return $ Right () + wrong -> error $ "Unexpected op results: " ++ show wrong runSerialTest :: (GRPC -> IO (Either GRPCIOError ())) -> IO () runSerialTest f = - withGRPC f >>= \case Left x -> error $ show x - Right () -> return () + withGRPC f >>= \case + Left x -> error $ show x + Right () -> return () -withClientServerUnaryCall :: GRPC - -> ((Client, Server, ClientCall, - ServerCall ByteString) - -> IO (Either GRPCIOError a)) - -> IO (Either GRPCIOError a) +withClientServerUnaryCall :: + GRPC -> + ( ( Client, + Server, + ClientCall, + ServerCall ByteString + ) -> + IO (Either GRPCIOError a) + ) -> + IO (Either GRPCIOError a) withClientServerUnaryCall grpc f = do withClient grpc clientConf $ \c -> do crm <- clientRegisterMethodNormal c "/foo" - withServer grpc serverConf $ \s -> - withClientCall c crm 10 $ \cc -> do + withServer grpc serverConf $ \s -> do + ccVar <- newEmptyMVar + bracket newEmptyMVar (\v -> putMVar v ()) $ \finished -> do + _ <- forkIO $ + void $ + withClientCall c crm 10 $ \cc -> do + putMVar ccVar cc + -- NOTE: We need to send client ops here or else `withServerCall` hangs, + -- because registered methods try to do recv ops immediately when + -- created. If later we want to send payloads or metadata, we'll need + -- to tweak this. + _clientRes <- runOps (unsafeCC cc) (clientCQ c) clientEmptySendOps + takeMVar finished + pure (Right ()) let srm = head (normalMethods s) - -- NOTE: We need to send client ops here or else `withServerCall` hangs, - -- because registered methods try to do recv ops immediately when - -- created. If later we want to send payloads or metadata, we'll need - -- to tweak this. - _clientRes <- runOps (unsafeCC cc) (clientCQ c) clientEmptySendOps + cc <- takeMVar ccVar withServerCall s srm $ \sc -> f (c, s, cc, sc) @@ -65,16 +82,22 @@ clientConf = ClientConfig "localhost" 50051 [] Nothing Nothing clientEmptySendOps :: [Op] -clientEmptySendOps = [OpSendInitialMetadata mempty, - OpSendMessage "", - OpSendCloseFromClient] +clientEmptySendOps = + [ OpSendInitialMetadata mempty, + OpSendMessage "", + OpSendCloseFromClient + ] clientRecvOps :: [Op] -clientRecvOps = [OpRecvInitialMetadata, - OpRecvMessage, - OpRecvStatusOnClient] +clientRecvOps = + [ OpRecvInitialMetadata, + OpRecvMessage, + OpRecvStatusOnClient + ] serverEmptyRecvOps :: [Op] -serverEmptyRecvOps = [OpSendInitialMetadata mempty, - OpRecvMessage, - OpRecvCloseOnServer] +serverEmptyRecvOps = + [ OpSendInitialMetadata mempty, + OpRecvMessage, + OpRecvCloseOnServer + ]