Merge pull request #9 from connor/joel/low-level-testing

Prelim cleanup and reorg

grpc-haskell.cabal

@@ -56,7 +56,7 @@ library
     , grpc/impl/codegen/slice.h
   build-tools:          c2hs
   default-language:     Haskell2010
-  ghc-options:          -Wall -fwarn-incomplete-patterns
+  ghc-options:          -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind
   include-dirs:         include
   hs-source-dirs:       src
   default-extensions:   CPP
@@ -76,9 +76,11 @@ test-suite test
     , tasty >= 0.11 && <0.12
     , tasty-hunit >= 0.9 && <0.10
     , containers ==0.5.*
-  other-modules: LowLevelTests
+  other-modules:
+    LowLevelTests,
+    UnsafeTests
   default-language:     Haskell2010
-  ghc-options:          -Wall -fwarn-incomplete-patterns -g -threaded
+  ghc-options:          -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind -g -threaded
   hs-source-dirs:       tests
   main-is:              Properties.hs
   type:                 exitcode-stdio-1.0

src/Network/GRPC/LowLevel/Call.hs

@@ -107,3 +107,9 @@ destroyCall call@ServerCall{..} = do
   forM_ callDetails C.destroyCallDetails
   grpcDebug $ "destroying deadline." ++ show callDeadline
   forM_ callDeadline C.timespecDestroy
+
+_nowarn_unused :: a
+_nowarn_unused =
+  castPtr `undefined`
+  (peek :: Ptr Int -> IO Int) `undefined`
+  ()

src/Network/GRPC/LowLevel/CompletionQueue.hs

