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

Prelim cleanup and reorg
This commit is contained in:
Joel Stanley 2016-05-25 17:27:21 -07:00
commit e039adc2b7
9 changed files with 410 additions and 389 deletions

View File

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

View File

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

View File

@ -6,8 +6,8 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Network.GRPC.LowLevel.CompletionQueue ( module Network.GRPC.LowLevel.CompletionQueue
CompletionQueue ( CompletionQueue
, withCompletionQueue , withCompletionQueue
, createCompletionQueue , createCompletionQueue
, shutdownCompletionQueue , shutdownCompletionQueue
@ -16,33 +16,35 @@ module Network.GRPC.LowLevel.CompletionQueue (
, channelCreateRegisteredCall , channelCreateRegisteredCall
, channelCreateCall , channelCreateCall
, TimeoutSeconds , TimeoutSeconds
, eventSuccess , isEventSuccessful
, serverRegisterCompletionQueue , serverRegisterCompletionQueue
, serverShutdownAndNotify , serverShutdownAndNotify
, serverRequestRegisteredCall , serverRequestRegisteredCall
, serverRequestCall , serverRequestCall
, newTag , newTag
) where )
where
import Control.Concurrent (forkIO, threadDelay) 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) readTVar, writeTVar)
import Control.Exception (bracket) import Control.Exception (bracket)
import Data.IORef (IORef, newIORef, atomicModifyIORef') import Data.IORef (IORef, atomicModifyIORef',
newIORef)
import Data.List (intersperse) import Data.List (intersperse)
import Foreign.Marshal.Alloc (malloc, free) import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Ptr (nullPtr, plusPtr) import Foreign.Ptr (nullPtr, plusPtr)
import Foreign.Storable (peek) import Foreign.Storable (peek)
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.Constants 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.Metadata as C
import qualified Network.GRPC.Unsafe.Op as C
import qualified Network.GRPC.Unsafe.Time as C
import System.Timeout (timeout) 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 -- NOTE: the concurrency requirements for a CompletionQueue are a little
-- complicated. There are two read operations: next and pluck. We can either -- 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 (C.Event C.QueueTimeout _ _) = Left GRPCIOTimeout
eventToError _ = Left GRPCIOUnknownError 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 -- | 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 -- 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 C.withDeadlineSeconds waitSeconds $ \deadline -> do
ev <- C.grpcCompletionQueuePluck unsafeCQ tag deadline C.reserved ev <- C.grpcCompletionQueuePluck unsafeCQ tag deadline C.reserved
grpcDebug $ "pluck: finished. Event: " ++ show ev 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 -- 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 -- 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) atomically $ readTVar currentPluckers >>= \x -> check (x == 0)
--drain the queue --drain the queue
C.grpcCompletionQueueShutdown unsafeCQ C.grpcCompletionQueueShutdown unsafeCQ
loopRes <- timeout (5*10^6) drainLoop loopRes <- timeout (5*10^(6::Int)) drainLoop
case loopRes of case loopRes of
Nothing -> return $ Left GRPCIOShutdownFailure Nothing -> return $ Left GRPCIOShutdownFailure
Just () -> C.grpcCompletionQueueDestroy unsafeCQ >> return (Right ()) Just () -> C.grpcCompletionQueueDestroy unsafeCQ >> return (Right ())
@ -221,11 +222,6 @@ shutdownCompletionQueue (CompletionQueue{..}) = do
C.QueueTimeout -> drainLoop C.QueueTimeout -> drainLoop
C.OpComplete -> 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 channelCreateRegisteredCall :: C.Channel -> C.Call -> C.PropagationMask
-> CompletionQueue -> C.CallHandle -> CompletionQueue -> C.CallHandle
-> C.CTimeSpecPtr -> IO (Either GRPCIOError Call) -> C.CTimeSpecPtr -> IO (Either GRPCIOError Call)
@ -290,7 +286,7 @@ serverRequestRegisteredCall
return $ Right assembledCall return $ Right assembledCall
-- TODO: see TODO for failureCleanup in serverRequestCall. -- TODO: see TODO for failureCleanup in serverRequestCall.
where failureCleanup deadline callPtr metadataArrayPtr bbPtr = forkIO $ do where failureCleanup deadline callPtr metadataArrayPtr bbPtr = forkIO $ do
threadDelay (30*10^6) threadDelaySecs 30
grpcDebug "serverRequestRegisteredCall: doing delayed cleanup." grpcDebug "serverRequestRegisteredCall: doing delayed cleanup."
C.timespecDestroy deadline C.timespecDestroy deadline
free callPtr free callPtr
@ -340,7 +336,7 @@ serverRequestCall server cq@CompletionQueue{..} timeLimit =
-- we sleep for a while before freeing the objects. We should find a -- we sleep for a while before freeing the objects. We should find a
-- permanent solution that's more robust. -- permanent solution that's more robust.
where failureCleanup callPtr callDetails metadataArrayPtr = forkIO $ do where failureCleanup callPtr callDetails metadataArrayPtr = forkIO $ do
threadDelay (30*10^6) threadDelaySecs 30
grpcDebug "serverRequestCall: doing delayed cleanup." grpcDebug "serverRequestCall: doing delayed cleanup."
free callPtr free callPtr
C.destroyCallDetails callDetails C.destroyCallDetails callDetails
@ -356,3 +352,6 @@ serverRegisterCompletionQueue server CompletionQueue{..} =
serverShutdownAndNotify :: C.Server -> CompletionQueue -> C.Tag -> IO () serverShutdownAndNotify :: C.Server -> CompletionQueue -> C.Tag -> IO ()
serverShutdownAndNotify server CompletionQueue{..} tag = serverShutdownAndNotify server CompletionQueue{..} tag =
C.grpcServerShutdownAndNotify server unsafeCQ tag C.grpcServerShutdownAndNotify server unsafeCQ tag
threadDelaySecs :: Int -> IO ()
threadDelaySecs = threadDelay . (* 10^(6::Int))

