mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2025-03-27 08:05:19 +01:00
190 lines
8.8 KiB
Haskell
190 lines
8.8 KiB
Haskell
-- | Unlike most of the other internal low-level modules, we don't export
|
|
-- everything here. There are several things in here that, if accessed, could
|
|
-- cause race conditions, so we only expose functions that are thread safe.
|
|
-- However, some of the functions we export here can cause memory leaks if used
|
|
-- improperly.
|
|
--
|
|
-- When definition operations which pertain to calls, this module only provides
|
|
-- definitions for registered calls; for unregistered variants, see
|
|
-- `Network.GRPC.LowLevel.CompletionQueue.Unregistered`. Type definitions and
|
|
-- implementation details to both are kept in
|
|
-- `Network.GRPC.LowLevel.CompletionQueue.Internal`.
|
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Network.GRPC.LowLevel.CompletionQueue
|
|
( CompletionQueue
|
|
, withCompletionQueue
|
|
, createCompletionQueue
|
|
, shutdownCompletionQueue
|
|
, pluck
|
|
, startBatch
|
|
, channelCreateCall
|
|
, TimeoutSeconds
|
|
, isEventSuccessful
|
|
, serverRegisterCompletionQueue
|
|
, serverShutdownAndNotify
|
|
, serverRequestCall
|
|
, newTag
|
|
)
|
|
where
|
|
|
|
import Control.Concurrent (forkIO)
|
|
import Control.Concurrent.STM (atomically, check)
|
|
import Control.Concurrent.STM.TVar (newTVarIO, readTVar,
|
|
writeTVar)
|
|
import Control.Exception (bracket)
|
|
import Data.IORef (newIORef)
|
|
import Data.List (intersperse)
|
|
import Foreign.Marshal.Alloc (free, malloc)
|
|
import Foreign.Ptr (nullPtr)
|
|
import Foreign.Storable (peek)
|
|
import qualified Network.GRPC.Unsafe as C
|
|
import qualified Network.GRPC.Unsafe.Constants as C
|
|
import qualified Network.GRPC.Unsafe.Metadata as C
|
|
import qualified Network.GRPC.Unsafe.Op as C
|
|
import qualified Network.GRPC.Unsafe.Time as C
|
|
import System.Timeout (timeout)
|
|
|
|
import Network.GRPC.LowLevel.Call
|
|
import Network.GRPC.LowLevel.GRPC
|
|
import Network.GRPC.LowLevel.CompletionQueue.Internal
|
|
|
|
withCompletionQueue :: GRPC -> (CompletionQueue -> IO a) -> IO a
|
|
withCompletionQueue grpc = bracket (createCompletionQueue grpc)
|
|
shutdownCompletionQueue
|
|
|
|
createCompletionQueue :: GRPC -> IO CompletionQueue
|
|
createCompletionQueue _ = do
|
|
unsafeCQ <- C.grpcCompletionQueueCreate C.reserved
|
|
currentPluckers <- newTVarIO 0
|
|
currentPushers <- newTVarIO 0
|
|
shuttingDown <- newTVarIO False
|
|
nextTag <- newIORef minBound
|
|
return $ CompletionQueue{..}
|
|
|
|
-- 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
|
|
-- case, switch these to 'Maybe'.
|
|
-- | Very simple wrapper around 'grpcCallStartBatch'. Throws 'GRPCIOShutdown'
|
|
-- without calling 'grpcCallStartBatch' if the queue is shutting down.
|
|
-- Throws 'CallError' if 'grpcCallStartBatch' returns a non-OK code.
|
|
startBatch :: CompletionQueue -> C.Call -> C.OpArray -> Int -> C.Tag
|
|
-> IO (Either GRPCIOError ())
|
|
startBatch cq@CompletionQueue{..} call opArray opArraySize tag =
|
|
withPermission Push cq $ fmap throwIfCallError $ do
|
|
grpcDebug $ "startBatch: calling grpc_call_start_batch with pointers: "
|
|
++ show call ++ " " ++ show opArray
|
|
res <- C.grpcCallStartBatch call opArray opArraySize tag C.reserved
|
|
grpcDebug "startBatch: grpc_call_start_batch call returned."
|
|
return res
|
|
|
|
|
|
-- | Shuts down the completion queue. See the comment above 'CompletionQueue'
|
|
-- for the strategy we use to ensure that no one tries to use the
|
|
-- queue after we begin the shutdown process. Errors with
|
|
-- 'GRPCIOShutdownFailure' if the queue can't be shut down within 5 seconds.
|
|
shutdownCompletionQueue :: CompletionQueue -> IO (Either GRPCIOError ())
|
|
shutdownCompletionQueue (CompletionQueue{..}) = do
|
|
atomically $ writeTVar shuttingDown True
|
|
atomically $ readTVar currentPushers >>= \x -> check (x == 0)
|
|
atomically $ readTVar currentPluckers >>= \x -> check (x == 0)
|
|
--drain the queue
|
|
C.grpcCompletionQueueShutdown unsafeCQ
|
|
loopRes <- timeout (5*10^(6::Int)) drainLoop
|
|
grpcDebug $ "Got CQ loop shutdown result of: " ++ show loopRes
|
|
case loopRes of
|
|
Nothing -> return $ Left GRPCIOShutdownFailure
|
|
Just () -> C.grpcCompletionQueueDestroy unsafeCQ >> return (Right ())
|
|
|
|
where drainLoop :: IO ()
|
|
drainLoop = do
|
|
grpcDebug "drainLoop: before next() call"
|
|
ev <- C.withDeadlineSeconds 1 $ \deadline ->
|
|
C.grpcCompletionQueueNext unsafeCQ deadline C.reserved
|
|
grpcDebug $ "drainLoop: next() call got " ++ show ev
|
|
case (C.eventCompletionType ev) of
|
|
C.QueueShutdown -> return ()
|
|
C.QueueTimeout -> drainLoop
|
|
C.OpComplete -> drainLoop
|
|
|
|
channelCreateCall :: C.Channel
|
|
-> C.Call
|
|
-> C.PropagationMask
|
|
-> CompletionQueue
|
|
-> C.CallHandle
|
|
-> C.CTimeSpecPtr
|
|
-> IO (Either GRPCIOError ClientCall)
|
|
channelCreateCall
|
|
chan parent mask cq@CompletionQueue{..} handle deadline =
|
|
withPermission Push cq $ do
|
|
grpcDebug $ "channelCreateCall: call with "
|
|
++ concat (intersperse " " [show chan, show parent, show mask,
|
|
show unsafeCQ, show handle,
|
|
show deadline])
|
|
call <- C.grpcChannelCreateRegisteredCall chan parent mask unsafeCQ
|
|
handle deadline C.reserved
|
|
return $ Right $ ClientCall call
|
|
|
|
-- | 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
|
|
-- TODO: Is gRPC supposed to populate this deadline?
|
|
-- NOTE: the below stuff is freed when we free the call we return.
|
|
deadline <- C.secondsToDeadline timeLimit
|
|
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 deadline
|
|
metadataArray bbPtr unsafeCQ unsafeCQ tag
|
|
grpcDebug $ "serverRequestCall(R): callError: "
|
|
++ show callError
|
|
if callError /= C.CallOk
|
|
then do grpcDebug "serverRequestCall(R): callError. cleaning up"
|
|
failureCleanup deadline 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 deadline callPtr metadataArrayPtr bbPtr
|
|
return $ Left x
|
|
Right () -> do
|
|
rawCall <- peek callPtr
|
|
let assembledCall = ServerCall rawCall metadataArrayPtr
|
|
bbPtr Nothing 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
|
|
|
|
-- | Register the server's completion queue. Must be done before the server is
|
|
-- started.
|
|
serverRegisterCompletionQueue :: C.Server -> CompletionQueue -> IO ()
|
|
serverRegisterCompletionQueue server CompletionQueue{..} =
|
|
C.grpcServerRegisterCompletionQueue server unsafeCQ C.reserved
|
|
|
|
serverShutdownAndNotify :: C.Server -> CompletionQueue -> C.Tag -> IO ()
|
|
serverShutdownAndNotify server CompletionQueue{..} tag =
|
|
C.grpcServerShutdownAndNotify server unsafeCQ tag
|