Fix async exception handling (#86)

Previously, grpc-haskell used a lot of code in the form of

```
do x <- acquireResource
   f x `finally` releaseResource x
```

This is not safe since you can get killed after acquiring the resource
but before installing the exception handler via `finally`. We have
seen various gRPC assertion errors and crashes on shutdown when this
got triggered.
This commit is contained in:
Moritz Kiefer 2019-08-22 17:55:33 +02:00 committed by Gabriel Gonzalez
parent a26497c82c
commit 35163c3c18
4 changed files with 36 additions and 24 deletions

View file

@ -11,7 +11,7 @@
-- `Network.GRPC.LowLevel.Client.Unregistered`. -- `Network.GRPC.LowLevel.Client.Unregistered`.
module Network.GRPC.LowLevel.Client where module Network.GRPC.LowLevel.Client where
import Control.Exception (bracket, finally) import Control.Exception (bracket)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -222,9 +222,12 @@ withClientCallParent :: Client
-> (ClientCall -> IO (Either GRPCIOError a)) -> (ClientCall -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withClientCallParent cl rm tm parent f = withClientCallParent cl rm tm parent f =
clientCreateCallParent cl rm tm parent >>= \case bracket (clientCreateCallParent cl rm tm parent) cleanup $ \case
Left e -> return (Left e) Left e -> return (Left e)
Right c -> f c `finally` do Right c -> f c
where
cleanup (Left _) = pure ()
cleanup (Right c) = do
debugClientCall c debugClientCall c
grpcDebug "withClientCall(R): destroying." grpcDebug "withClientCall(R): destroying."
destroyClientCall c destroyClientCall c

View file

@ -1,10 +1,11 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Network.GRPC.LowLevel.Client.Unregistered where module Network.GRPC.LowLevel.Client.Unregistered where
import Control.Arrow import Control.Arrow
import Control.Exception (finally) import Control.Exception (bracket)
import Control.Monad (join) import Control.Monad (join)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Foreign.Ptr (nullPtr) import Foreign.Ptr (nullPtr)
@ -40,13 +41,15 @@ withClientCall :: Client
-> TimeoutSeconds -> TimeoutSeconds
-> (ClientCall -> IO (Either GRPCIOError a)) -> (ClientCall -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withClientCall client method timeout f = do withClientCall client method timeout f =
createResult <- clientCreateCall client method timeout bracket (clientCreateCall client method timeout) cleanup $ \case
case createResult of
Left x -> return $ Left x Left x -> return $ Left x
Right call -> f call `finally` logDestroy call Right call -> f call
where logDestroy c = grpcDebug "withClientCall(U): destroying." where
>> destroyClientCall c cleanup (Left _) = pure ()
cleanup (Right call) = do
grpcDebug "withClientCall(U): destroying."
destroyClientCall call
-- | 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. -- first. Probably only useful for testing.

View file

@ -26,7 +26,7 @@ import Control.Concurrent.STM.TVar (TVar
, writeTVar , writeTVar
, readTVarIO , readTVarIO
, newTVarIO) , newTVarIO)
import Control.Exception (bracket, finally) import Control.Exception (bracket)
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
@ -343,13 +343,16 @@ withServerCall :: Server
-> (ServerCall (MethodPayload mt) -> IO (Either GRPCIOError a)) -> (ServerCall (MethodPayload mt) -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withServerCall s rm f = withServerCall s rm f =
serverCreateCall s rm >>= \case bracket (serverCreateCall s rm) cleanup $ \case
Left e -> return (Left e) Left e -> return (Left e)
Right c -> do Right c -> do
debugServerCall c debugServerCall c
f c `finally` do f c
grpcDebug "withServerCall(R): destroying." where
destroyServerCall c cleanup (Left _) = pure ()
cleanup (Right c) = do
grpcDebug "withServerCall(R): destroying."
destroyServerCall c
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- serverReader (server side of client streaming mode) -- serverReader (server side of client streaming mode)

View file

@ -3,7 +3,7 @@
module Network.GRPC.LowLevel.Server.Unregistered where module Network.GRPC.LowLevel.Server.Unregistered where
import Control.Exception (finally) import Control.Exception (bracket, finally, mask)
import Control.Monad import Control.Monad
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -30,9 +30,12 @@ withServerCall :: Server
-> (ServerCall -> IO (Either GRPCIOError a)) -> (ServerCall -> IO (Either GRPCIOError a))
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
withServerCall s f = withServerCall s f =
serverCreateCall s >>= \case bracket (serverCreateCall s) cleanup $ \case
Left e -> return (Left e) Left e -> return (Left e)
Right c -> f c `finally` do Right c -> f c
where
cleanup (Left _) = pure ()
cleanup (Right c) = do
grpcDebug "withServerCall: destroying." grpcDebug "withServerCall: destroying."
destroyServerCall c destroyServerCall c
@ -44,13 +47,13 @@ withServerCall s f =
withServerCallAsync :: Server withServerCallAsync :: Server
-> (ServerCall -> IO ()) -> (ServerCall -> IO ())
-> IO () -> IO ()
withServerCallAsync s f = withServerCallAsync s f = mask $ \unmask ->
serverCreateCall s >>= \case serverCreateCall s >>= \case
Left e -> do grpcDebug $ "withServerCallAsync: call error: " ++ show e Left e -> do grpcDebug $ "withServerCallAsync: call error: " ++ show e
return () return ()
Right c -> do wasForkSuccess <- forkServer s handler Right c -> do wasForkSuccess <- forkServer s handler
unless wasForkSuccess destroy unless wasForkSuccess destroy
where handler = f c `finally` destroy where handler = unmask (f c) `finally` destroy
-- TODO: We sometimes never finish cleanup if the server -- TODO: We sometimes never finish cleanup if the server
-- is shutting down and calls killThread. This causes gRPC -- is shutting down and calls killThread. This causes gRPC
-- core to complain about leaks. I think the cause of -- core to complain about leaks. I think the cause of