diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # ChangeLog for http2 +## 5.4.10 + +* `decodeSophisticated` has the type it had before 5.4.9; the header list + size limit moved to an unexported function. + [#226](https://github.com/kazu-yamamoto/http2/pull/226) +* A `runIO` connection ends, with a GOAWAY, once the application says it is + done. + [#228](https://github.com/kazu-yamamoto/http2/pull/228) +* The threads of a connection are waited for, up to five seconds, before + its streams are closed and the caller tears the connection down. + [#228](https://github.com/kazu-yamamoto/http2/pull/228) +* Requires `time-manager` 0.5. + ## 5.4.9 * Bound the decoded size of a field block (CVE-2026-49975). 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 @@ -184,7 +184,7 @@ runH2 :: Config -> Context -> IO a -> IO a runH2 conf ctx runClient = do - T.stopAfter mgr (E.try runAll >>= closureClient conf ctx) $ \res -> + stopAfterAndWait mgr (E.try runAll >>= closureClient conf ctx) $ \res -> closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res where mgr = threadManager ctx diff --git a/Network/HTTP2/H2/Context.hs b/Network/HTTP2/H2/Context.hs --- a/Network/HTTP2/H2/Context.hs +++ b/Network/HTTP2/H2/Context.hs @@ -12,6 +12,8 @@ import Network.Control import Network.Socket (SockAddr) import qualified System.ThreadManager as T +import qualified System.TimeManager as TM +import System.Timeout (timeout) import Imports hiding (insert) import Network.HPACK @@ -26,6 +28,26 @@ ---------------------------------------------------------------- +-- | Telling a connection's threads to stop and seeing them out before the +-- cleanup, which closes the streams they are still writing to. +-- +-- The wait is capped because one of the threads waited for runs the +-- application's handler: an application which swallows the asynchronous +-- exception would otherwise keep this from ever returning. +stopAfterAndWait + :: T.ThreadManager -> IO a -> (Maybe E.SomeException -> IO ()) -> IO a +stopAfterAndWait mgr action cleanup = + T.stopAfter mgr action $ \res -> do + void $ timeout stopTimeout $ T.waitUntilAllGone mgr + cleanup res + +-- | How long the threads are given to end after they have been told to. +-- Unwinding takes milliseconds; this is for one that does not stop. +stopTimeout :: Int +stopTimeout = 5000000 + +---------------------------------------------------------------- + data RoleInfo = RIS ServerInfo | RIC ClientInfo type Launch = Context -> Stream -> InpObj -> IO () @@ -88,8 +110,13 @@ , mySockAddr :: SockAddr , peerSockAddr :: SockAddr , threadManager :: T.ThreadManager + , timeoutManager :: TM.Manager + -- ^ For the threads that are timed out: owning a thread and + -- timing it out are separate, so the manager carries no timer. , receiverDone :: TVar (Maybe E.SomeException) - , workersDone :: STM Bool + , appDone :: STM Bool + -- ^ Server only: set by 'sioDone' once a 'runIO' application has + -- nothing more to send. Never for 'run' and clients. , informationalCallback :: StreamId -> TokenHeaderTable -> IO () -- ^ Client only: called when a 1xx informational response (e.g. 103 Early -- Hints) is received, ahead of the final response. Copied from @@ -132,7 +159,7 @@ -> Int -> Int -> Settings - -> T.Manager + -> TM.Manager -> Maybe (STM Bool) -> IO Context newContext roleInfo Config{..} cacheSiz connRxWS mySettings timmgr mdone = do @@ -172,10 +199,11 @@ rstRate <- newRate let mySockAddr = confMySockAddr let peerSockAddr = confPeerSockAddr - threadManager <- T.newThreadManager timmgr + threadManager <- T.newThreadManager + let timeoutManager = timmgr receiverDone <- newTVarIO Nothing let informationalCallback = confOnInformational - let workersDone = fromMaybe (T.isAllGone threadManager) mdone + let appDone = fromMaybe (return False) mdone peerGoAway <- newTVarIO Nothing activeRequests <- newTVarIO 0 resetByMe <- newIORef IntSet.empty diff --git a/Network/HTTP2/H2/Receiver.hs b/Network/HTTP2/H2/Receiver.hs --- a/Network/HTTP2/H2/Receiver.hs +++ b/Network/HTTP2/H2/Receiver.hs @@ -25,6 +25,7 @@ import Network.HTTP.Semantics import qualified System.IO.Error as E import qualified System.ThreadManager as T +import qualified System.TimeManager as TM import Imports hiding (delete, insert) import Network.HTTP2.Frame @@ -69,7 +70,7 @@ then loop1 else - T.withHandle (threadManager ctx) (E.throwTo tid ConnectionIsTimeout) loop2 + TM.withHandle (timeoutManager ctx) (E.throwTo tid ConnectionIsTimeout) loop2 loop1 :: IO Void loop1 = do @@ -79,14 +80,14 @@ processFrame ctx conf $ decodeFrameHeader hd loop1 - loop2 :: T.Handle -> IO Void + loop2 :: TM.Handle -> IO Void loop2 th = do -- If 'confReadN' is timeouted, 'ConnectionIsTimeout' is thrown -- to destroy the thread trees. So it is if the peer does not -- read what we send, and we wait here for ever. atomically $ waitControlQ $ controlQ ctx hd <- confReadN frameHeaderLength - T.tickle th + TM.tickle th when (BS.null hd) $ E.throwIO ConnectionIsClosed processFrame ctx conf $ decodeFrameHeader hd loop2 th diff --git a/Network/HTTP2/H2/Sender.hs b/Network/HTTP2/H2/Sender.hs --- a/Network/HTTP2/H2/Sender.hs +++ b/Network/HTTP2/H2/Sender.hs @@ -18,6 +18,7 @@ import Network.ByteOrder import Network.HTTP.Semantics.Client import Network.HTTP.Semantics.IO +import qualified System.ThreadManager as T import Imports import Network.HPACK (setLimitForEncoding, toTokenHeaderTable) @@ -69,8 +70,12 @@ connectionError e = E.throwIO e -- | Whether the sender is done: nothing left to send, and the receiver --- done. Otherwise it waits for something to send. +-- done or the application done. Otherwise it waits for something to send. -- +-- The application is done once outputs waiting for their stream windows, +-- each in a thread of its own, are gone too. Workers are not waited for +-- when the receiver is done: they wait on streams closed only after this. +-- -- DATA parked for the connection window is something to send once the -- window opens. Left out, a sender with nothing else queued waited here -- for the control or output queue, and a WINDOW_UPDATE opening the window @@ -87,12 +92,18 @@ then return Nothing else do - recv <- readTVar receiverDone - case recv of - Just done -> - return $ Just done - _otherwise -> - retry + app <- appDone + gone <- T.isAllGone threadManager + if app && gone && null ps + then + return $ Just $ E.toException ConnectionIsClosed + else do + recv <- readTVar receiverDone + case recv of + Just done -> + return $ Just done + _otherwise -> + retry checkDone _ _ _ = return Nothing frameSender :: Context -> Config -> IO E.SomeException diff --git a/Network/HTTP2/H2/Sync.hs b/Network/HTTP2/H2/Sync.hs --- a/Network/HTTP2/H2/Sync.hs +++ b/Network/HTTP2/H2/Sync.hs @@ -18,6 +18,7 @@ import Network.Control import Network.HTTP.Semantics.IO import qualified System.ThreadManager as T +import qualified System.TimeManager as TM import Network.HTTP2.H2.Context import Network.HTTP2.H2.Queue @@ -108,14 +109,14 @@ case s of Done -> return () Cont newout -> do - mapM_ T.tickle (lcTimeHandle lc) + mapM_ TM.tickle (lcTimeHandle lc) cont <- checkLoop lc when cont $ do enqueueOutput outputQ newout loop newLoopCheck - :: Stream -> Maybe (TBQueue StreamingChunk) -> Maybe T.Handle -> IO LoopCheck + :: Stream -> Maybe (TBQueue StreamingChunk) -> Maybe TM.Handle -> IO LoopCheck newLoopCheck strm mtbq mth = do tovar <- newTVarIO False return $ @@ -132,7 +133,7 @@ , lcTBQ :: Maybe (TBQueue StreamingChunk) , lcTimeout :: TVar Bool , lcWindow :: TVar TxFlow - , lcTimeHandle :: Maybe T.Handle + , lcTimeHandle :: Maybe TM.Handle } checkLoop :: LoopCheck -> IO Bool diff --git a/Network/HTTP2/H2/Types.hs b/Network/HTTP2/H2/Types.hs --- a/Network/HTTP2/H2/Types.hs +++ b/Network/HTTP2/H2/Types.hs @@ -8,6 +8,7 @@ import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception as E +import qualified System.TimeManager as TM import Data.IORef import Foreign.Ptr (nullPtr) import Network.Control @@ -267,7 +268,7 @@ , confSendAll :: ByteString -> IO () , confReadN :: Int -> IO ByteString , confPositionReadMaker :: PositionReadMaker - , confTimeoutManager :: T.Manager + , confTimeoutManager :: TM.Manager , confMySockAddr :: SockAddr -- ^ This is copied into 'Aux', if exist, on server. , confPeerSockAddr :: SockAddr 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 @@ -11,7 +11,6 @@ import Network.HTTP.Semantics.Server import Network.HTTP.Semantics.Server.Internal import Network.Socket (SockAddr) -import qualified System.ThreadManager as T import Network.HTTP2.Frame import Network.HTTP2.H2 @@ -142,7 +141,7 @@ -- are closed with it. Right e -> return e closureServer conf ctx e - T.stopAfter mgr runBackgroundThreads $ \res -> + stopAfterAndWait mgr runBackgroundThreads $ \res -> closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res -- connClose must not be called here since Run:fork calls it diff --git a/Network/HTTP2/Server/Worker.hs b/Network/HTTP2/Server/Worker.hs --- a/Network/HTTP2/Server/Worker.hs +++ b/Network/HTTP2/Server/Worker.hs @@ -15,6 +15,7 @@ import Network.HTTP.Semantics.Server.Internal import Network.HTTP.Types import qualified System.ThreadManager as T +import qualified System.TimeManager as TM import Imports hiding (insert) import Network.HTTP2.Frame @@ -29,7 +30,7 @@ runServer :: Config -> Server -> Launch runServer conf server ctx@Context{..} strm req = - T.forkManagedTimeout threadManager label $ \th -> do + T.forkManagedTimeout threadManager timeoutManager label $ \th -> do let req' = pauseRequestBody th aux = defaultAux @@ -53,9 +54,9 @@ where readBody = inpObjBody req readBody' = do - T.pause th + TM.pause th bs <- readBody - T.resume th -- this is the same as 'tickle' + TM.resume th -- this is the same as 'tickle' return bs -- | Called once the handler has returned: nobody reads the request body @@ -278,18 +279,18 @@ -> IO (TBQueue StreamingChunk) sendStreaming ctx@Context{..} strm strmbdy = do tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 - T.forkManagedTimeout threadManager label $ \th -> + T.forkManagedTimeout threadManager timeoutManager label $ \th -> withOutBodyIface ctx strm tbq id $ \iface -> do let iface' = iface { outBodyPush = \b -> do - T.pause th + TM.pause th outBodyPush iface b - T.resume th -- this is the same as 'tickle' + TM.resume th -- this is the same as 'tickle' , outBodyPushFinal = \b -> do - T.pause th + TM.pause th outBodyPushFinal iface b - T.resume th -- this is the same as 'tickle' + TM.resume th -- this is the same as 'tickle' } strmbdy iface' return tbq diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: http2 -version: 5.4.9 +version: 5.4.10 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -122,7 +122,7 @@ network-byte-order >=0.1.7 && <0.2, network-control >=0.1 && <0.2, stm >=2.5 && <2.6, - time-manager >=0.3.0 && <0.5, + time-manager >=0.5 && <0.6, unix-time >=0.4.11 && <0.6, utf8-string >=1.0 && <1.1 diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -44,6 +44,7 @@ import qualified Network.HTTP2.Client.Internal as C import Network.HTTP2.Frame import Network.HTTP2.Server +import qualified Network.HTTP2.Server.Internal as S port :: String port = show $ unsafePerformIO (randomPort <$> getStdGen) @@ -432,6 +433,30 @@ Just (Left e) -> expectationFailure $ show (e :: C.HTTP2Error) Nothing -> expectationFailure "timed out" + it "closes the connection once a runIO application is done" $ + -- 'sioDone' set a flag that nothing read, so the connection + -- stayed open until the client closed it. + E.bracket (forkIO runServerIO) killThread $ \_ -> do + threadDelay 10000 + timeout 5000000 (requestAndCollect [] (\_ -> return ())) + `shouldReturn` Just ["HEADERS 1", "DATA 1 END_STREAM", "GOAWAY NoError"] + + it "sends a runIO body waiting for its window before closing" $ + -- The rest of the body waits in a thread of the thread manager. + -- The queues are empty meanwhile, but the application is not + -- done until it is gone. + E.bracket (forkIO runServerIO) killThread $ \_ -> do + threadDelay 10000 + let openWindow s = + threadDelay 100000 + >> sendAll + s + (encodeFrame (EncodeInfo defaultFlags 1 Nothing) $ WindowUpdateFrame 100000) + timeout + 5000000 + (requestAndCollect [(SettingsInitialWindowSize, 1000)] openWindow) + `shouldReturn` Just ["HEADERS 1", "DATA 1 END_STREAM", "GOAWAY NoError"] + it "answers the requests it has after the client's GOAWAY" $ -- A client's GOAWAY speaks of the server's own streams, and -- the requests it has already sent are still to be answered. @@ -815,6 +840,40 @@ status (Left C.ConnectionIsClosed) = "closed" status (Left e) = C8.pack $ show e +-- | A 'S.runIO' server answering a single request, then done. +runServerIO :: IO () +runServerIO = runTCPServer (Just host) port $ \s -> + E.bracket (allocSimpleConfig s 32768) freeSimpleConfig $ \conf -> + E.handle ignoreHTTP2Error $ S.runIO defaultServerConfig conf (return . app) + where + app S.ServerIO{..} = do + (strm, _) <- sioReadRequest + sioWriteResponse strm $ + responseBuilder ok200 [] $ + byteString $ + B.replicate 30000 0x61 + sioDone + +-- | A request for / with these settings, then the action, and what the +-- server sends until it closes the connection. +requestAndCollect :: SettingsList -> (Socket -> IO ()) -> IO [String] +requestAndCollect settings action = runTCPClient host port $ \s -> do + sendAll s connectionPreface + sendAll s $ + encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ + SettingsFrame settings + sendAll s $ + encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) 1 Nothing) $ + HeadersFrame Nothing $ + hpackEncode + [ (":scheme", "http") + , (":authority", "127.0.0.1") + , (":path", "/") + , (":method", "GET") + ] + _ <- E.try (action s) :: IO (Either E.IOException ()) + collectFrames s + -- | A request for /slow, then GOAWAY(NO_ERROR) at once. What the server -- sends from then on until it closes the connection. goAwayFromClient :: IO [String] @@ -833,7 +892,11 @@ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ GoAwayFrame 0 NoError "going" - collect s + collectFrames s + +-- | What the server sends until it closes the connection. +collectFrames :: Socket -> IO [String] +collectFrames = collect where collect s = do mf <- recvFrame s