From 35163c3c1861f2eb27ea443dac20a4960d76d87d Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Thu, 22 Aug 2019 17:55:33 +0200 Subject: [PATCH] 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. --- core/src/Network/GRPC/LowLevel/Client.hs | 9 ++++++--- .../GRPC/LowLevel/Client/Unregistered.hs | 17 ++++++++++------- core/src/Network/GRPC/LowLevel/Server.hs | 19 +++++++++++-------- .../GRPC/LowLevel/Server/Unregistered.hs | 15 +++++++++------ 4 files changed, 36 insertions(+), 24 deletions(-) diff --git a/core/src/Network/GRPC/LowLevel/Client.hs b/core/src/Network/GRPC/LowLevel/Client.hs index 77c461e..4d68451 100644 --- a/core/src/Network/GRPC/LowLevel/Client.hs +++ b/core/src/Network/GRPC/LowLevel/Client.hs @@ -11,7 +11,7 @@ -- `Network.GRPC.LowLevel.Client.Unregistered`. module Network.GRPC.LowLevel.Client where -import Control.Exception (bracket, finally) +import Control.Exception (bracket) import Control.Concurrent.MVar import Control.Monad import Control.Monad.IO.Class @@ -222,9 +222,12 @@ withClientCallParent :: Client -> (ClientCall -> IO (Either GRPCIOError a)) -> IO (Either GRPCIOError a) 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) - Right c -> f c `finally` do + Right c -> f c + where + cleanup (Left _) = pure () + cleanup (Right c) = do debugClientCall c grpcDebug "withClientCall(R): destroying." destroyClientCall c diff --git a/core/src/Network/GRPC/LowLevel/Client/Unregistered.hs b/core/src/Network/GRPC/LowLevel/Client/Unregistered.hs index 8800952..361f346 100644 --- a/core/src/Network/GRPC/LowLevel/Client/Unregistered.hs +++ b/core/src/Network/GRPC/LowLevel/Client/Unregistered.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Network.GRPC.LowLevel.Client.Unregistered where import Control.Arrow -import Control.Exception (finally) +import Control.Exception (bracket) import Control.Monad (join) import Data.ByteString (ByteString) import Foreign.Ptr (nullPtr) @@ -40,13 +41,15 @@ withClientCall :: Client -> TimeoutSeconds -> (ClientCall -> IO (Either GRPCIOError a)) -> IO (Either GRPCIOError a) -withClientCall client method timeout f = do - createResult <- clientCreateCall client method timeout - case createResult of +withClientCall client method timeout f = + bracket (clientCreateCall client method timeout) cleanup $ \case Left x -> return $ Left x - Right call -> f call `finally` logDestroy call - where logDestroy c = grpcDebug "withClientCall(U): destroying." - >> destroyClientCall c + Right call -> f call + where + 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 -- first. Probably only useful for testing. diff --git a/core/src/Network/GRPC/LowLevel/Server.hs b/core/src/Network/GRPC/LowLevel/Server.hs index dc16543..fc718a4 100644 --- a/core/src/Network/GRPC/LowLevel/Server.hs +++ b/core/src/Network/GRPC/LowLevel/Server.hs @@ -26,7 +26,7 @@ import Control.Concurrent.STM.TVar (TVar , writeTVar , readTVarIO , newTVarIO) -import Control.Exception (bracket, finally) +import Control.Exception (bracket) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Except @@ -343,13 +343,16 @@ withServerCall :: Server -> (ServerCall (MethodPayload mt) -> IO (Either GRPCIOError a)) -> IO (Either GRPCIOError a) withServerCall s rm f = - serverCreateCall s rm >>= \case - Left e -> return (Left e) - Right c -> do - debugServerCall c - f c `finally` do - grpcDebug "withServerCall(R): destroying." - destroyServerCall c + bracket (serverCreateCall s rm) cleanup $ \case + Left e -> return (Left e) + Right c -> do + debugServerCall c + f c + where + cleanup (Left _) = pure () + cleanup (Right c) = do + grpcDebug "withServerCall(R): destroying." + destroyServerCall c -------------------------------------------------------------------------------- -- serverReader (server side of client streaming mode) diff --git a/core/src/Network/GRPC/LowLevel/Server/Unregistered.hs b/core/src/Network/GRPC/LowLevel/Server/Unregistered.hs index f50d662..6f7309c 100644 --- a/core/src/Network/GRPC/LowLevel/Server/Unregistered.hs +++ b/core/src/Network/GRPC/LowLevel/Server/Unregistered.hs @@ -3,7 +3,7 @@ module Network.GRPC.LowLevel.Server.Unregistered where -import Control.Exception (finally) +import Control.Exception (bracket, finally, mask) import Control.Monad import Control.Monad.Trans.Except import Data.ByteString (ByteString) @@ -30,9 +30,12 @@ withServerCall :: Server -> (ServerCall -> IO (Either GRPCIOError a)) -> IO (Either GRPCIOError a) withServerCall s f = - serverCreateCall s >>= \case - Left e -> return (Left e) - Right c -> f c `finally` do + bracket (serverCreateCall s) cleanup $ \case + Left e -> return (Left e) + Right c -> f c + where + cleanup (Left _) = pure () + cleanup (Right c) = do grpcDebug "withServerCall: destroying." destroyServerCall c @@ -44,13 +47,13 @@ withServerCall s f = withServerCallAsync :: Server -> (ServerCall -> IO ()) -> IO () -withServerCallAsync s f = +withServerCallAsync s f = mask $ \unmask -> serverCreateCall s >>= \case Left e -> do grpcDebug $ "withServerCallAsync: call error: " ++ show e return () Right c -> do wasForkSuccess <- forkServer s handler 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 -- is shutting down and calls killThread. This causes gRPC -- core to complain about leaks. I think the cause of