@@ -6,8 +6,8 @@
 
 {-# LANGUAGE RecordWildCards #-}
 
-module Network.GRPC.LowLevel.CompletionQueue (
+module Network.GRPC.LowLevel.CompletionQueue
-  CompletionQueue
+  ( CompletionQueue
   , withCompletionQueue
   , createCompletionQueue
   , shutdownCompletionQueue
@@ -16,33 +16,35 @@ module Network.GRPC.LowLevel.CompletionQueue (
   , channelCreateRegisteredCall
   , channelCreateCall
   , TimeoutSeconds
-  , eventSuccess
+  , isEventSuccessful
   , serverRegisterCompletionQueue
   , serverShutdownAndNotify
   , serverRequestRegisteredCall
   , serverRequestCall
   , newTag
-) where
+  )
+where
 
 import           Control.Concurrent            (forkIO, threadDelay)
-import           Control.Concurrent.STM (atomically, retry, check)
+import           Control.Concurrent.STM        (atomically, check, retry)
-import           Control.Concurrent.STM.TVar (TVar, newTVarIO, modifyTVar',
+import           Control.Concurrent.STM.TVar   (TVar, modifyTVar', newTVarIO,
                                                 readTVar, writeTVar)
 import           Control.Exception             (bracket)
-import           Data.IORef (IORef, newIORef, atomicModifyIORef')
+import           Data.IORef                    (IORef, atomicModifyIORef',
+                                                newIORef)
 import           Data.List                     (intersperse)
-import           Foreign.Marshal.Alloc (malloc, free)
+import           Foreign.Marshal.Alloc         (free, malloc)
 import           Foreign.Ptr                   (nullPtr, plusPtr)
 import           Foreign.Storable              (peek)
 import qualified Network.GRPC.Unsafe           as C
 import qualified Network.GRPC.Unsafe.Constants as C
-import qualified Network.GRPC.Unsafe.Time as C
-import qualified Network.GRPC.Unsafe.Op as C
 import qualified Network.GRPC.Unsafe.Metadata  as C
+import qualified Network.GRPC.Unsafe.Op        as C
+import qualified Network.GRPC.Unsafe.Time      as C
 import           System.Timeout                (timeout)
 
-import Network.GRPC.LowLevel.GRPC
 import           Network.GRPC.LowLevel.Call
+import           Network.GRPC.LowLevel.GRPC
 
 -- NOTE: the concurrency requirements for a CompletionQueue are a little
 -- complicated. There are two read operations: next and pluck. We can either
@@ -159,9 +161,10 @@ eventToError (C.Event C.QueueShutdown _ _) = Left GRPCIOShutdown
 eventToError (C.Event C.QueueTimeout _ _) = Left GRPCIOTimeout
 eventToError _ = Left GRPCIOUnknownError
 
-isFailedEvent :: C.Event -> Bool
+-- | Returns true iff the given grpc_event was a success.
-isFailedEvent C.Event{..} = (eventCompletionType /= C.OpComplete)
+isEventSuccessful :: C.Event -> Bool
-                            || not eventSuccess
+isEventSuccessful (C.Event C.OpComplete True _) = True
+isEventSuccessful _ = False
 
 -- | Waits for the given number of seconds for the given tag to appear on the
 -- completion queue. Throws 'GRPCIOShutdown' if the completion queue is shutting
@@ -175,9 +178,7 @@ pluck cq@CompletionQueue{..} tag waitSeconds = do
     C.withDeadlineSeconds waitSeconds $ \deadline -> do
       ev <- C.grpcCompletionQueuePluck unsafeCQ tag deadline C.reserved
       grpcDebug $ "pluck: finished. Event: " ++ show ev
-      if isFailedEvent ev
+      return $ if isEventSuccessful ev then Right () else eventToError ev
-         then return $ eventToError ev
-         else return $ Right ()
 
 -- TODO: I'm thinking it might be easier to use 'Either' uniformly everywhere
 -- even when it's isomorphic to 'Maybe'. If that doesn't turn out to be the
@@ -207,7 +208,7 @@ shutdownCompletionQueue (CompletionQueue{..}) = do
   atomically $ readTVar currentPluckers >>= \x -> check (x == 0)
   --drain the queue
   C.grpcCompletionQueueShutdown unsafeCQ
-  loopRes <- timeout (5*10^6) drainLoop
+  loopRes <- timeout (5*10^(6::Int)) drainLoop
   case loopRes of
     Nothing -> return $ Left GRPCIOShutdownFailure
     Just () -> C.grpcCompletionQueueDestroy unsafeCQ >> return (Right ())
@@ -221,11 +222,6 @@ shutdownCompletionQueue (CompletionQueue{..}) = do
             C.QueueTimeout -> drainLoop
             C.OpComplete -> drainLoop
 
--- | Returns true iff the given grpc_event was a success.
-eventSuccess :: C.Event -> Bool
-eventSuccess (C.Event C.OpComplete True _) = True
-eventSuccess _ = False
-
 channelCreateRegisteredCall :: C.Channel -> C.Call -> C.PropagationMask
                                -> CompletionQueue -> C.CallHandle
                                -> C.CTimeSpecPtr -> IO (Either GRPCIOError Call)
@@ -290,7 +286,7 @@ serverRequestRegisteredCall
                      return $ Right assembledCall
       -- TODO: see TODO for failureCleanup in serverRequestCall.
       where failureCleanup deadline callPtr metadataArrayPtr bbPtr = forkIO $ do
-              threadDelay (30*10^6)
+              threadDelaySecs 30
               grpcDebug "serverRequestRegisteredCall: doing delayed cleanup."
               C.timespecDestroy deadline
               free callPtr
@@ -340,7 +336,7 @@ serverRequestCall server cq@CompletionQueue{..} timeLimit =
       -- we sleep for a while before freeing the objects. We should find a
       -- permanent solution that's more robust.
       where failureCleanup callPtr callDetails metadataArrayPtr = forkIO $ do
-              threadDelay (30*10^6)
+              threadDelaySecs 30
               grpcDebug "serverRequestCall: doing delayed cleanup."
               free callPtr
               C.destroyCallDetails callDetails
@@ -356,3 +352,6 @@ serverRegisterCompletionQueue server CompletionQueue{..} =
 serverShutdownAndNotify :: C.Server -> CompletionQueue -> C.Tag -> IO ()
 serverShutdownAndNotify server CompletionQueue{..} tag =
   C.grpcServerShutdownAndNotify server unsafeCQ tag
+
+threadDelaySecs :: Int -> IO ()
+threadDelaySecs = threadDelay . (* 10^(6::Int))

src/Network/GRPC/LowLevel/GRPC.hs

@@ -51,7 +51,7 @@ grpcDebug :: String -> IO ()
 grpcDebug str = do tid <- myThreadId
                    putStrLn $ (show tid) ++ ": " ++ str
 #else
-grpcDebug str = return ()
+grpcDebug _ = return ()
 #endif
 
 {-

src/Network/GRPC/LowLevel/Op.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards            #-}
 
 module Network.GRPC.LowLevel.Op where
 
@@ -10,17 +10,18 @@ import           Data.Maybe (catMaybes)
 import           Data.String                           (IsString)
 import           Foreign.C.String                      (CString)
 import           Foreign.C.Types                       (CInt)
-import           Foreign.Marshal.Alloc (malloc, mallocBytes, free)
+import           Foreign.Marshal.Alloc                 (free, malloc,
+                                                        mallocBytes)
 import           Foreign.Ptr                           (Ptr, nullPtr)
 import           Foreign.Storable                      (peek, poke)
-import qualified Network.GRPC.Unsafe as C
+import qualified Network.GRPC.Unsafe                   as C ()
-import qualified Network.GRPC.Unsafe.Metadata as C
 import qualified Network.GRPC.Unsafe.ByteBuffer        as C
+import qualified Network.GRPC.Unsafe.Metadata          as C
 import qualified Network.GRPC.Unsafe.Op                as C
 
-import Network.GRPC.LowLevel.GRPC
-import Network.GRPC.LowLevel.CompletionQueue
 import           Network.GRPC.LowLevel.Call
+import           Network.GRPC.LowLevel.CompletionQueue
+import           Network.GRPC.LowLevel.GRPC
 
 type MetadataMap = M.Map B.ByteString B.ByteString
 
@@ -224,3 +225,6 @@ runOps call cq ops timeLimit =
                 grpcDebug "runOps: got good op; starting."
                 fmap (Right . catMaybes) $ mapM resultFromOpContext contexts
               Left err -> return $ Left err
+
+_nowarn_unused :: a
+_nowarn_unused = undefined nullPtr

src/Network/GRPC/LowLevel/Server.hs

@@ -12,12 +12,17 @@ import           Foreign.Storable (peek)
 import qualified Network.GRPC.Unsafe                   as C
 import qualified Network.GRPC.Unsafe.Op                as C
 
-import           Network.GRPC.LowLevel.GRPC
-import           Network.GRPC.LowLevel.CompletionQueue (CompletionQueue,
-                 pluck, serverRegisterCompletionQueue, serverShutdownAndNotify,
-                 createCompletionQueue, shutdownCompletionQueue, TimeoutSeconds,
-                 serverRequestRegisteredCall, serverRequestCall)
 import           Network.GRPC.LowLevel.Call
+import           Network.GRPC.LowLevel.CompletionQueue (CompletionQueue,
+                                                        TimeoutSeconds,
+                                                        createCompletionQueue,
+                                                        pluck,
+                                                        serverRegisterCompletionQueue,
+                                                        serverRequestCall,
+                                                        serverRequestRegisteredCall,
+                                                        serverShutdownAndNotify,
+                                                        shutdownCompletionQueue)
+import           Network.GRPC.LowLevel.GRPC
 import           Network.GRPC.LowLevel.Op
 
 import qualified Network.GRPC.Unsafe.ByteBuffer        as C
@@ -199,7 +204,7 @@ serverHandleNormalRegisteredCall :: Server
                              -- metadata and returns a response body and
                              -- metadata.
                           -> IO (Either GRPCIOError ())
-serverHandleNormalRegisteredCall s@Server{..} rm timeLimit initMetadata f = do
+serverHandleNormalRegisteredCall s@Server{..} rm timeLimit srvMetadata f = do
   -- TODO: we use this timeLimit twice, so the max time spent is 2*timeLimit.
   -- Should we just hard-code time limits instead? Not sure if client
   -- programmer cares, since this function will likely just be put in a loop
@@ -229,16 +234,16 @@ serverHandleNormalRegisteredCall s@Server{..} rm timeLimit initMetadata f = do
 -- | Handle one unregistered call.
 serverHandleNormalCall :: Server -> TimeoutSeconds
                           -> MetadataMap
-                          -- ^ Initial metadata.
+                          -- ^ Initial server metadata.
                           -> (ByteString -> MetadataMap
                               -> IO (ByteString, MetadataMap, StatusDetails))
                           -- ^ Handler function takes a request body and
                           -- metadata and returns a response body and metadata.
                           -> IO (Either GRPCIOError ())
-serverHandleNormalCall s@Server{..} timeLimit initMetadata f = do
+serverHandleNormalCall s@Server{..} timeLimit srvMetadata f = do
   withServerCall s timeLimit $ \call -> do
     grpcDebug "serverHandleNormalCall: starting batch."
-    let recvOps = serverOpsGetNormalCall initMetadata
+    let recvOps = serverOpsGetNormalCall srvMetadata
     opResults <- runOps call serverCQ recvOps timeLimit
     case opResults of
       Left x -> return $ Left x
@@ -255,3 +260,6 @@ serverHandleNormalCall s@Server{..} timeLimit initMetadata f = do
           Right _ -> grpcDebug "serverHandleNormalCall: ops done."
                      >> return (Right ())
       x -> error $ "impossible pattern match: " ++ show x
+
+_nowarn_unused :: a
+_nowarn_unused = undefined threadDelay

tests/LowLevelTests.hs

@@ -1,13 +1,14 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module LowLevelTests where
+module LowLevelTests (lowLevelTests) where
 
-import           Control.Concurrent.Async (withAsync, wait)
+import           Control.Concurrent.Async
+import           Control.Monad
 import           Data.ByteString                (ByteString)
 import qualified Data.Map                       as M
 import           Network.GRPC.LowLevel
 import           Test.Tasty
-import           Test.Tasty.HUnit ((@?=), testCase)
+import           Test.Tasty.HUnit               as HU (testCase, (@?=))
 
 lowLevelTests :: TestTree
 lowLevelTests = testGroup "Unit tests of low-level Haskell library"
@@ -23,81 +24,75 @@ lowLevelTests = testGroup "Unit tests of low-level Haskell library"
    , testPayloadLowLevelUnregistered
    ]
 
-dummyMeta :: M.Map ByteString ByteString
-dummyMeta = M.fromList [("foo","bar")]
-
 testGRPCBracket :: TestTree
-testGRPCBracket = testCase "No errors starting and stopping GRPC" $
+testGRPCBracket = grpcTest "Start/stop GRPC" nop
-                  withGRPC $ const $ return ()
 
 testCompletionQueueCreateDestroy :: TestTree
 testCompletionQueueCreateDestroy =
-  testCase "No errors creating and destroying a CQ" $ withGRPC $ \grpc ->
+  grpcTest "Create/destroy completion queue" $ \grpc -> do
-    withCompletionQueue grpc $ const (return ())
+  withCompletionQueue grpc nop
 
 testServerCreateDestroy :: TestTree
 testServerCreateDestroy =
-  testCase "No errors when starting and stopping a server" $
+  grpcTest "Server - start/stop" $ \grpc -> do
-  withGRPC $ \grpc -> withServer grpc (ServerConfig "localhost" 50051 [])
+  withServer grpc (ServerConfig "localhost" 50051 []) nop
-                                 (const $ return ())
 
 testClientCreateDestroy :: TestTree
 testClientCreateDestroy =
-  testCase "No errors when starting and stopping a client" $
+  grpcTest "Client - start/stop" $ \grpc -> do
-  withGRPC $ \grpc -> withClient grpc (ClientConfig "localhost" 50051)
+  withClient grpc (ClientConfig "localhost" 50051) nop
-                                 (const $ return ())
 
-testPayloadLowLevelServer :: GRPC -> IO ()
+payloadLowLevelServer :: TestServer
-testPayloadLowLevelServer grpc = do
+payloadLowLevelServer = TestServer $ \grpc -> do
   let conf = (ServerConfig "localhost" 50051 [("/foo", "localhost", Normal)])
   withServer grpc conf $ \server -> do
     let method = head (registeredMethods server)
     result <- serverHandleNormalRegisteredCall server method 11 M.empty $
-                \reqBody reqMeta ->
+                \_reqBody _reqMeta ->
                   return ("reply test", dummyMeta, dummyMeta,
                           StatusDetails "details string")
     case result of
       Left err -> error $ show err
       Right _ -> return ()
 
-testPayloadLowLevelClient :: GRPC -> IO ()
+payloadLowLevelClient :: TestClient
-testPayloadLowLevelClient grpc =
+payloadLowLevelClient = TestClient $ \grpc ->
   withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
     method <- clientRegisterMethod client "/foo" "localhost" Normal
     putStrLn "registered method on client."
     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 details) -> do
+      Right (NormalRequestResult respBody _initMeta _trailingMeta respCode details) -> do
         details @?= "details string"
         respBody @?= "reply test"
         respCode @?= GrpcStatusOk
 
-testPayloadLowLevelClientUnregistered :: GRPC -> IO ()
+payloadLowLevelClientUnregistered :: TestClient
-testPayloadLowLevelClientUnregistered grpc = do
+payloadLowLevelClientUnregistered = TestClient $ \grpc -> do
   withClient grpc (ClientConfig "localhost" 50051) $ \client -> 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 details) -> do
+              respBody _initMeta _trailingMeta respCode details) -> do
         respBody @?= "reply test"
         respCode @?= GrpcStatusOk
         details @?= "details string"
 
-testPayloadLowLevelServerUnregistered :: GRPC -> IO ()
+payloadLowLevelServerUnregistered :: TestServer
-testPayloadLowLevelServerUnregistered grpc = do
+payloadLowLevelServerUnregistered = TestServer $ \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 ()
 
 testClientRequestNoServer :: TestTree
-testClientRequestNoServer = testCase "request times out when no server " $ do
+testClientRequestNoServer =
-  withGRPC $ \grpc -> do
+  grpcTest "Client - request timeout when server DNE" $ \grpc -> do
   withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
     method <- clientRegisterMethod client "/foo" "localhost" Normal
     reqResult <- clientRegisteredRequest client method 1 "Hello" M.empty
@@ -126,26 +121,18 @@ testServerUnregisteredAwaitNoClient =
           Right _ -> return ()
 
 testPayloadLowLevel :: TestTree
-testPayloadLowLevel = testCase "LowLevel Haskell library request/response " $ do
+testPayloadLowLevel =
-  withGRPC $ \grpc -> do
+  grpcTest "Client/Server - low-level (registered) request/response" $
-    withAsync (testPayloadLowLevelServer grpc) $ \a1 -> do
+  runClientServer payloadLowLevelClient payloadLowLevelServer
-      withAsync (testPayloadLowLevelClient grpc) $ \a2 -> do
-        wait a1
-        wait a2
 
 testPayloadLowLevelUnregistered :: TestTree
 testPayloadLowLevelUnregistered =
-  testCase "LowLevel Haskell library unregistered request/response " $ do
+  grpcTest "Client/Server - low-level unregistered request/response" $
-    withGRPC $ \grpc -> do
+  runClientServer payloadLowLevelClientUnregistered payloadLowLevelServerUnregistered
-      withAsync (testPayloadLowLevelServerUnregistered grpc) $ \a1 ->
-        withAsync (testPayloadLowLevelClientUnregistered grpc) $ \a2 -> do
-          wait a1
-          wait a2
 
 testWithServerCall :: TestTree
 testWithServerCall =
-  testCase "Creating and destroying a call: no errors. " $
+  grpcTest "Server - Create/destroy call" $ \grpc -> do
-    withGRPC $ \grpc -> do
   let conf = ServerConfig "localhost" 50051 []
   withServer grpc conf $ \server -> do
     result <- withServerCall server 1 $ const $ return $ Right ()
@@ -153,8 +140,7 @@ testWithServerCall =
 
 testWithClientCall :: TestTree
 testWithClientCall =
-  testCase "Creating and destroying a client call: no errors. " $
+  grpcTest "Client - Create/destroy call" $ \grpc -> do
-    withGRPC $ \grpc -> do
   let conf = ClientConfig "localhost" 50051
   withClient grpc conf $ \client -> do
     result <- withClientCall client "foo" "localhost" 10 $
@@ -162,3 +148,25 @@ testWithClientCall =
     case result of
       Left err -> error $ show err
       Right _ -> return ()
+
+--------------------------------------------------------------------------------
+-- Utilities and helpers
+
+dummyMeta :: M.Map ByteString ByteString
+dummyMeta = M.fromList [("foo","bar")]
+
+nop :: Monad m => a -> m ()
+nop = const (return ())
+
+-- | Defines a general-purpose GRPC unit test
+grpcTest :: TestName -> (GRPC -> IO ()) -> TestTree
+grpcTest nm = testCase nm . withGRPC
+
+newtype TestClient = TestClient (GRPC -> IO ())
+newtype TestServer = TestServer (GRPC -> IO ())
+
+-- | 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 =
+  void $ s grpc `concurrently` c grpc

tests/Properties.hs

@@ -1,245 +1,9 @@
-{-# 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
-
+import           Test.Tasty
-roundtripSlice :: B.ByteString -> TestTree
+import           UnsafeTests
-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]
 
 main :: IO ()
-main = defaultMain allTests
+main = defaultMain $ testGroup "GRPC Unit Tests"
+  [ unsafeTests
+  , lowLevelTests
+  ]

tests/UnsafeTests.hs

@@ -0,0 +1,230 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module UnsafeTests (unsafeTests) where
+
+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
+import           Test.Tasty.HUnit               as HU (testCase, (@?=))
+
+unsafeTests :: TestTree
+unsafeTests = testGroup "Unit tests for unsafe C bindings"
+  [ roundtripSlice "Hello, world!"
+  , roundtripByteBuffer "Hwaet! We gardena in geardagum..."
+  , testMetadata
+  , testNow
+  , testCreateDestroyMetadata
+  , testCreateDestroyMetadataKeyVals
+  , testCreateDestroyDeadline
+  , testPayload
+  ]
+
+roundtripSlice :: B.ByteString -> TestTree
+roundtripSlice bs = testCase "ByteString slice roundtrip" $ do
+  slice <- byteStringToSlice bs
+  unslice <- sliceToByteString slice
+  bs HU.@?= unslice
+  freeSlice slice
+
+roundtripByteBuffer :: B.ByteString -> TestTree
+roundtripByteBuffer bs = testCase "ByteBuffer 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
+
+testMetadata :: TestTree
+testMetadata = testCase "Metadata setter/getter 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
+
+currTimeMillis :: ClockType -> IO Int
+currTimeMillis t = do
+  gprT <- gprNow t
+  tMillis <- gprTimeToMillis gprT
+  timespecDestroy gprT
+  return tMillis
+
+testNow :: TestTree
+testNow = testCase "Create/destroy various clock types" $ do
+  _ <- currTimeMillis GprClockMonotonic
+  _ <- currTimeMillis GprClockRealtime
+  _ <- currTimeMillis GprClockPrecise
+  return ()
+
+testCreateDestroyMetadata :: TestTree
+testCreateDestroyMetadata = testCase "Create/destroy metadataArrayPtr" $ do
+  grpc $ withMetadataArrayPtr $ const $ return ()
+
+testCreateDestroyMetadataKeyVals :: TestTree
+testCreateDestroyMetadataKeyVals = testCase "Create/destroy metadata key/values" $ do
+  grpc $ withMetadataKeyValPtr 10 $ const $ return ()
+
+testCreateDestroyDeadline :: TestTree
+testCreateDestroyDeadline = testCase "Create/destroy deadline" $ do
+  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