eeva/gRPC-haskell
1
0
Fork 0
mirror of https://github.com/unclechu/gRPC-haskell.git synced 2024-11-26 21:19:43 +01:00
Code Issues Projects Releases Wiki Activity

serverRequestCall: block until request received (#30)

Browse source 
* fix error for client timeouts

* registered calls: block until call received, simplify cleanup

* unregistered calls: block until request received

* Fix up tests
This commit is contained in:
Connor Clark 2016-06-22 10:41:14 -07:00
parent f6e244912a
commit ff73b5eb5a
11 changed files with 160 additions and 241 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
examples/echo/echo-server/Main.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
@ -13,9 +14,10 @@ import qualified Network.GRPC.LowLevel.Call.Unregistered as U
serverMeta :: MetadataMap
serverMeta = [("test_meta", "test_meta_value")]
handler :: U.ServerCall -> ByteString -> MetadataMap -> MethodName
handler :: U.ServerCall
-> ByteString
-> IO (ByteString, MetadataMap, StatusCode, StatusDetails)
handler _call reqBody _reqMeta _method = do
handler U.ServerCall{..} reqBody = do
--putStrLn $ "Got request for method: " ++ show method
--putStrLn $ "Got metadata: " ++ show reqMeta
return (reqBody, serverMeta, StatusOk, StatusDetails "")
@ -23,7 +25,7 @@ handler _call reqBody _reqMeta _method = do
unregMain :: IO ()
unregMain = withGRPC $ \grpc -> do
withServer grpc (ServerConfig "localhost" 50051 []) $ \server -> forever $ do
result <- U.serverHandleNormalCall server 15 serverMeta handler
result <- U.serverHandleNormalCall server serverMeta handler
case result of
Left x -> putStrLn $ "handle call result error: " ++ show x
Right _ -> return ()
@ -34,7 +36,7 @@ regMain = withGRPC $ \grpc -> do
withServer grpc (ServerConfig "localhost" 50051 methods) $ \server ->
forever $ do
let method = head (registeredMethods server)
result <- serverHandleNormalCall server method 15 serverMeta $
result <- serverHandleNormalCall server method serverMeta $
\_call reqBody _reqMeta -> return (reqBody, serverMeta, StatusOk,
StatusDetails "")
case result of
@ -44,7 +46,7 @@ regMain = withGRPC $ \grpc -> do
-- | loop to fork n times
regLoop :: Server -> RegisteredMethod -> IO ()
regLoop server method = forever $ do
result <- serverHandleNormalCall server method 15 serverMeta $
result <- serverHandleNormalCall server method serverMeta $
\_call reqBody _reqMeta -> return (reqBody, serverMeta, StatusOk,
StatusDetails "")
case result of

39
src/Network/GRPC/LowLevel/Call.hs
View file

@ -65,10 +65,9 @@ clientCallCancel cc = C.grpcCallCancel (unClientCall cc) C.reserved
-- the C state needed to respond to a registered call.
data ServerCall = ServerCall
{ unServerCall :: C.Call,
requestMetadataRecv :: Ptr C.MetadataArray,
optionalPayload :: Ptr C.ByteBuffer,
requestMetadataRecv :: MetadataMap,
optionalPayload :: Maybe ByteString,
parentPtr :: Maybe (Ptr C.Call),
callDeadlinePtr :: C.CTimeSpecPtr,
callDeadline :: TimeSpec
}
@ -76,24 +75,6 @@ serverCallCancel :: ServerCall -> C.StatusCode -> String -> IO ()
serverCallCancel sc code reason =
C.grpcCallCancelWithStatus (unServerCall sc) code reason C.reserved
serverCallGetMetadata :: ServerCall -> IO MetadataMap
serverCallGetMetadata ServerCall{..} = do
marray <- peek requestMetadataRecv
C.getAllMetadataArray marray
-- | Extract the client request body from the given call, if present. TODO: the
-- reason this returns @Maybe ByteString@ is because the gRPC library calls the
-- underlying out parameter "optional_payload". I am not sure exactly in what
-- cases it won't be present. The C++ library checks a has_request_payload_ bool
-- and passes in nullptr to request_registered_call if the bool is false, so we
-- may be able to do the payload present/absent check earlier.
serverCallGetPayload :: ServerCall -> IO (Maybe ByteString)
serverCallGetPayload ServerCall{..} = do
bb@(C.ByteBuffer rawPtr) <- peek optionalPayload
if rawPtr == nullPtr
then return Nothing
else Just <$> C.copyByteBufferToByteString bb
serverCallIsExpired :: ServerCall -> IO Bool
serverCallIsExpired sc = do
currTime <- getTime Monotonic
@ -110,24 +91,16 @@ debugClientCall = const $ return ()
debugServerCall :: ServerCall -> IO ()
#ifdef DEBUG
debugServerCall call@(ServerCall (C.Call ptr) _ _ _ _ _) = do
debugServerCall call@(ServerCall (C.Call ptr) _ _ _ _) = do
grpcDebug $ "debugServerCall(R): server call: " ++ (show ptr)
grpcDebug $ "debugServerCall(R): metadata ptr: "
++ show (requestMetadataRecv call)
metadataArr <- peek (requestMetadataRecv call)
metadata <- C.getAllMetadataArray metadataArr
grpcDebug $ "debugServerCall(R): metadata received: " ++ (show metadata)
grpcDebug $ "debugServerCall(R): payload ptr: " ++ show (optionalPayload call)
payload <- peek (optionalPayload call)
bs <- C.copyByteBufferToByteString payload
grpcDebug $ "debugServerCall(R): payload contents: " ++ show bs
forM_ (parentPtr call) $ \parentPtr' -> do
grpcDebug $ "debugServerCall(R): parent ptr: " ++ show parentPtr'
(C.Call parent) <- peek parentPtr'
grpcDebug $ "debugServerCall(R): parent: " ++ show parent
grpcDebug $ "debugServerCall(R): deadline ptr: " ++ show (callDeadline call)
timespec <- peek (callDeadlinePtr call)
grpcDebug $ "debugServerCall(R): deadline: " ++ show (C.timeSpec timespec)
#else
{-# INLINE debugServerCall #-}
debugServerCall = const $ return ()
@ -144,11 +117,5 @@ destroyServerCall call@ServerCall{..} = do
debugServerCall call
grpcDebug $ "Destroying server-side call object: " ++ show unServerCall
C.grpcCallDestroy unServerCall
grpcDebug $ "destroying metadata array: " ++ show requestMetadataRecv
C.metadataArrayDestroy requestMetadataRecv
grpcDebug $ "destroying optional payload" ++ show optionalPayload
C.destroyReceivingByteBuffer optionalPayload
grpcDebug $ "freeing parentPtr: " ++ show parentPtr
forM_ parentPtr free
grpcDebug $ "destroying deadline." ++ show callDeadline
C.timespecDestroy callDeadlinePtr

25
src/Network/GRPC/LowLevel/Call/Unregistered.hs
View file

@ -6,6 +6,8 @@ import Control.Monad
import Foreign.Marshal.Alloc (free)
import Foreign.Ptr (Ptr)
import Foreign.Storable (peek)
import System.Clock (TimeSpec)
import Network.GRPC.LowLevel.Call (Host (..), MethodName (..))
import Network.GRPC.LowLevel.GRPC (MetadataMap, grpcDebug)
import qualified Network.GRPC.Unsafe as C
@ -17,28 +19,17 @@ import qualified Network.GRPC.Unsafe.Op as C
-- call.
data ServerCall = ServerCall
{ unServerCall :: C.Call
, requestMetadataRecv :: Ptr C.MetadataArray
, requestMetadataRecv :: MetadataMap
, parentPtr :: Maybe (Ptr C.Call)
, callDetails :: C.CallDetails
, callDeadline :: TimeSpec
, callMethod :: MethodName
, callHost :: Host
}
serverCallCancel :: ServerCall -> C.StatusCode -> String -> IO ()
serverCallCancel sc code reason =
C.grpcCallCancelWithStatus (unServerCall sc) code reason C.reserved
serverCallGetMetadata :: ServerCall -> IO MetadataMap
serverCallGetMetadata ServerCall{..} = do
marray <- peek requestMetadataRecv
C.getAllMetadataArray marray
serverCallGetMethodName :: ServerCall -> IO MethodName
serverCallGetMethodName ServerCall{..} =
MethodName <$> C.callDetailsGetMethod callDetails
serverCallGetHost :: ServerCall -> IO Host
serverCallGetHost ServerCall{..} =
Host <$> C.callDetailsGetHost callDetails
debugServerCall :: ServerCall -> IO ()
#ifdef DEBUG
debugServerCall call@(ServerCall (C.Call ptr) _ _ _) = do
@ -66,9 +57,5 @@ destroyServerCall call@ServerCall{..} = do
debugServerCall call
grpcDebug $ "Destroying server-side call object: " ++ show unServerCall
C.grpcCallDestroy unServerCall
grpcDebug $ "destroying metadata array: " ++ show requestMetadataRecv
C.metadataArrayDestroy requestMetadataRecv
grpcDebug $ "freeing parentPtr: " ++ show parentPtr
forM_ parentPtr free
grpcDebug $ "destroying call details: " ++ show callDetails
C.destroyCallDetails callDetails

105
src/Network/GRPC/LowLevel/CompletionQueue.hs
View file

@ -34,6 +34,7 @@ import Control.Concurrent.STM (atomically, check)
import Control.Concurrent.STM.TVar (newTVarIO, readTVar,
writeTVar)
import Control.Exception (bracket)
import Control.Monad (liftM2)
import Data.IORef (newIORef)
import Data.List (intersperse)
import Foreign.Marshal.Alloc (free, malloc)
@ -51,6 +52,8 @@ import System.Timeout (timeout)
import Network.GRPC.LowLevel.Call
import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.CompletionQueue.Internal
import qualified Network.GRPC.Unsafe.ByteBuffer as C
import qualified Network.GRPC.Unsafe.Metadata as C
withCompletionQueue :: GRPC -> (CompletionQueue -> IO a) -> IO a
withCompletionQueue grpc = bracket (createCompletionQueue grpc)
@ -131,61 +134,69 @@ channelCreateCall
-- | Create the call object to handle a registered call.
serverRequestCall :: C.Server
-> CompletionQueue
-> TimeoutSeconds
-> RegisteredMethod
-> IO (Either GRPCIOError ServerCall)
serverRequestCall
server cq@CompletionQueue{..} timeLimit RegisteredMethod{..} =
withPermission Push cq $ do
-- NOTE: the below stuff is freed when we free the call we return.
deadlinePtr <- malloc
callPtr <- malloc
metadataArrayPtr <- C.metadataArrayCreate
metadataArray <- peek metadataArrayPtr
bbPtr <- malloc
tag <- newTag cq
grpcDebug $ "serverRequestCall(R): tag is " ++ show tag
callError <- C.grpcServerRequestRegisteredCall
server methodHandle callPtr deadlinePtr
metadataArray bbPtr unsafeCQ unsafeCQ tag
grpcDebug $ "serverRequestCall(R): callError: "
++ show callError
if callError /= C.CallOk
then do grpcDebug "serverRequestCall(R): callError. cleaning up"
failureCleanup deadlinePtr callPtr metadataArrayPtr bbPtr
return $ Left $ GRPCIOCallError callError
else do pluckResult <- pluck cq tag (Just timeLimit)
grpcDebug "serverRequestCall(R): finished pluck."
case pluckResult of
Left x -> do
grpcDebug "serverRequestCall(R): cleanup pluck err"
failureCleanup deadlinePtr callPtr metadataArrayPtr bbPtr
return $ Left x
Right () -> do
rawCall <- peek callPtr
deadline <- convertDeadline deadlinePtr
let assembledCall = ServerCall rawCall metadataArrayPtr
bbPtr Nothing deadlinePtr deadline
return $ Right assembledCall
--TODO: the gRPC library appears to hold onto these pointers for a random
-- amount of time, even after returning from the only call that uses them.
-- This results in malloc errors if
-- gRPC tries to modify them after we free them. To work around it,
-- we sleep for a while before freeing the objects. We should find a
-- permanent solution that's more robust.
where failureCleanup deadline callPtr metadataArrayPtr bbPtr = forkIO $ do
threadDelaySecs 30
grpcDebug "serverRequestCall(R): doing delayed cleanup."
C.timespecDestroy deadline
free callPtr
C.metadataArrayDestroy metadataArrayPtr
free bbPtr
convertDeadline deadline = do
server cq@CompletionQueue{..} RegisteredMethod{..} =
withPermission Push cq $
bracket (liftM2 (,) malloc malloc)
(\(p1,p2) -> free p1 >> free p2)
$ \(deadlinePtr, callPtr) ->
C.withByteBufferPtr $ \bbPtr ->
C.withMetadataArrayPtr $ \metadataArrayPtr -> do
metadataArray <- peek metadataArrayPtr
tag <- newTag cq
grpcDebug $ "serverRequestCall(R): tag is " ++ show tag
callError <- C.grpcServerRequestRegisteredCall
server methodHandle callPtr deadlinePtr
metadataArray bbPtr unsafeCQ unsafeCQ tag
grpcDebug $ "serverRequestCall(R): callError: "
++ show callError
if callError /= C.CallOk
then do grpcDebug "serverRequestCall(R): callError. cleaning up"
return $ Left $ GRPCIOCallError callError
else do pluckResult <- pluck cq tag Nothing
grpcDebug $ "serverRequestCall(R): finished pluck:"
++ show pluckResult
case pluckResult of
Left x -> do
grpcDebug "serverRequestCall(R): cleanup pluck err"
return $ Left x
Right () -> do
rawCall <- peek callPtr
deadline <- convertDeadline deadlinePtr
payload <- convertPayload bbPtr
meta <- convertMeta metadataArrayPtr
let assembledCall = ServerCall rawCall
meta
payload
Nothing
deadline
grpcDebug "serverRequestCall(R): About to return"
return $ Right assembledCall
where convertDeadline deadline = do
--gRPC gives us a deadline that is just a delta, so we convert it
--to a proper deadline.
deadline' <- C.timeSpec <$> peek deadline
now <- getTime Monotonic
return $ now + deadline'
convertPayload bbPtr = do
-- TODO: the reason this returns @Maybe ByteString@ is because the
-- gRPC library calls the underlying out parameter
-- "optional_payload". I am not sure exactly in what cases it
-- won't be present. The C++ library checks a
-- has_request_payload_ bool and passes in nullptr to
-- request_registered_call if the bool is false, so we
-- may be able to do the payload present/absent check earlier.
bb@(C.ByteBuffer rawPtr) <- peek bbPtr
if rawPtr == nullPtr
then return Nothing
else do bs <- C.copyByteBufferToByteString bb
return $ Just bs
convertMeta requestMetadataRecv = do
mArray <- peek requestMetadataRecv
metamap <- C.getAllMetadataArray mArray
return metamap
-- | Register the server's completion queue. Must be done before the server is
-- started.

1
src/Network/GRPC/LowLevel/CompletionQueue/Internal.hs
View file

@ -121,6 +121,7 @@ pluck cq@CompletionQueue{..} tag waitSeconds = do
eventToError :: C.Event -> (Either GRPCIOError a)
eventToError (C.Event C.QueueShutdown _ _) = Left GRPCIOShutdown
eventToError (C.Event C.QueueTimeout _ _) = Left GRPCIOTimeout
eventToError (C.Event C.OpComplete False _) = Left GRPCIOTimeout
eventToError _ = Left GRPCIOUnknownError
-- | Returns true iff the given grpc_event was a success.

86
src/Network/GRPC/LowLevel/CompletionQueue/Unregistered.hs
View file

@ -3,6 +3,7 @@
module Network.GRPC.LowLevel.CompletionQueue.Unregistered where
import Control.Concurrent (forkIO)
import Control.Exception (bracket)
import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Storable (peek)
import Network.GRPC.LowLevel.Call
@ -31,50 +32,45 @@ channelCreateCall chan parent mask cq@CompletionQueue{..} meth endpt deadline =
serverRequestCall :: C.Server
-> CompletionQueue
-> TimeoutSeconds
-> IO (Either GRPCIOError U.ServerCall)
serverRequestCall server cq@CompletionQueue{..} timeLimit =
withPermission Push cq $ do
callPtr <- malloc
grpcDebug $ "serverRequestCall: callPtr is " ++ show callPtr
callDetails <- C.createCallDetails
metadataArrayPtr <- C.metadataArrayCreate
metadataArray <- peek metadataArrayPtr
tag <- newTag cq
callError <- C.grpcServerRequestCall server callPtr callDetails
metadataArray unsafeCQ unsafeCQ tag
grpcDebug $ "serverRequestCall: callError was " ++ show callError
if callError /= C.CallOk
then do grpcDebug "serverRequestCall: got call error; cleaning up."
failureCleanup callPtr callDetails metadataArrayPtr
return $ Left $ GRPCIOCallError callError
else do pluckResult <- pluck cq tag (Just timeLimit)
grpcDebug $ "serverRequestCall: pluckResult was "
++ show pluckResult
case pluckResult of
Left x -> do
grpcDebug "serverRequestCall: pluck error; cleaning up."
failureCleanup callPtr callDetails
metadataArrayPtr
return $ Left x
Right () -> do
rawCall <- peek callPtr
let call = U.ServerCall rawCall
metadataArrayPtr
Nothing
callDetails
return $ Right call
serverRequestCall server cq@CompletionQueue{..} =
withPermission Push cq $
bracket malloc free $ \callPtr ->
C.withMetadataArrayPtr $ \metadataArrayPtr ->
C.withCallDetails $ \callDetails -> do
grpcDebug $ "serverRequestCall: callPtr is " ++ show callPtr
metadataArray <- peek metadataArrayPtr
tag <- newTag cq
callError <- C.grpcServerRequestCall server callPtr callDetails
metadataArray unsafeCQ unsafeCQ tag
grpcDebug $ "serverRequestCall: callError was " ++ show callError
if callError /= C.CallOk
then do grpcDebug "serverRequestCall: got call error; cleaning up."
return $ Left $ GRPCIOCallError callError
else do pluckResult <- pluck cq tag Nothing
grpcDebug $ "serverRequestCall: pluckResult was "
++ show pluckResult
case pluckResult of
Left x -> do
grpcDebug "serverRequestCall: pluck error."
return $ Left x
Right () -> do
rawCall <- peek callPtr
metadata <- C.getAllMetadataArray metadataArray
deadline <- getDeadline callDetails
method <- getMethod callDetails
host <- getHost callDetails
let call = U.ServerCall rawCall
metadata
Nothing
deadline
method
host
return $ Right call
--TODO: the gRPC library appears to hold onto these pointers for a random
-- amount of time, even after returning from the only call that uses them.
-- This results in malloc errors if
-- gRPC tries to modify them after we free them. To work around it,
-- 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
threadDelaySecs 30
grpcDebug "serverRequestCall: doing delayed cleanup."
free callPtr
C.destroyCallDetails callDetails
C.metadataArrayDestroy metadataArrayPtr
return ()
where getDeadline callDetails = do
C.timeSpec <$> C.callDetailsGetDeadline callDetails
getMethod callDetails =
MethodName <$> C.callDetailsGetMethod callDetails
getHost callDetails =
Host <$> C.callDetailsGetHost callDetails

19
src/Network/GRPC/LowLevel/Server.hs
View file

@ -126,18 +126,16 @@ serverRegisterMethod _ _ _ _ = error "Streaming methods not implemented yet."
-- method.
serverCreateCall :: Server
-> RegisteredMethod
-> TimeoutSeconds
-> IO (Either GRPCIOError ServerCall)
serverCreateCall Server{..} rm timeLimit =
serverRequestCall internalServer serverCQ timeLimit rm
serverCreateCall Server{..} rm =
serverRequestCall internalServer serverCQ rm
withServerCall :: Server
-> RegisteredMethod
-> TimeoutSeconds
-> (ServerCall -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a)
withServerCall server regmethod timeout f = do
createResult <- serverCreateCall server regmethod timeout
withServerCall server regmethod f = do
createResult <- serverCreateCall server regmethod
case createResult of
Left x -> return $ Left x
Right call -> f call `finally` logDestroy call
@ -177,22 +175,21 @@ type ServerHandler
-- | Wait for and then handle a normal (non-streaming) call.
serverHandleNormalCall :: Server
-> RegisteredMethod
-> TimeoutSeconds
-> MetadataMap
-- ^ Initial server metadata
-> ServerHandler
-> IO (Either GRPCIOError ())
serverHandleNormalCall s@Server{..} rm timeLimit initMeta f = do
withServerCall s rm timeLimit $ \call -> do
serverHandleNormalCall s@Server{..} rm initMeta f = do
withServerCall s rm $ \call -> do
grpcDebug "serverHandleNormalCall(R): starting batch."
debugServerCall call
payload <- serverCallGetPayload call
let payload = optionalPayload call
case payload of
--TODO: what should we do with an empty payload? Have the handler take
-- @Maybe ByteString@? Need to figure out when/why payload would be empty.
Nothing -> error "serverHandleNormalCall(R): payload empty."
Just requestBody -> do
requestMeta <- serverCallGetMetadata call
let requestMeta = requestMetadataRecv call
(respBody, trailingMeta, status, details) <- f call
requestBody
requestMeta

37
src/Network/GRPC/LowLevel/Server/Unregistered.hs
View file

@ -13,16 +13,15 @@ import Network.GRPC.LowLevel.Op (Op(..), OpR
import Network.GRPC.LowLevel.Server (Server (..))
import qualified Network.GRPC.Unsafe.Op as C
serverCreateCall :: Server -> TimeoutSeconds
-> IO (Either GRPCIOError ServerCall)
serverCreateCall Server{..} timeLimit =
serverRequestCall internalServer serverCQ timeLimit
serverCreateCall :: Server -> IO (Either GRPCIOError ServerCall)
serverCreateCall Server{..} =
serverRequestCall internalServer serverCQ
withServerCall :: Server -> TimeoutSeconds
withServerCall :: Server
-> (ServerCall -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a)
withServerCall server timeout f = do
createResult <- serverCreateCall server timeout
withServerCall server f = do
createResult <- serverCreateCall server
case createResult of
Left x -> return $ Left x
Right call -> f call `finally` logDestroy call
@ -52,37 +51,29 @@ serverOpsSendNormalResponse body metadata code details =
-- | A handler for an unregistered server call; bytestring arguments are the
-- request body and response body respectively.
type ServerHandler
= ServerCall -> ByteString -> MetadataMap -> MethodName
= ServerCall -> ByteString
-> IO (ByteString, MetadataMap, C.StatusCode, StatusDetails)
-- | Handle one unregistered call.
serverHandleNormalCall :: Server
-> TimeoutSeconds
-> MetadataMap -- ^ Initial server metadata.
-> ServerHandler
-> IO (Either GRPCIOError ())
serverHandleNormalCall s@Server{..} timeLimit srvMetadata f = do
withServerCall s timeLimit $ \call -> do
serverHandleNormalCall s@Server{..} srvMetadata f = do
withServerCall s $ \call@ServerCall{..} -> do
grpcDebug "serverHandleNormalCall(U): starting batch."
let recvOps = serverOpsGetNormalCall srvMetadata
call' = unServerCall call
opResults <- runOps call' serverCQ recvOps
opResults <- runOps unServerCall serverCQ recvOps
case opResults of
Left x -> do grpcDebug "serverHandleNormalCall(U): ops failed; aborting"
return $ Left x
Right [OpRecvMessageResult (Just body)] -> do
requestMeta <- serverCallGetMetadata call
grpcDebug $ "got client metadata: " ++ show requestMeta
methodName <- serverCallGetMethodName call
hostName <- serverCallGetHost call
grpcDebug $ "call_details host is: " ++ show hostName
(respBody, respMetadata, status, details) <- f call
body
requestMeta
methodName
grpcDebug $ "got client metadata: " ++ show requestMetadataRecv
grpcDebug $ "call_details host is: " ++ show callHost
(respBody, respMetadata, status, details) <- f call body
let respOps = serverOpsSendNormalResponse
respBody respMetadata status details
respOpsResults <- runOps call' serverCQ respOps
respOpsResults <- runOps unServerCall serverCQ respOps
case respOpsResults of
Left x -> do grpcDebug "serverHandleNormalCall(U): resp failed."
return $ Left x

4
src/Network/GRPC/Unsafe.chs
View file

@ -2,6 +2,7 @@
module Network.GRPC.Unsafe where
import Control.Exception (bracket)
import Control.Monad
import Foreign.C.Types
@ -46,6 +47,9 @@ deriving instance Show CallDetails
{#fun create_call_details as ^ {} -> `CallDetails'#}
{#fun destroy_call_details as ^ {`CallDetails'} -> `()'#}
withCallDetails :: (CallDetails -> IO a) -> IO a
withCallDetails = bracket createCallDetails destroyCallDetails
-- instance def adapted from
-- https://mail.haskell.org/pipermail/c2hs/2007-June/000800.html
instance Storable Call where

71
tests/LowLevelTests.hs
View file

@ -11,6 +11,7 @@ import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.Map as M
import Network.GRPC.LowLevel
import qualified Network.GRPC.LowLevel.Call.Unregistered as U
import qualified Network.GRPC.LowLevel.Client.Unregistered as U
import qualified Network.GRPC.LowLevel.Server.Unregistered as U
import Test.Tasty
@ -29,9 +30,6 @@ lowLevelTests = testGroup "Unit tests of low-level Haskell library"
, testClientCall
, testClientTimeoutNoServer
, testServerCreateDestroy
, testServerCall
, testServerTimeoutNoClient
, testWrongEndpoint
, testMixRegisteredUnregistered
, testPayload
, testPayloadUnregistered
@ -65,42 +63,12 @@ testClientTimeoutNoServer =
clientOnlyTest "request timeout when server DNE" $ \c -> do
rm <- clientRegisterMethod c "/foo" Normal
r <- clientRequest c rm 1 "Hello" mempty
r @?= Left GRPCIOUnknownError
r @?= Left GRPCIOTimeout
testServerCreateDestroy :: TestTree
testServerCreateDestroy =
serverOnlyTest "start/stop" [] nop
testServerCall :: TestTree
testServerCall =
serverOnlyTest "create/destroy call" [] $ \s -> do
r <- U.withServerCall s 1 $ const $ return $ Right ()
r @?= Left GRPCIOTimeout
testServerTimeoutNoClient :: TestTree
testServerTimeoutNoClient =
serverOnlyTest "wait timeout when client DNE" [("/foo", Normal)] $ \s -> do
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 1 mempty dummyHandler
r @?= Left GRPCIOTimeout
testWrongEndpoint :: TestTree
testWrongEndpoint =
csTest "client requests unknown endpoint" client server [("/foo", Normal)]
where
-- TODO: possibly factor out dead-simple client/server construction even
-- further
client c = do
rm <- clientRegisterMethod c "/bar" Normal
r <- clientRequest c rm 1 "Hello!" mempty
r @?= Left (GRPCIOBadStatusCode StatusDeadlineExceeded
(StatusDetails "Deadline Exceeded"))
server s = do
length (registeredMethods s) @?= 1
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 2 mempty dummyHandler
r @?= Left GRPCIOTimeout
testMixRegisteredUnregistered :: TestTree
testMixRegisteredUnregistered =
csTest "server uses unregistered calls to handle unknown endpoints"
@ -119,28 +87,21 @@ testMixRegisteredUnregistered =
clientRequest c rm2 1 "bad endpoint" mempty >>= do
checkReqRslt $ \NormalRequestResult{..} -> do
rspBody @?= ""
r3 <- clientRequest c rm1 1 "Hello" mempty
r3 @?= deadlineExceededStatus
return ()
server s = do
concurrently regThread unregThread
return ()
where regThread = do
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 2 dummyMeta $ \_ body _ -> do
r <- serverHandleNormalCall s rm dummyMeta $ \_ body _ -> do
body @?= "Hello"
return ("reply test", dummyMeta, StatusOk, StatusDetails "")
return ()
unregThread = do
r1 <- U.serverHandleNormalCall s 2 mempty $ \_ _ _ method -> do
method @?= "/bar"
r1 <- U.serverHandleNormalCall s mempty $ \call _ -> do
U.callMethod call @?= "/bar"
return ("", mempty, StatusOk,
StatusDetails "Wrong endpoint")
r2 <- U.serverHandleNormalCall s 2 mempty $ \_ _ _ method -> do
method @?= "/bar"
return ("", mempty, StatusNotFound,
StatusDetails "Wrong endpoint")
r2 @?= Left GRPCIOTimeout
return ()
-- TODO: There seems to be a race here (and in other client/server pairs, of
@ -166,7 +127,7 @@ testPayload =
server s = do
length (registeredMethods s) @?= 1
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 11 dummyMeta $ \_ reqBody reqMD -> do
r <- serverHandleNormalCall s rm dummyMeta $ \_ reqBody reqMD -> do
reqBody @?= "Hello!"
checkMD "Server metadata mismatch" clientMD reqMD
return ("reply test", dummyMeta, StatusOk,
@ -185,9 +146,9 @@ testServerCancel =
"Received RST_STREAM err=8"))
server s = do
let rm = head (registeredMethods s)
r <- serverHandleNormalCall s rm 10 mempty $ \c _ _ -> do
r <- serverHandleNormalCall s rm mempty $ \c _ _ -> do
serverCallCancel c StatusCancelled ""
return (mempty, mempty, StatusOk, "")
return (mempty, mempty, StatusCancelled, "")
r @?= Right ()
testPayloadUnregistered :: TestTree
@ -201,9 +162,9 @@ testPayloadUnregistered =
rspBody @?= "reply test"
details @?= "details string"
server s = do
r <- U.serverHandleNormalCall s 11 mempty $ \_ body _md meth -> do
r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{..} body -> do
body @?= "Hello!"
meth @?= "/foo"
callMethod @?= "/foo"
return ("reply test", mempty, StatusOk, "details string")
r @?= Right ()
@ -223,10 +184,12 @@ testGoaway =
lastResult == unavailableStatus
||
lastResult == deadlineExceededStatus
||
lastResult == Left GRPCIOTimeout
server s = do
let rm = head (registeredMethods s)
serverHandleNormalCall s rm 11 mempty dummyHandler
serverHandleNormalCall s rm 11 mempty dummyHandler
serverHandleNormalCall s rm mempty dummyHandler
serverHandleNormalCall s rm mempty dummyHandler
return ()
testSlowServer :: TestTree
@ -239,7 +202,7 @@ testSlowServer =
result @?= deadlineExceededStatus
server s = do
let rm = head (registeredMethods s)
serverHandleNormalCall s rm 1 mempty $ \_ _ _ -> do
serverHandleNormalCall s rm mempty $ \_ _ _ -> do
threadDelay (2*10^(6 :: Int))
return ("", mempty, StatusOk, StatusDetails "")
return ()
@ -254,7 +217,7 @@ testServerCallExpirationCheck =
return ()
server s = do
let rm = head (registeredMethods s)
serverHandleNormalCall s rm 5 mempty $ \c _ _ -> do
serverHandleNormalCall s rm mempty $ \c _ _ -> do
exp1 <- serverCallIsExpired c
assertBool "Call isn't expired when handler starts" $ not exp1
threadDelaySecs 1
@ -263,7 +226,7 @@ testServerCallExpirationCheck =
threadDelaySecs 3
exp3 <- serverCallIsExpired c
assertBool "Call is expired after 4 seconds" exp3
return ("", mempty, StatusDetails "")
return ("", mempty, StatusCancelled, StatusDetails "")
return ()
--------------------------------------------------------------------------------

2
tests/LowLevelTests/Op.hs
View file

@ -84,7 +84,7 @@ withClientServerUnaryCall grpc f = do
-- created. If later we want to send payloads or metadata, we'll need
-- to tweak this.
clientRes <- runOps (unClientCall cc) (clientCQ c) clientEmptySendOps
withServerCall s srm 10 $ \sc ->
withServerCall s srm $ \sc ->
f (c, s, cc, sc)
serverConf = (ServerConfig "localhost" 50051 [("/foo", Normal)])