http2 5.3.0 → 5.3.1
raw patch · 6 files changed
+94/−50 lines, 6 files
Files
- ChangeLog.md +7/−0
- Network/HTTP2/Client.hs +0/−1
- Network/HTTP2/Client/Run.hs +6/−10
- Network/HTTP2/H2/Manager.hs +78/−29
- Network/HTTP2/Server/Run.hs +2/−9
- http2.cabal +1/−1
ChangeLog.md view
@@ -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
Network/HTTP2/Client.hs view
@@ -71,7 +71,6 @@ emptyFrameRateLimit, rstRateLimit, - -- * Common configuration Config (..), allocSimpleConfig,
Network/HTTP2/Client/Run.hs view
@@ -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
Network/HTTP2/H2/Manager.hs view
@@ -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.
Network/HTTP2/Server/Run.hs view
@@ -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 ()
http2.cabal view
@@ -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 <kazu@iij.ad.jp>