Drop distinction between runServerOps and runClientOps

This commit is contained in:
Joel Stanley 2016-06-08 15:03:35 -05:00
parent 8069ebba07
commit 4780a0c8ed
5 changed files with 44 additions and 59 deletions

View file

@ -47,8 +47,6 @@ GRPC
, withClientCall , withClientCall
-- * Ops -- * Ops
, runClientOps
, runServerOps
, Op(..) , Op(..)
, OpRecvResult(..) , OpRecvResult(..)

View file

@ -153,12 +153,13 @@ clientRequest client@(Client{..}) rm@(RegisteredMethod{..})
Normal -> withClientCall client rm timeLimit $ \call -> do Normal -> withClientCall client rm timeLimit $ \call -> do
grpcDebug "clientRequest(R): created call." grpcDebug "clientRequest(R): created call."
debugClientCall call debugClientCall call
let call' = unClientCall call
-- NOTE: sendOps and recvOps *must* be in separate batches or -- NOTE: sendOps and recvOps *must* be in separate batches or
-- the client hangs when the server can't be reached. -- the client hangs when the server can't be reached.
let sendOps = [OpSendInitialMetadata meta let sendOps = [OpSendInitialMetadata meta
, OpSendMessage body , OpSendMessage body
, OpSendCloseFromClient] , OpSendCloseFromClient]
sendRes <- runClientOps call clientCQ sendOps timeLimit sendRes <- runOps call' clientCQ sendOps timeLimit
case sendRes of case sendRes of
Left x -> do grpcDebug "clientRequest(R) : batch error." Left x -> do grpcDebug "clientRequest(R) : batch error."
return $ Left x return $ Left x
@ -166,7 +167,7 @@ clientRequest client@(Client{..}) rm@(RegisteredMethod{..})
let recvOps = [OpRecvInitialMetadata, let recvOps = [OpRecvInitialMetadata,
OpRecvMessage, OpRecvMessage,
OpRecvStatusOnClient] OpRecvStatusOnClient]
recvRes <- runClientOps call clientCQ recvOps timeLimit recvRes <- runOps call' clientCQ recvOps timeLimit
case recvRes of case recvRes of
Left x -> do Left x -> do
grpcDebug "clientRequest(R): batch error." grpcDebug "clientRequest(R): batch error."

View file

@ -48,8 +48,7 @@ withClientCall client method timeout f = do
>> destroyClientCall c >> destroyClientCall c
-- | Makes a normal (non-streaming) request without needing to register a method -- | Makes a normal (non-streaming) request without needing to register a method
-- first. Probably only useful for testing. TODO: This is preliminary, like -- first. Probably only useful for testing.
-- 'clientRegisteredRequest'.
clientRequest :: Client clientRequest :: Client
-> MethodName -> MethodName
-- ^ Method name, e.g. "/foo" -- ^ Method name, e.g. "/foo"
@ -64,7 +63,7 @@ clientRequest client@Client{..} meth timeLimit body meta =
fmap join $ do fmap join $ do
withClientCall client meth timeLimit $ \call -> do withClientCall client meth timeLimit $ \call -> do
let ops = clientNormalRequestOps body meta let ops = clientNormalRequestOps body meta
results <- runClientOps call clientCQ ops timeLimit results <- runOps (unClientCall call) clientCQ ops timeLimit
grpcDebug "clientRequest(U): ops ran." grpcDebug "clientRequest(U): ops ran."
case results of case results of
Left x -> return $ Left x Left x -> return $ Left x

View file

