diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal index 4cadf7c..9e726a9 100644 --- a/grpc-haskell.cabal +++ b/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 diff --git a/src/Network/GRPC/LowLevel/Call.hs b/src/Network/GRPC/LowLevel/Call.hs index 15559db..ac8663a 100644 --- a/src/Network/GRPC/LowLevel/Call.hs +++ b/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` + () diff --git a/src/Network/GRPC/LowLevel/CompletionQueue.hs b/src/Network/GRPC/LowLevel/CompletionQueue.hs index b7af4c4..3310734 100644 --- a/src/Network/GRPC/LowLevel/CompletionQueue.hs +++ b/src/Network/GRPC/LowLevel/CompletionQueue.hs @@ -6,8 +6,8 @@ {-# LANGUAGE RecordWildCards #-} -module Network.GRPC.LowLevel.CompletionQueue ( - CompletionQueue +module Network.GRPC.LowLevel.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.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) -import qualified Network.GRPC.Unsafe as C +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM (atomically, check, retry) +import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, + readTVar, writeTVar) +import Control.Exception (bracket) +import Data.IORef (IORef, atomicModifyIORef', + newIORef) +import Data.List (intersperse) +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 System.Timeout (timeout) +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.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 @@ -69,7 +71,7 @@ import Network.GRPC.LowLevel.Call -- are used to wait for batches gRPC operations ('Op's) to finish running, as -- well as wait for various other operations, such as server shutdown, pinging, -- checking to see if we've been disconnected, and so forth. -data CompletionQueue = CompletionQueue {unsafeCQ :: C.CompletionQueue, +data CompletionQueue = CompletionQueue {unsafeCQ :: C.CompletionQueue, -- ^ All access to this field must be -- guarded by a check of 'shuttingDown'. currentPluckers :: TVar Int, @@ -78,15 +80,15 @@ data CompletionQueue = CompletionQueue {unsafeCQ :: C.CompletionQueue, -- queue. -- The max value is set by gRPC in -- 'C.maxCompletionQueuePluckers' - currentPushers :: TVar Int, + currentPushers :: TVar Int, -- ^ Used to prevent new work from -- being pushed onto the queue when -- the queue begins to shut down. - shuttingDown :: TVar Bool, + shuttingDown :: TVar Bool, -- ^ Used to prevent new pluck calls on -- the queue when the queue begins to -- shut down. - nextTag :: IORef Int + nextTag :: IORef Int -- ^ Used to supply unique tags for work -- items pushed onto the queue. } @@ -159,13 +161,14 @@ eventToError (C.Event C.QueueShutdown _ _) = Left GRPCIOShutdown eventToError (C.Event C.QueueTimeout _ _) = Left GRPCIOTimeout eventToError _ = Left GRPCIOUnknownError -isFailedEvent :: C.Event -> Bool -isFailedEvent C.Event{..} = (eventCompletionType /= C.OpComplete) - || not eventSuccess +-- | Returns true iff the given grpc_event was a success. +isEventSuccessful :: C.Event -> Bool +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 ---down and cannot handle new requests. +-- down and cannot handle new requests. pluck :: CompletionQueue -> C.Tag -> TimeoutSeconds -> IO (Either GRPCIOError ()) pluck cq@CompletionQueue{..} tag waitSeconds = do @@ -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 - then return $ eventToError ev - else return $ Right () + return $ if isEventSuccessful ev then Right () else eventToError ev -- 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)) diff --git a/src/Network/GRPC/LowLevel/GRPC.hs b/src/Network/GRPC/LowLevel/GRPC.hs index 4d7bd8f..dedf1ba 100644 --- a/src/Network/GRPC/LowLevel/GRPC.hs +++ b/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 {- diff --git a/src/Network/GRPC/LowLevel/Op.hs b/src/Network/GRPC/LowLevel/Op.hs index 7a82e08..938f2de 100644 --- a/src/Network/GRPC/LowLevel/Op.hs +++ b/src/Network/GRPC/LowLevel/Op.hs @@ -1,26 +1,27 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} module Network.GRPC.LowLevel.Op where 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, mallocBytes, free) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (peek, poke) -import qualified Network.GRPC.Unsafe as C -import qualified Network.GRPC.Unsafe.Metadata as C -import qualified Network.GRPC.Unsafe.ByteBuffer as C -import qualified Network.GRPC.Unsafe.Op as C +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 (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.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.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 diff --git a/src/Network/GRPC/LowLevel/Server.hs b/src/Network/GRPC/LowLevel/Server.hs index d1d95b1..d541ac1 100644 --- a/src/Network/GRPC/LowLevel/Server.hs +++ b/src/Network/GRPC/LowLevel/Server.hs @@ -2,26 +2,31 @@ module Network.GRPC.LowLevel.Server where -import Control.Concurrent (threadDelay) -import Control.Exception (bracket, finally) +import Control.Concurrent (threadDelay) +import Control.Exception (bracket, finally) import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.Map as M -import Foreign.Ptr (nullPtr) -import Foreign.Storable (peek) -import qualified Network.GRPC.Unsafe as C -import qualified Network.GRPC.Unsafe.Op as C +import Data.ByteString (ByteString) +import qualified Data.Map as M +import Foreign.Ptr (nullPtr) +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 -import qualified Network.GRPC.Unsafe.Metadata as C +import qualified Network.GRPC.Unsafe.ByteBuffer as C +import qualified Network.GRPC.Unsafe.Metadata as C -- | Wraps various gRPC state needed to run a server. data Server = Server {internalServer :: C.Server, serverCQ :: CompletionQueue, @@ -30,10 +35,10 @@ data Server = Server {internalServer :: C.Server, serverCQ :: CompletionQueue, -- | Configuration needed to start a server. There might be more fields that -- need to be added to this in the future. data ServerConfig = - ServerConfig {hostName :: Host, + ServerConfig {hostName :: Host, -- ^ Name of the host the server is running on. Not sure -- how this is used. Setting to "localhost" works fine in tests. - port :: Int, + port :: Int, -- ^ Port to listen for requests on. methodsToRegister :: [(MethodName, Host, GRPCMethodType)] -- ^ List of (method name, method host, method type) tuples @@ -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 diff --git a/tests/LowLevelTests.hs b/tests/LowLevelTests.hs index a8d0f48..5f01a80 100644 --- a/tests/LowLevelTests.hs +++ b/tests/LowLevelTests.hs @@ -1,13 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -module LowLevelTests where +module LowLevelTests (lowLevelTests) where -import Control.Concurrent.Async (withAsync, wait) -import Data.ByteString (ByteString) -import qualified Data.Map as M +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,85 +24,79 @@ 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" $ - withGRPC $ const $ return () +testGRPCBracket = grpcTest "Start/stop GRPC" nop testCompletionQueueCreateDestroy :: TestTree testCompletionQueueCreateDestroy = - testCase "No errors creating and destroying a CQ" $ withGRPC $ \grpc -> - withCompletionQueue grpc $ const (return ()) + grpcTest "Create/destroy completion queue" $ \grpc -> do + withCompletionQueue grpc nop testServerCreateDestroy :: TestTree testServerCreateDestroy = - testCase "No errors when starting and stopping a server" $ - withGRPC $ \grpc -> withServer grpc (ServerConfig "localhost" 50051 []) - (const $ return ()) + grpcTest "Server - start/stop" $ \grpc -> do + withServer grpc (ServerConfig "localhost" 50051 []) nop testClientCreateDestroy :: TestTree testClientCreateDestroy = - testCase "No errors when starting and stopping a client" $ - withGRPC $ \grpc -> withClient grpc (ClientConfig "localhost" 50051) - (const $ return ()) + grpcTest "Client - start/stop" $ \grpc -> do + withClient grpc (ClientConfig "localhost" 50051) nop -testPayloadLowLevelServer :: GRPC -> IO () -testPayloadLowLevelServer grpc = do +payloadLowLevelServer :: TestServer +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 () -testPayloadLowLevelClient grpc = +payloadLowLevelClient :: TestClient +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 () -testPayloadLowLevelClientUnregistered grpc = do +payloadLowLevelClientUnregistered :: TestClient +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 () -testPayloadLowLevelServerUnregistered grpc = do +payloadLowLevelServerUnregistered :: TestServer +payloadLowLevelServerUnregistered = TestServer $ \grpc -> do withServer grpc (ServerConfig "localhost" 50051 []) $ \server -> do result <- serverHandleNormalCall server 11 M.empty $ - \reqBody reqMeta -> return ("reply test", M.empty, - StatusDetails "details string") + \_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 - withGRPC $ \grpc -> do - withClient grpc (ClientConfig "localhost" 50051) $ \client -> do - method <- clientRegisterMethod client "/foo" "localhost" Normal - reqResult <- clientRegisteredRequest client method 1 "Hello" M.empty - reqResult @?= (Left GRPCIOTimeout) +testClientRequestNoServer = + 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 + reqResult @?= (Left GRPCIOTimeout) testServerAwaitNoClient :: TestTree testServerAwaitNoClient = testCase "server wait times out when no client " $ do @@ -126,39 +121,52 @@ testServerUnregisteredAwaitNoClient = Right _ -> return () testPayloadLowLevel :: TestTree -testPayloadLowLevel = testCase "LowLevel Haskell library request/response " $ do - withGRPC $ \grpc -> do - withAsync (testPayloadLowLevelServer grpc) $ \a1 -> do - withAsync (testPayloadLowLevelClient grpc) $ \a2 -> do - wait a1 - wait a2 +testPayloadLowLevel = + grpcTest "Client/Server - low-level (registered) request/response" $ + runClientServer payloadLowLevelClient payloadLowLevelServer testPayloadLowLevelUnregistered :: TestTree testPayloadLowLevelUnregistered = - testCase "LowLevel Haskell library unregistered request/response " $ do - withGRPC $ \grpc -> do - withAsync (testPayloadLowLevelServerUnregistered grpc) $ \a1 -> - withAsync (testPayloadLowLevelClientUnregistered grpc) $ \a2 -> do - wait a1 - wait a2 + grpcTest "Client/Server - low-level unregistered request/response" $ + runClientServer payloadLowLevelClientUnregistered payloadLowLevelServerUnregistered testWithServerCall :: TestTree testWithServerCall = - testCase "Creating and destroying a call: no errors. " $ - withGRPC $ \grpc -> do - let conf = ServerConfig "localhost" 50051 [] - withServer grpc conf $ \server -> do - result <- withServerCall server 1 $ const $ return $ Right () - result @?= Left GRPCIOTimeout + grpcTest "Server - Create/destroy call" $ \grpc -> do + let conf = ServerConfig "localhost" 50051 [] + withServer grpc conf $ \server -> do + result <- withServerCall server 1 $ const $ return $ Right () + result @?= Left GRPCIOTimeout testWithClientCall :: TestTree testWithClientCall = - testCase "Creating and destroying a client call: no errors. " $ - withGRPC $ \grpc -> do - let conf = ClientConfig "localhost" 50051 - withClient grpc conf $ \client -> do - result <- withClientCall client "foo" "localhost" 10 $ - const $ return $ Right () - case result of - Left err -> error $ show err - Right _ -> return () + grpcTest "Client - Create/destroy call" $ \grpc -> do + let conf = ClientConfig "localhost" 50051 + withClient grpc conf $ \client -> do + result <- withClientCall client "foo" "localhost" 10 $ + const $ return $ Right () + 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 diff --git a/tests/Properties.hs b/tests/Properties.hs index 7637bbe..395c038 100644 --- a/tests/Properties.hs +++ b/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 - -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] +import LowLevelTests +import Test.Tasty +import UnsafeTests main :: IO () -main = defaultMain allTests +main = defaultMain $ testGroup "GRPC Unit Tests" + [ unsafeTests + , lowLevelTests + ] diff --git a/tests/UnsafeTests.hs b/tests/UnsafeTests.hs new file mode 100644 index 0000000..98725c1 --- /dev/null +++ b/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