diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # ChangeLog for http2 +## 5.3.1 + +* Fix treatment of async exceptions + [#138](https://github.com/kazu-yamamoto/http2/pull/138) +* Avoid race condition + [#137](https://github.com/kazu-yamamoto/http2/pull/137) + ## 5.3.0 * New server architecture: spawning worker on demand instead of the diff --git a/Network/HTTP2/Client.hs b/Network/HTTP2/Client.hs --- a/Network/HTTP2/Client.hs +++ b/Network/HTTP2/Client.hs @@ -71,7 +71,6 @@ emptyFrameRateLimit, rstRateLimit, - -- * Common configuration Config (..), allocSimpleConfig, diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -140,16 +140,8 @@ 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 @@ -157,6 +149,10 @@ runBackgroundThreads = do labelMe "H2 runBackgroundThreads" concurrently_ runReceiver runSender + + clientResult :: Either () a -> a + clientResult (Left ()) = undefined -- unreachable + clientResult (Right a) = a sendRequest :: Config diff --git a/Network/HTTP2/H2/Manager.hs b/Network/HTTP2/H2/Manager.hs --- a/Network/HTTP2/H2/Manager.hs +++ b/Network/HTTP2/H2/Manager.hs @@ -16,8 +16,8 @@ ) where import Data.Foldable -import Data.Set (Set) -import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map.Strict as Map import qualified System.TimeManager as T import UnliftIO.Concurrent import UnliftIO.Exception @@ -28,11 +28,25 @@ ---------------------------------------------------------------- -data Command = Stop (Maybe SomeException) | Add ThreadId | 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 + +cancelTimeout :: TimeoutHandle -> IO () +cancelTimeout (ThreadWithTimeout h) = T.cancel h +cancelTimeout ThreadWithoutTimeout = return () + +type ManagedThreads = Map ThreadId TimeoutHandle + -- | Starting a thread manager. -- Its action is initially set to 'return ()' and should be set -- by 'setAction'. This allows that the action can include @@ -43,27 +57,47 @@ cnt <- newTVarIO 0 void $ forkIO $ do labelMe "H2 thread manager" - go q Set.empty + go q Map.empty return $ Manager q cnt timmgr where - go q tset0 = do + -- This runs in a separate thread whose ThreadId is not known by anyone + -- else, so it cannot be killed by asynchronous exceptions. + go :: TQueue Command -> ManagedThreads -> IO () + go q threadMap0 = do x <- atomically $ readTQueue q case x of - Stop err -> kill tset0 err - Add newtid -> - let tset = add newtid tset0 - in go q tset - Delete oldtid -> - let tset = del oldtid tset0 - in go q tset + Stop signalTimeoutsDisabled err -> do + kill signalTimeoutsDisabled threadMap0 err + Add newtid -> do + let threadMap = add newtid threadMap0 + go q threadMap + RegisterTimeout tid h -> do + let threadMap = registerTimeout tid h threadMap0 + go q threadMap + Delete oldtid -> do + threadMap <- del oldtid threadMap0 + 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 - atomically $ writeTQueue q $ Stop (either Just (const Nothing) ma) - cleanup ma + 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 + case ma of + Left err -> cleanup (Just err) >> throwIO err + Right a -> cleanup Nothing >> return a ---------------------------------------------------------------- @@ -86,7 +120,7 @@ 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 @@ -112,24 +146,39 @@ ---------------------------------------------------------------- -add :: ThreadId -> Set ThreadId -> Set ThreadId -add tid set = set' - where - set' = Set.insert tid set +add :: ThreadId -> ManagedThreads -> ManagedThreads +add tid = Map.insert tid ThreadWithoutTimeout -del :: ThreadId -> Set ThreadId -> Set ThreadId -del tid set = set' - where - set' = Set.delete tid set +registerTimeout :: ThreadId -> T.Handle -> ManagedThreads -> ManagedThreads +registerTimeout tid = Map.insert tid . ThreadWithTimeout -kill :: Set ThreadId -> Maybe SomeException -> IO () -kill set err = traverse_ (\tid -> E.throwTo tid $ KilledByHttp2ThreadManager err) set +del :: ThreadId -> ManagedThreads -> IO ManagedThreads +del tid threadMap = do + forM_ (Map.lookup tid threadMap) cancelTimeout + return $ Map.delete tid threadMap +-- | Kill all threads +-- +-- We first remove all threads from the timeout manager, then signal that that +-- is complete, and finally kill all threads. This avoids a race between the +-- timeout manager and our manager: we want to ensure that the exception that +-- gets delivered is 'KilledByHttp2ThreadManager', not 'TimeoutThread'. +kill :: MVar () -> ManagedThreads -> Maybe SomeException -> IO () +kill signalTimeoutsDisabled threadMap err = do + forM_ (Map.elems threadMap) cancelTimeout + putMVar signalTimeoutsDisabled () + forM_ (Map.keys threadMap) $ \tid -> + 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 _ _ tmgr) action = E.bracket register T.cancel action +timeoutKillThread (Manager q _ tmgr) action = E.bracket register T.cancel action where - register = T.registerKillThread tmgr (return ()) + register = do + 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. diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs --- a/Network/HTTP2/Server/Run.hs +++ b/Network/HTTP2/Server/Run.hs @@ -12,7 +12,6 @@ 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 @@ 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 () diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2 -version: 5.3.0 +version: 5.3.1 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto