More cleanup: move unsafe payload test to UnsafeTests module, use bracket_ and concurrently

2024-11-26 21:19:43 +01:00 · 2016-05-25 15:41:37 -07:00 · 2016-05-25 15:41:37 -07:00 · 2882a2a8ff
commit 2882a2a8ff
parent e7faab5d3a
2 changed files with 151 additions and 159 deletions
--- a/tests/LowLevelTests.hs
+++ b/tests/LowLevelTests.hs
@ -2,20 +2,12 @@

 module LowLevelTests (lowLevelTests) where

+import           Control.Applicative
 import           Control.Concurrent.Async
+import           Control.Monad
 import           Data.ByteString                (ByteString)
-import qualified Data.ByteString                as B
 import qualified Data.Map                       as M
-import           Foreign.Marshal.Alloc
-import           Foreign.Ptr
-import           Foreign.Storable
 import           Network.GRPC.LowLevel
-import           Network.GRPC.Unsafe
-import           Network.GRPC.Unsafe.ByteBuffer
-import           Network.GRPC.Unsafe.Constants
-import           Network.GRPC.Unsafe.Metadata
-import           Network.GRPC.Unsafe.Op
-import           Network.GRPC.Unsafe.Time
 import           Test.Tasty
 import           Test.Tasty.HUnit               as HU (testCase, (@?=))

@ -31,7 +23,6 @@ lowLevelTests = testGroup "Unit tests of low-level Haskell library"
   , testClientRequestNoServer
   , testServerAwaitNoClient
   , testPayloadLowLevelUnregistered
-   , testUnsafePayload
   ]

 testGRPCBracket :: TestTree
@ -158,135 +149,6 @@ testWithClientCall =
      Left err -> error $ show err
      Right _ -> return ()

-assertCqEventComplete :: Event -> IO ()
-assertCqEventComplete e = do
-  eventCompletionType e HU.@?= OpComplete
-  eventSuccess e HU.@?= True
-
-unsafePayloadClient :: TestClient
-unsafePayloadClient = TestClient $ \_grpc -> 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
-
-unsafePayloadServer :: TestServer
-unsafePayloadServer = TestServer $ \_grpc -> 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.
-testUnsafePayload :: TestTree
-testUnsafePayload =
-  grpcTest "Client/Server - Unsafe request/response" $
-  runClientServer unsafePayloadClient unsafePayloadServer
-
 --------------------------------------------------------------------------------
 -- Utilities and helpers

@ -303,12 +165,8 @@ grpcTest nm = testCase nm . withGRPC
 newtype TestClient = TestClient (GRPC -> IO ())
 newtype TestServer = TestServer (GRPC -> IO ())

-- | Asyncs the given 'TestClient' and 'TestServer' and waits for both to
-- terminate. TODO: We'll probably want to add toplevel timeouts and better
-- error reporting.
+-- | Concurrently executes the given 'TestClient' and 'TestServer' TODO: We may
+-- want to add toplevel timeouts and better error reporting here.
 runClientServer :: TestClient -> TestServer -> GRPC -> IO ()
-runClientServer (TestClient c) (TestServer s) grpc = do
-  withAsync (s grpc) $ \a1 -> do
-    withAsync (c grpc) $ \a2 -> do
-      wait a1
-      wait a2
+runClientServer (TestClient c) (TestServer s) grpc =
+  void $ s grpc `concurrently` c grpc
--- a/tests/UnsafeTests.hs
+++ b/tests/UnsafeTests.hs
@ -1,11 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}

-module UnsafeTests where
+module UnsafeTests (unsafeTests) where

-import           Data.ByteString                as B (ByteString)
+import           Control.Concurrent.Async
+import           Control.Exception (bracket_)
+import           Control.Monad
+import qualified Data.ByteString                as B
+import           Foreign.Marshal.Alloc
+import           Foreign.Ptr
+import           Foreign.Storable
 import           Network.GRPC.Unsafe
 import           Network.GRPC.Unsafe.ByteBuffer
+import           Network.GRPC.Unsafe.Constants
 import           Network.GRPC.Unsafe.Metadata
+import           Network.GRPC.Unsafe.Op
 import           Network.GRPC.Unsafe.Slice
 import           Network.GRPC.Unsafe.Time
 import           Test.Tasty
@ -20,6 +28,7 @@ unsafeTests = testGroup "Unit tests for unsafe C bindings"
  , testCreateDestroyMetadata
  , testCreateDestroyMetadataKeyVals
  , testCreateDestroyDeadline
+  , testPayload
  ]

 roundtripSlice :: B.ByteString -> TestTree
@ -79,18 +88,143 @@ testNow = testCase "Create/destroy various clock types" $ do

 testCreateDestroyMetadata :: TestTree
 testCreateDestroyMetadata = testCase "Create/destroy metadataArrayPtr" $ do
-  grpcInit
-  withMetadataArrayPtr $ const $ return ()
-  grpcShutdown
+  grpc $ withMetadataArrayPtr $ const $ return ()

 testCreateDestroyMetadataKeyVals :: TestTree
 testCreateDestroyMetadataKeyVals = testCase "Create/destroy metadata key/values" $ do
-  grpcInit
-  withMetadataKeyValPtr 10 $ const $ return ()
-  grpcShutdown
+  grpc $ withMetadataKeyValPtr 10 $ const $ return ()

 testCreateDestroyDeadline :: TestTree
 testCreateDestroyDeadline = testCase "Create/destroy deadline" $ do
-  grpcInit
-  withDeadlineSeconds 10 $ const $ return ()
-  grpcShutdown
+  grpc $ withDeadlineSeconds 10 $ const $ return ()
+
+assertCqEventComplete :: Event -> IO ()
+assertCqEventComplete e = do
+  eventCompletionType e HU.@?= OpComplete
+  eventSuccess e HU.@?= True
+
+payloadClient :: IO ()
+payloadClient = 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
+
+payloadServer :: IO ()
+payloadServer = 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 "Unsafe request/response" $ do
+  grpc $ payloadClient `concurrently` payloadServer
+
+grpc :: IO a -> IO ()
+grpc = bracket_ grpcInit grpcShutdown . void