View File

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

View File

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

View File

@ -12,12 +12,17 @@ import Foreign.Storable (peek)
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.Op 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.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 Network.GRPC.LowLevel.Op
import qualified Network.GRPC.Unsafe.ByteBuffer as C import qualified Network.GRPC.Unsafe.ByteBuffer as C
@ -199,7 +204,7 @@ serverHandleNormalRegisteredCall :: Server
-- metadata and returns a response body and -- metadata and returns a response body and
-- metadata. -- metadata.
-> IO (Either GRPCIOError ()) -> 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. -- 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 -- 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 -- 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. -- | Handle one unregistered call.
serverHandleNormalCall :: Server -> TimeoutSeconds serverHandleNormalCall :: Server -> TimeoutSeconds
-> MetadataMap -> MetadataMap
-- ^ Initial metadata. -- ^ Initial server metadata.
-> (ByteString -> MetadataMap -> (ByteString -> MetadataMap
-> IO (ByteString, MetadataMap, StatusDetails)) -> IO (ByteString, MetadataMap, StatusDetails))
-- ^ Handler function takes a request body and -- ^ Handler function takes a request body and
-- metadata and returns a response body and metadata. -- metadata and returns a response body and metadata.
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverHandleNormalCall s@Server{..} timeLimit initMetadata f = do serverHandleNormalCall s@Server{..} timeLimit srvMetadata f = do
withServerCall s timeLimit $ \call -> do withServerCall s timeLimit $ \call -> do
grpcDebug "serverHandleNormalCall: starting batch." grpcDebug "serverHandleNormalCall: starting batch."
let recvOps = serverOpsGetNormalCall initMetadata let recvOps = serverOpsGetNormalCall srvMetadata
opResults <- runOps call serverCQ recvOps timeLimit opResults <- runOps call serverCQ recvOps timeLimit
case opResults of case opResults of
Left x -> return $ Left x Left x -> return $ Left x
@ -255,3 +260,6 @@ serverHandleNormalCall s@Server{..} timeLimit initMetadata f = do
Right _ -> grpcDebug "serverHandleNormalCall: ops done." Right _ -> grpcDebug "serverHandleNormalCall: ops done."
>> return (Right ()) >> return (Right ())
x -> error $ "impossible pattern match: " ++ show x x -> error $ "impossible pattern match: " ++ show x
_nowarn_unused :: a
_nowarn_unused = undefined threadDelay

View File

