From 3a0c72d97c9d0f3ae00a027df6869f883c8f4dd6 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Fri, 19 Jul 2024 12:13:47 +0200 Subject: [PATCH 1/2] Fix treatment of async exceptions In https://github.com/kazu-yamamoto/http2/pull/92 we added an exception handler that was meant to catch _all_ exceptions (sync and async). This got changed in https://github.com/kazu-yamamoto/http2/pull/114 (specifically, https://github.com/kazu-yamamoto/http2/pull/114/commits/52a9619ba95b67d469205cb0dea546ada8489baa): when we moved from `Control.Exception` to `UnliftIO.Exception`, we got a different behaviour for `catch` and friends (see https://github.com/well-typed/grapesy/issues/193#issuecomment-2238704595) for a full list. This commit fixes some unintended consequences of this change. --- Network/HTTP2/Client/Run.hs | 16 ++++++---------- Network/HTTP2/H2/Manager.hs | 15 +++++++++++---- Network/HTTP2/Server/Run.hs | 11 ++--------- 3 files changed, 19 insertions(+), 23 deletions(-) diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs index 0db39014..4b466d18 100644 --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -140,16 +140,8 @@ setup ClientConfig{..} conf@Config{..} = do runH2 :: Config -> Context -> IO a -> IO a runH2 conf ctx runClient = do - stopAfter mgr (race runBackgroundThreads runClient) $ \res -> do - closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) $ - either Just (const Nothing) res - case res of - Left err -> - throwIO err - Right (Left ()) -> - undefined -- never reach - Right (Right x) -> - return x + stopAfter mgr (clientResult <$> race runBackgroundThreads runClient) $ \res -> + closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res where mgr = threadManager ctx runReceiver = frameReceiver ctx conf @@ -158,6 +150,10 @@ runH2 conf ctx runClient = do labelMe "H2 runBackgroundThreads" concurrently_ runReceiver runSender + clientResult :: Either () a -> a + clientResult (Left ()) = undefined -- unreachable + clientResult (Right a) = a + sendRequest :: Config -> Context diff --git a/Network/HTTP2/H2/Manager.hs b/Network/HTTP2/H2/Manager.hs index c566c080..e6ab2536 100644 --- a/Network/HTTP2/H2/Manager.hs +++ b/Network/HTTP2/H2/Manager.hs @@ -79,16 +79,23 @@ start timmgr = do go q threadMap -- | Stopping the manager. -stopAfter :: Manager -> IO a -> (Either SomeException a -> IO b) -> IO b +-- +-- The action is run in the scope of an exception handler that catches all +-- exceptions (including asynchronous ones); this allows the cleanup handler +-- to cleanup in all circumstances. If an exception is caught, it is rethrown +-- after the cleanup is complete. +stopAfter :: Manager -> IO a -> (Maybe SomeException -> IO ()) -> IO a stopAfter (Manager q _ _) action cleanup = do mask $ \unmask -> do - ma <- try $ unmask action + ma <- trySyncOrAsync $ unmask action signalTimeoutsDisabled <- newEmptyMVar atomically $ writeTQueue q $ Stop signalTimeoutsDisabled (either Just (const Nothing) ma) -- This call to takeMVar /will/ eventually succeed, because the Manager -- thread cannot be killed (see comment on 'go' in 'start'). takeMVar signalTimeoutsDisabled - cleanup ma + case ma of + Left err -> cleanup (Just err) >> throwIO err + Right a -> cleanup Nothing >> return a ---------------------------------------------------------------- @@ -111,7 +118,7 @@ forkManagedUnmask mgr label io = incCounter mgr -- We catch the exception and do not rethrow it: we don't want the -- exception printed to stderr. - io unmask `catch` \(_e :: SomeException) -> return () + io unmask `catchSyncOrAsync` \(_e :: SomeException) -> return () deleteMyId mgr decCounter mgr where diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs index 7d4d64e5..a1d6e509 100644 --- a/Network/HTTP2/Server/Run.hs +++ b/Network/HTTP2/Server/Run.hs @@ -12,7 +12,6 @@ import Network.HTTP.Semantics.Server import Network.HTTP.Semantics.Server.Internal import Network.Socket (SockAddr) import UnliftIO.Async (concurrently_) -import UnliftIO.Exception import Network.HTTP2.Frame import Network.HTTP2.H2 @@ -129,14 +128,8 @@ runH2 conf ctx = do runReceiver = frameReceiver ctx conf runSender = frameSender ctx conf runBackgroundThreads = concurrently_ runReceiver runSender - stopAfter mgr runBackgroundThreads $ \res -> do - closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) $ - either Just (const Nothing) res - case res of - Left err -> - throwIO err - Right x -> - return x + stopAfter mgr runBackgroundThreads $ \res -> + closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res -- connClose must not be called here since Run:fork calls it goaway :: Config -> ErrorCode -> ByteString -> IO () From e753c9ff2df0a0a8cb3344d5d504dd635a90523e Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Wed, 24 Jul 2024 09:29:32 +0200 Subject: [PATCH 2/2] Fourmolu --- Network/HTTP2/Client.hs | 1 - Network/HTTP2/H2/Manager.hs | 36 +++++++++++++++++++----------------- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/Network/HTTP2/Client.hs b/Network/HTTP2/Client.hs index f072c115..94013231 100644 --- a/Network/HTTP2/Client.hs +++ b/Network/HTTP2/Client.hs @@ -71,7 +71,6 @@ module Network.HTTP2.Client ( emptyFrameRateLimit, rstRateLimit, - -- * Common configuration Config (..), allocSimpleConfig, diff --git a/Network/HTTP2/H2/Manager.hs b/Network/HTTP2/H2/Manager.hs index e6ab2536..704e720a 100644 --- a/Network/HTTP2/H2/Manager.hs +++ b/Network/HTTP2/H2/Manager.hs @@ -28,22 +28,22 @@ import Imports ---------------------------------------------------------------- -data Command = - Stop (MVar ()) (Maybe SomeException) - | Add ThreadId - | RegisterTimeout ThreadId T.Handle - | Delete ThreadId +data Command + = Stop (MVar ()) (Maybe SomeException) + | Add ThreadId + | RegisterTimeout ThreadId T.Handle + | Delete ThreadId -- | Manager to manage the thread and the timer. data Manager = Manager (TQueue Command) (TVar Int) T.Manager -data TimeoutHandle = - ThreadWithTimeout T.Handle - | ThreadWithoutTimeout +data TimeoutHandle + = ThreadWithTimeout T.Handle + | ThreadWithoutTimeout cancelTimeout :: TimeoutHandle -> IO () cancelTimeout (ThreadWithTimeout h) = T.cancel h -cancelTimeout ThreadWithoutTimeout = return () +cancelTimeout ThreadWithoutTimeout = return () type ManagedThreads = Map ThreadId TimeoutHandle @@ -89,13 +89,15 @@ stopAfter (Manager q _ _) action cleanup = do mask $ \unmask -> do ma <- trySyncOrAsync $ unmask action signalTimeoutsDisabled <- newEmptyMVar - atomically $ writeTQueue q $ Stop signalTimeoutsDisabled (either Just (const Nothing) ma) + atomically $ + writeTQueue q $ + Stop signalTimeoutsDisabled (either Just (const Nothing) ma) -- This call to takeMVar /will/ eventually succeed, because the Manager -- thread cannot be killed (see comment on 'go' in 'start'). takeMVar signalTimeoutsDisabled case ma of - Left err -> cleanup (Just err) >> throwIO err - Right a -> cleanup Nothing >> return a + Left err -> cleanup (Just err) >> throwIO err + Right a -> cleanup Nothing >> return a ---------------------------------------------------------------- @@ -166,17 +168,17 @@ kill signalTimeoutsDisabled threadMap err = do forM_ (Map.elems threadMap) cancelTimeout putMVar signalTimeoutsDisabled () forM_ (Map.keys threadMap) $ \tid -> - E.throwTo tid $ KilledByHttp2ThreadManager err + E.throwTo tid $ KilledByHttp2ThreadManager err -- | Killing the IO action of the second argument on timeout. timeoutKillThread :: Manager -> (T.Handle -> IO a) -> IO a timeoutKillThread (Manager q _ tmgr) action = E.bracket register T.cancel action where register = do - h <- T.registerKillThread tmgr (return ()) - tid <- myThreadId - atomically $ writeTQueue q (RegisterTimeout tid h) - return h + h <- T.registerKillThread tmgr (return ()) + tid <- myThreadId + atomically $ writeTQueue q (RegisterTimeout tid h) + return h -- | Registering closer for a resource and -- returning a timer refresher.