@ -181,20 +181,36 @@ resultFromOpContext _ = do
grpcDebug "resultFromOpContext: saw non-result op type." grpcDebug "resultFromOpContext: saw non-result op type."
return Nothing return Nothing
--TODO: the list of 'Op's type is less specific than it could be. There are only -- | For a given call, run the given 'Op's on the given completion queue with
-- a few different sequences of 'Op's we will see in practice. Once we figure -- the given tag. Blocks until the ops are complete or the given number of
-- out what those are, we should create a more specific sum type. However, since -- seconds have elapsed. TODO: now that we distinguish between different types
-- ops can fail, the list of 'OpRecvResult' returned by 'runOps' can vary in -- of calls at the type level, we could try to limit the input 'Op's more
-- their contents and are perhaps less amenable to simplification. -- appropriately. E.g., we don't use an 'OpRecvInitialMetadata' when receiving a
-- In the meantime, from looking at the core tests, it looks like it is safe to -- registered call, because gRPC handles that for us.
-- say that we always get a GRPC_CALL_ERROR_TOO_MANY_OPERATIONS error if we use
-- the same 'Op' twice in the same batch, so we might want to change the list to -- TODO: the list of 'Op's type is less specific than it could be. There are
-- a set. I don't think order matters within a batch. Need to check. -- only a few different sequences of 'Op's we will see in practice. Once we
-- figure out what those are, we should create a more specific sum
-- type. However, since ops can fail, the list of 'OpRecvResult' returned by
-- 'runOps' can vary in their contents and are perhaps less amenable to
-- simplification. In the meantime, from looking at the core tests, it looks
-- like it is safe to say that we always get a
-- GRPC_CALL_ERROR_TOO_MANY_OPERATIONS error if we use the same 'Op' twice in
-- the same batch, so we might want to change the list to a set. I don't think
-- order matters within a batch. Need to check.
runOps :: C.Call runOps :: C.Call
-- ^ 'Call' that this batch is associated with. One call can be
-- associated with many batches.
-> CompletionQueue -> CompletionQueue
-- ^ Queue on which our tag will be placed once our ops are done
-- running.
-> [Op] -> [Op]
-- ^ The list of 'Op's to execute.
-> TimeoutSeconds -> TimeoutSeconds
-- ^ How long to block waiting for the tag to appear on the queue. If
-- we time out, the result of this action will be @CallBatchError
-- BatchTimeout@.
-> IO (Either GRPCIOError [OpRecvResult]) -> IO (Either GRPCIOError [OpRecvResult])
runOps call cq ops timeLimit = runOps call cq ops timeLimit =
let l = length ops in let l = length ops in
@ -218,35 +234,6 @@ runOps call cq ops timeLimit =
fmap (Right . catMaybes) $ mapM resultFromOpContext contexts fmap (Right . catMaybes) $ mapM resultFromOpContext contexts
Left err -> return $ Left err Left err -> return $ Left err
-- | For a given server call, run the given 'Op's on the given completion queue
-- with the given tag. Blocks until the ops are complete or the given number of
-- seconds have elapsed. TODO: now that we distinguish between different types
-- of calls at the type level, we could try to limit the input 'Op's more
-- appropriately. E.g., we don't use an 'OpRecvInitialMetadata' when receiving a
-- registered call, because gRPC handles that for us.
runServerOps :: ServerCall
-- ^ 'Call' that this batch is associated with. One call can be
-- associated with many batches.
-> CompletionQueue
-- ^ Queue on which our tag will be placed once our ops are done
-- running.
-> [Op]
-- ^ The list of 'Op's to execute.
-> TimeoutSeconds
-- ^ How long to block waiting for the tag to appear on the
-- queue. If we time out, the result of this action will be
-- @CallBatchError BatchTimeout@.
-> IO (Either GRPCIOError [OpRecvResult])
runServerOps = runOps . unServerCall
-- | Like 'runServerOps', but for client-side calls.
runClientOps :: ClientCall
-> CompletionQueue
-> [Op]
-> TimeoutSeconds
-> IO (Either GRPCIOError [OpRecvResult])
runClientOps = runOps . unClientCall
-- | If response status info is present in the given 'OpRecvResult's, returns -- | If response status info is present in the given 'OpRecvResult's, returns
-- a tuple of trailing metadata, status code, and status details. -- a tuple of trailing metadata, status code, and status details.
extractStatusInfo :: [OpRecvResult] extractStatusInfo :: [OpRecvResult]

View file

@ -217,7 +217,7 @@ serverHandleNormalCall s@Server{..} rm timeLimit srvMetadata f = do
let status = C.GrpcStatusOk let status = C.GrpcStatusOk
let respOps = serverOpsSendNormalRegisteredResponse let respOps = serverOpsSendNormalRegisteredResponse
respBody initMeta trailingMeta status details respBody initMeta trailingMeta status details
respOpsResults <- runServerOps call serverCQ respOps timeLimit respOpsResults <- runOps (unServerCall call) serverCQ respOps timeLimit
grpcDebug "serverHandleNormalCall(R): finished response ops." grpcDebug "serverHandleNormalCall(R): finished response ops."
case respOpsResults of case respOpsResults of
Left x -> return $ Left x Left x -> return $ Left x