@ -1,13 +1,14 @@
{-# LANGUAGE OverloadedStrings #-} {-# 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 Data.ByteString (ByteString)
import qualified Data.Map as M import qualified Data.Map as M
import Network.GRPC.LowLevel import Network.GRPC.LowLevel
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit ((@?=), testCase) import Test.Tasty.HUnit as HU (testCase, (@?=))
lowLevelTests :: TestTree lowLevelTests :: TestTree
lowLevelTests = testGroup "Unit tests of low-level Haskell library" lowLevelTests = testGroup "Unit tests of low-level Haskell library"
@ -23,81 +24,75 @@ lowLevelTests = testGroup "Unit tests of low-level Haskell library"
, testPayloadLowLevelUnregistered , testPayloadLowLevelUnregistered
] ]
dummyMeta :: M.Map ByteString ByteString
dummyMeta = M.fromList [("foo","bar")]
testGRPCBracket :: TestTree testGRPCBracket :: TestTree
testGRPCBracket = testCase "No errors starting and stopping GRPC" $ testGRPCBracket = grpcTest "Start/stop GRPC" nop
withGRPC $ const $ return ()
testCompletionQueueCreateDestroy :: TestTree testCompletionQueueCreateDestroy :: TestTree
testCompletionQueueCreateDestroy = 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 :: TestTree
testServerCreateDestroy = 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 :: TestTree
testClientCreateDestroy = 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)]) let conf = (ServerConfig "localhost" 50051 [("/foo", "localhost", Normal)])
withServer grpc conf $ \server -> do withServer grpc conf $ \server -> do
let method = head (registeredMethods server) let method = head (registeredMethods server)
result <- serverHandleNormalRegisteredCall server method 11 M.empty $ result <- serverHandleNormalRegisteredCall server method 11 M.empty $
\reqBody reqMeta -> \_reqBody _reqMeta ->
return ("reply test", dummyMeta, dummyMeta, return ("reply test", dummyMeta, dummyMeta,
StatusDetails "details string") StatusDetails "details string")
case result of case result of
Left err -> error $ show err Left err -> error $ show err
Right _ -> return () Right _ -> return ()
testPayloadLowLevelClient :: GRPC -> IO () payloadLowLevelClient :: TestClient
testPayloadLowLevelClient grpc = payloadLowLevelClient = TestClient $ \grpc ->
withClient grpc (ClientConfig "localhost" 50051) $ \client -> do withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
method <- clientRegisterMethod client "/foo" "localhost" Normal method <- clientRegisterMethod client "/foo" "localhost" Normal
putStrLn "registered method on client." putStrLn "registered method on client."
reqResult <- clientRegisteredRequest client method 10 "Hello!" M.empty reqResult <- clientRegisteredRequest client method 10 "Hello!" M.empty
case reqResult of case reqResult of
Left x -> error $ "Client got error: " ++ show x 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" details @?= "details string"
respBody @?= "reply test" respBody @?= "reply test"
respCode @?= GrpcStatusOk respCode @?= GrpcStatusOk
testPayloadLowLevelClientUnregistered :: GRPC -> IO () payloadLowLevelClientUnregistered :: TestClient
testPayloadLowLevelClientUnregistered grpc = do payloadLowLevelClientUnregistered = TestClient $ \grpc -> do
withClient grpc (ClientConfig "localhost" 50051) $ \client -> do withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
reqResult <- clientRequest client "/foo" "localhost" 10 "Hello!" M.empty reqResult <- clientRequest client "/foo" "localhost" 10 "Hello!" M.empty
case reqResult of case reqResult of
Left x -> error $ "Client got error: " ++ show x Left x -> error $ "Client got error: " ++ show x
Right (NormalRequestResult Right (NormalRequestResult
respBody initMeta trailingMeta respCode details) -> do respBody _initMeta _trailingMeta respCode details) -> do
respBody @?= "reply test" respBody @?= "reply test"
respCode @?= GrpcStatusOk respCode @?= GrpcStatusOk
details @?= "details string" details @?= "details string"
testPayloadLowLevelServerUnregistered :: GRPC -> IO () payloadLowLevelServerUnregistered :: TestServer
testPayloadLowLevelServerUnregistered grpc = do payloadLowLevelServerUnregistered = TestServer $ \grpc -> do
withServer grpc (ServerConfig "localhost" 50051 []) $ \server -> do withServer grpc (ServerConfig "localhost" 50051 []) $ \server -> do
result <- serverHandleNormalCall server 11 M.empty $ result <- serverHandleNormalCall server 11 M.empty $
\reqBody reqMeta -> return ("reply test", M.empty, \_reqBody _reqMeta -> return ("reply test", M.empty,
StatusDetails "details string") StatusDetails "details string")
case result of case result of
Left x -> error $ show x Left x -> error $ show x
Right _ -> return () Right _ -> return ()
testClientRequestNoServer :: TestTree 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 withClient grpc (ClientConfig "localhost" 50051) $ \client -> do
method <- clientRegisterMethod client "/foo" "localhost" Normal method <- clientRegisterMethod client "/foo" "localhost" Normal
reqResult <- clientRegisteredRequest client method 1 "Hello" M.empty reqResult <- clientRegisteredRequest client method 1 "Hello" M.empty
@ -126,26 +121,18 @@ testServerUnregisteredAwaitNoClient =
Right _ -> return () Right _ -> return ()
testPayloadLowLevel :: TestTree 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 :: TestTree
testPayloadLowLevelUnregistered = 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 :: TestTree
testWithServerCall = testWithServerCall =
testCase "Creating and destroying a call: no errors. " $ grpcTest "Server - Create/destroy call" $ \grpc -> do
withGRPC $ \grpc -> do
let conf = ServerConfig "localhost" 50051 [] let conf = ServerConfig "localhost" 50051 []
withServer grpc conf $ \server -> do withServer grpc conf $ \server -> do
result <- withServerCall server 1 $ const $ return $ Right () result <- withServerCall server 1 $ const $ return $ Right ()
@ -153,8 +140,7 @@ testWithServerCall =
testWithClientCall :: TestTree testWithClientCall :: TestTree
testWithClientCall = 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 let conf = ClientConfig "localhost" 50051
withClient grpc conf $ \client -> do withClient grpc conf $ \client -> do
result <- withClientCall client "foo" "localhost" 10 $ result <- withClientCall client "foo" "localhost" 10 $
@ -162,3 +148,25 @@ testWithClientCall =
case result of case result of
Left err -> error $ show err Left err -> error $ show err
Right _ -> return () 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

View File

@ -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 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 :: IO ()
main = defaultMain allTests main = defaultMain $ testGroup "GRPC Unit Tests"
[ unsafeTests
, lowLevelTests
]

230
tests/UnsafeTests.hs Normal file
View File

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