http2 5.4.8 → 5.4.9
raw patch · 22 files changed
+1080/−80 lines, 22 filesdep ~time-managerPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: time-manager
API changes (from Hackage documentation)
+ Network.HPACK: getHeaderListSizeLimit :: DynamicTable -> IO (Maybe Int)
+ Network.HPACK: setHeaderListSizeLimit :: Maybe Int -> DynamicTable -> IO ()
Files
- ChangeLog.md +23/−0
- Network/HPACK.hs +2/−0
- Network/HPACK/HeaderBlock/Decode.hs +71/−18
- Network/HPACK/Table.hs +2/−0
- Network/HPACK/Table/Dynamic.hs +23/−0
- Network/HPACK/Types.hs +2/−1
- Network/HTTP2/Client/Run.hs +23/−4
- Network/HTTP2/H2/Context.hs +41/−2
- Network/HTTP2/H2/HPACK.hs +3/−1
- Network/HTTP2/H2/OutBodyIface.hs +19/−6
- Network/HTTP2/H2/Queue.hs +41/−2
- Network/HTTP2/H2/Receiver.hs +88/−30
- Network/HTTP2/H2/Sender.hs +19/−8
- Network/HTTP2/H2/Settings.hs +14/−2
- Network/HTTP2/H2/Stream.hs +2/−0
- Network/HTTP2/H2/Types.hs +8/−0
- Network/HTTP2/Server/Run.hs +1/−1
- Network/HTTP2/Server/Worker.hs +60/−2
- bench-hpack/Main.hs +1/−1
- http2.cabal +2/−2
- test/HPACK/DecodeSpec.hs +116/−0
- test/HTTP2/ServerSpec.hs +519/−0
ChangeLog.md view
@@ -1,5 +1,28 @@ # ChangeLog for http2 +## 5.4.9++* Bound the decoded size of a field block (CVE-2026-49975).+ [#216](https://github.com/kazu-yamamoto/http2/pull/216)+* Follow-ups to the header list size limit (CVE-2026-49975).+ [#217](https://github.com/kazu-yamamoto/http2/pull/217)+* Reset the stream of a server handler that fails.+ [#218](https://github.com/kazu-yamamoto/http2/pull/218)+* Reset the stream when a streaming body throws.+ [#219](https://github.com/kazu-yamamoto/http2/pull/219)+* Reset the stream of a client request interrupted before its response.+ [#220](https://github.com/kazu-yamamoto/http2/pull/220)+* Throw away the request body its handler did not read.+ [#221](https://github.com/kazu-yamamoto/http2/pull/221)+* Stop reading a peer that does not read what we send.+ [#222](https://github.com/kazu-yamamoto/http2/pull/222)+* Check the body against its content-length before delivering it.+ [#223](https://github.com/kazu-yamamoto/http2/pull/223)+* Ignore trailers on a stream we have reset.+ [#224](https://github.com/kazu-yamamoto/http2/pull/224)+* Apply the table size updates of a block at once.+ [#225](https://github.com/kazu-yamamoto/http2/pull/225)+ ## 5.4.8 * Reset a stream cancelled with an asynchronous exception instead of
Network/HPACK.hs view
@@ -22,6 +22,8 @@ withDynamicTableForEncoding, withDynamicTableForDecoding, setLimitForEncoding,+ setHeaderListSizeLimit,+ getHeaderListSizeLimit, -- * Strategy for encoding CompressionAlgo (..),
Network/HPACK/HeaderBlock/Decode.hs view
@@ -67,33 +67,54 @@ -> ByteString -- ^ An HPACK format -> IO TokenHeaderTable-decodeTokenHeader dyntbl inp =- decodeHPACK dyntbl inp (decodeSophisticated (toTokenHeader dyntbl)) `E.catch` \BufferOverrun -> E.throwIO HeaderBlockTruncated+decodeTokenHeader dyntbl inp = do+ lim <- getHeaderListSizeLimit dyntbl+ decodeHPACK dyntbl inp (decodeSophisticatedWithLimit lim (toTokenHeader dyntbl))+ `E.catch` \BufferOverrun -> E.throwIO HeaderBlockTruncated decodeHPACK :: DynamicTable -> ByteString -> (ReadBuffer -> IO a) -> IO a-decodeHPACK dyntbl inp dec = withReadBuffer inp chkChange+decodeHPACK dyntbl inp dec = withReadBuffer inp $ chkChange Nothing where- chkChange rbuf = do+ chkChange mupd rbuf = do -- A block can be empty, or hold nothing but table size updates: -- no fields, which is what empty trailers are sent as. Reading -- on regardless threw 'BufferOverrun', reported as a truncated -- block, so the connection was closed over them. leftover <- remainingSize rbuf if leftover < 1- then dec rbuf+ then apply mupd >> dec rbuf else do w <- read8 rbuf if isTableSizeUpdate w then do- tableSizeUpdate dyntbl w rbuf- chkChange rbuf+ siz <- tableSizeUpdate dyntbl w rbuf+ let upd = case mupd of+ Nothing -> (siz, siz)+ Just (lo, _) -> (min lo siz, siz)+ chkChange (Just upd) rbuf else do ff rbuf (-1)+ apply mupd dec rbuf+ -- The table size updates at the beginning of a block, applied at once.+ --+ -- Each used to be applied as it came, and each that changed the size+ -- copied the whole table into a new one. RFC 7541, section 4.2, needs+ -- two at most -- the smallest size since the last block, then the+ -- final one -- but nothing stopped a peer from sending thousands,+ -- alternating between two sizes, each cheap on the wire and costly+ -- here. Applied one after another, they leave the entries that fit+ -- in the smallest of them, in a table of the last one's size: so the+ -- table is shrunk to the smallest, then set to the last, two copies+ -- however many updates there are.+ apply Nothing = return ()+ apply (Just (lo, final)) = do+ when (lo < final) $ renewDynamicTable lo dyntbl+ renewDynamicTable final dyntbl -- | Converting to '[Header]'. --@@ -138,26 +159,52 @@ -- whole block has been decoded, so that the dynamic table is up to -- date: the message is malformed, not the block. -- * 'DecodeError' would be thrown if the HPACK format is broken.+--+-- The decoded size of the block is not limited: see 'decodeTokenHeader'+-- and 'setHeaderListSizeLimit' for that. decodeSophisticated :: (Word8 -> ReadBuffer -> IO TokenHeader) -> ReadBuffer -> IO TokenHeaderTable-decodeSophisticated decTokenHeader rbuf = do+decodeSophisticated = decodeSophisticatedWithLimit Nothing++-- | Like 'decodeSophisticated', throwing 'TooLargeHeader' as well once+-- the decoded header list size exceeds the limit.+--+-- Not exported: 'decodeSophisticated' is, from "Network.HPACK.Internal",+-- and used by other packages (http3, for QPACK), so its type stays as it+-- was.+decodeSophisticatedWithLimit+ :: Maybe Int+ -- ^ The limit on the decoded header list size ('Nothing' means no limit)+ -> (Word8 -> ReadBuffer -> IO TokenHeader)+ -> ReadBuffer+ -> IO TokenHeaderTable+decodeSophisticatedWithLimit lim decTokenHeader rbuf = do -- using maxTokenIx to reduce condition arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing tvs <- pseudoNormal arr tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where+ -- RFC 9113 section 6.5.2: the length of the name plus the length of+ -- the value plus 32, summed over the fields. A near-empty field+ -- referenced thousands of times, or a Cookie split into many crumbs,+ -- is cheap on the wire but large here; the limit bounds it.+ tooLarge :: Int -> Bool+ tooLarge siz = maybe False (siz >) lim+ fieldSize :: TokenHeader -> Int+ fieldSize (Token{..}, v) = BS.length (original tokenKey) + BS.length v + 32 pseudoNormal :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList- pseudoNormal arr = pseudo+ pseudoNormal arr = pseudo 0 where- pseudo = do+ pseudo siz = do leftover <- remainingSize rbuf if leftover >= 1 then do w <- read8 rbuf tv@(Token{..}, v) <- decTokenHeader w rbuf+ let siz' = siz + fieldSize tv if isPseudo then do mx <- unsafeRead arr tokenIx@@ -165,19 +212,21 @@ when (isJust mx) $ malformed IllegalHeaderName -- unknown when (isMaxTokenIx tokenIx) $ malformed IllegalHeaderName+ when (tooLarge siz') $ malformed TooLargeHeader unsafeWrite arr tokenIx (Just v)- pseudo+ pseudo siz' else do -- 0-Length Headers Leak - CVE-2019-9516 when (tokenKey == "") $ malformed IllegalHeaderName when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $ malformed IllegalHeaderName+ when (tooLarge siz') $ malformed TooLargeHeader unsafeWrite arr tokenIx (Just v) if isCookieTokenIx tokenIx- then normal 0 empty (empty << v)- else normal 0 (empty << tv) empty+ then normal 0 siz' empty (empty << v)+ else normal 0 siz' (empty << tv) empty else return []- normal n builder cookie+ normal n siz builder cookie | n > headerLimit = malformed TooLargeHeader | otherwise = do leftover <- remainingSize rbuf@@ -190,10 +239,12 @@ when (tokenKey == "") $ malformed IllegalHeaderName when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $ malformed IllegalHeaderName+ let siz' = siz + fieldSize tv+ when (tooLarge siz') $ malformed TooLargeHeader unsafeWrite arr tokenIx (Just v) if isCookieTokenIx tokenIx- then normal (n + 1) builder (cookie << v)- else normal (n + 1) (builder << tv) cookie+ then normal (n + 1) siz' builder (cookie << v)+ else normal (n + 1) siz' (builder << tv) cookie else do let tvs0 = run builder cook = run cookie@@ -229,13 +280,15 @@ | w `testBit` 4 = neverIndexing dyntbl w rbuf | otherwise = withoutIndexing dyntbl w rbuf -tableSizeUpdate :: DynamicTable -> Word8 -> ReadBuffer -> IO ()+-- | Read a table size update, and check it against our limit: it is+-- applied by 'decodeHPACK', with the others at the beginning of the block.+tableSizeUpdate :: DynamicTable -> Word8 -> ReadBuffer -> IO Size tableSizeUpdate dyntbl w rbuf = do let w' = mask5 w siz <- decodeI 5 w' rbuf suitable <- isSuitableSize siz dyntbl unless suitable $ E.throwIO TooLargeTableSize- renewDynamicTable siz dyntbl+ return siz ----------------------------------------------------------------
Network/HPACK/Table.hs view
@@ -16,6 +16,8 @@ needChangeTableSize, setLimitForEncoding, resetLimitForEncoding,+ setHeaderListSizeLimit,+ getHeaderListSizeLimit, -- * Insertion insertEntry,
Network/HPACK/Table/Dynamic.hs view
@@ -14,6 +14,8 @@ needChangeTableSize, setLimitForEncoding, resetLimitForEncoding,+ setHeaderListSizeLimit,+ getHeaderListSizeLimit, insertEntry, toDynamicEntry, CodeInfo (..),@@ -122,6 +124,11 @@ -- ^ The current dynamic table size (defined in HPACK) , maxDynamicTableSize :: IORef Size -- ^ The max dynamic table size (defined in HPACK)+ , headerListSizeLimit :: IORef (Maybe Size)+ -- ^ The limit on the decoded header list size, as defined in RFC 9113+ -- section 6.5.2 (the sum over each field of the length of its name,+ -- the length of its value, and 32). 'Nothing' means no limit. Used+ -- when decoding only. } {-# INLINE adj #-}@@ -192,6 +199,21 @@ | lim < maxsiz -> Change lim | otherwise -> Ignore maxsiz +-- | Setting the limit on the decoded header list size for decoding, as+-- defined in RFC 9113 section 6.5.2: the sum over each field of the+-- length of its name, the length of its value, and 32. A field block+-- over the limit makes decoding throw 'TooLargeHeader'. 'Nothing'+-- means no limit, which is the default. A limit of zero is a limit,+-- too: every field exceeds it.+setHeaderListSizeLimit :: Maybe Int -> DynamicTable -> IO ()+setHeaderListSizeLimit lim DynamicTable{..} =+ writeIORef headerListSizeLimit lim++-- | Getting the limit on the decoded header list size. 'Nothing' means no+-- limit.+getHeaderListSizeLimit :: DynamicTable -> IO (Maybe Int)+getHeaderListSizeLimit DynamicTable{..} = readIORef headerListSizeLimit+ -- | When SETTINGS_HEADER_TABLE_SIZE is received from a peer, -- its value should be set by this function. setLimitForEncoding :: Size -> DynamicTable -> IO ()@@ -242,6 +264,7 @@ <*> newIORef maxN -- maxNumOfEntries <*> newIORef 0 -- dynamicTableSize <*> newIORef maxsiz -- maxDynamicTableSize+ <*> newIORef Nothing -- headerListSizeLimit (no limit) where maxN = maxNumbers maxsiz end = maxN - 1
Network/HPACK/Types.hs view
@@ -87,7 +87,8 @@ IllegalTableSizeUpdate | HeaderBlockTruncated | IllegalHeaderName- | TooLargeHeader+ | -- | Too many fields, or a decoded header list size over the limit+ TooLargeHeader deriving (Eq, Show) instance E.Exception DecodeError
Network/HTTP2/Client/Run.hs view
@@ -54,7 +54,7 @@ -- @userinfo\@@ as part of the authority. -- -- >>> defaultClientConfig--- ClientConfig {scheme = "http", authority = "localhost", cacheLimit = 64, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}}+-- ClientConfig {scheme = "http", authority = "localhost", cacheLimit = 64, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Just 65536, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}} defaultClientConfig :: ClientConfig defaultClientConfig = ClientConfig@@ -94,8 +94,9 @@ case moutobj of Nothing -> return () Just outobj -> sendRequest conf ctx strm outobj False- rsp <- getResponse strm- processResponse rsp `E.finally` doneWithStream ctx strm+ -- Waiting for the response is in it too: a request interrupted+ -- there -- by 'timeout', say -- left its stream open just the same.+ (getResponse strm >>= processResponse) `E.finally` doneWithStream ctx strm -- After a GOAWAY, the connection lasts as long as a request is in -- 'activeRequests' ('drained'). counted ctx =@@ -121,7 +122,8 @@ action $ ClientIO confMySockAddr confPeerSockAddr putR get putB create runH2 conf ctx runClient --- | Called once 'processResponse' is done with a stream, however it ended.+-- | Called once a request is done with its stream, however it ended: once+-- 'processResponse' is, or once waiting for the response was interrupted. -- -- A response it did not read to the end left its stream open. The server -- went on sending the rest of the body, which nobody would read: it held@@ -130,8 +132,25 @@ -- Enough such requests, or ones whose 'processResponse' threw, and new -- requests waited for a slot, or the connection stalled. So such a stream -- is reset (CANCEL), and what was left of its body is given back.+--+-- A stream still idle is one whose request is still being sent: its+-- HEADERS may not have gone out yet, and a RST_STREAM ahead of them would+-- be one on an idle stream, a connection error (RFC 9113, section 5.1).+-- So that is left until the stream opens -- the request sent, or the+-- response begun -- or closes. doneWithStream :: Context -> Stream -> IO () doneWithStream ctx strm = do+ idle <- isIdle <$> readTVarIO (streamState strm)+ if idle+ then T.forkManaged (threadManager ctx) label $ do+ atomically $ readTVar (streamState strm) >>= check . not . isIdle+ doneWithOpenStream ctx strm+ else doneWithOpenStream ctx strm+ where+ label = "H2 done with stream " ++ show (streamNumber strm)++doneWithOpenStream :: Context -> Stream -> IO ()+doneWithOpenStream ctx strm = do cancelled <- closeIfReceiving ctx strm $ ResetByMe $ E.toException CancelledStream if cancelled
Network/HTTP2/H2/Context.hs view
@@ -8,6 +8,7 @@ import qualified Control.Exception as E import Data.IORef import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet as IntSet import Network.Control import Network.Socket (SockAddr) import qualified System.ThreadManager as T@@ -15,6 +16,7 @@ import Imports hiding (insert) import Network.HPACK import Network.HTTP2.Frame+import Network.HTTP2.H2.Queue import Network.HTTP2.H2.Settings import Network.HTTP2.H2.Stream import Network.HTTP2.H2.StreamTable@@ -73,7 +75,7 @@ -- ^ Invariant: Each stream will only ever have at most one 'Output' -- object in this queue at any moment. , outputQStreamID :: TVar StreamId- , controlQ :: TQueue Control+ , controlQ :: ControlQ , encodeDynamicTable :: DynamicTable , decodeDynamicTable :: DynamicTable , -- the connection window for sending data@@ -99,6 +101,9 @@ -- ^ Client only: requests whose 'processResponse' has not returned. -- A response can be complete, its stream gone from the table, and -- its body still being read.+ , resetByMe :: IORef IntSet.IntSet+ -- ^ Server only: the latest streams of the peer's we have reset, gone+ -- from the stream table: see 'wasResetByMe'. } {- FOURMOLU_ENABLE -} @@ -147,11 +152,18 @@ outputBufferLimit <- newIORef buflim outputQ <- newTQueueIO outputQStreamID <- newTVarIO sid0- controlQ <- newTQueueIO+ controlQ <- newControlQ -- My SETTINGS_HEADER_TABLE_SIZE encodeDynamicTable <- newDynamicTableForEncoding defaultDynamicTableSize decodeDynamicTable <- newDynamicTableForDecoding (headerTableSize mySettings) 4096+ -- Bound the decoded size of a field block: a near-empty field or a+ -- Cookie referenced thousands of times is cheap on the wire but large+ -- once decoded (CVE-2026-49975). Our own advertised limit is enforced+ -- when one is set, and a default is used otherwise.+ setHeaderListSizeLimit+ (Just (fromMaybe defaultHeaderListSizeLimit (maxHeaderListSize mySettings)))+ decodeDynamicTable txFlow <- newTVarIO (newTxFlow defaultWindowSize) -- 64K rxFlow <- newIORef (newRxFlow connRxWS) pingRate <- newRate@@ -166,6 +178,7 @@ let workersDone = fromMaybe (T.isAllGone threadManager) mdone peerGoAway <- newTVarIO Nothing activeRequests <- newTVarIO 0+ resetByMe <- newIORef IntSet.empty return Context{..} where role = case roleInfo of@@ -330,9 +343,35 @@ then deleteEven evenStreamTable streamNumber err else deleteOdd oddStreamTable streamNumber err setStreamState ctx strm (Closed cc) -- anyway+ case cc of+ ResetByMe _+ | isServer ctx && not (isServerInitiated streamNumber) ->+ rememberReset ctx streamNumber+ _otherwise -> return () where err :: E.SomeException err = E.toException (closedCodeToError streamNumber cc)++-- | Remember that we reset a stream of the peer's.+--+-- RFC 9113, section 5.1: "An endpoint MUST ignore frames that it receives+-- on closed streams after it has sent a RST_STREAM frame." Trailers among+-- them -- the peer sent them before our reset reached it -- but once the+-- stream is gone from the table, HEADERS on it look like the reuse of a+-- stream identifier, a connection error. So the latest streams we reset+-- are remembered, 'resetByMeLimit' of them, the oldest forgotten first.+rememberReset :: Context -> StreamId -> IO ()+rememberReset Context{resetByMe} sid =+ atomicModifyIORef' resetByMe $ \s ->+ let s' = IntSet.insert sid s+ in (if IntSet.size s' > resetByMeLimit then IntSet.deleteMin s' else s', ())++-- | Whether we reset a stream of the peer's lately: see 'rememberReset'.+wasResetByMe :: Context -> StreamId -> IO Bool+wasResetByMe Context{resetByMe} sid = IntSet.member sid <$> readIORef resetByMe++resetByMeLimit :: Int+resetByMeLimit = 1000 ---------------------------------------------------------------- -- From peer
Network/HTTP2/H2/HPACK.hs view
@@ -147,8 +147,10 @@ -- closed the connection, every other stream on it with it. handl IllegalHeaderName = E.throwIO $ StreamErrorIsSent ProtocolError sid illegal+ -- Too many fields, or too large a decoded size (RFC 9113 section+ -- 6.5.2): either way, the header list is too large. handl TooLargeHeader =- E.throwIO $ StreamErrorIsSent ProtocolError sid "too many fields"+ E.throwIO $ StreamErrorIsSent ProtocolError sid "header list too large" -- A block we could not get through: our dynamic table now holds the -- entries decoded before the throw and nothing after them -- no longer -- what the peer's encoder believes we have. Section 10.5.1: "The field
Network/HTTP2/H2/OutBodyIface.hs view
@@ -112,14 +112,23 @@ return () } - finished :: IO ()- finished = atomically $ do+ -- The body is done with: it returned, or it threw. One that returned+ -- has sent all it had, and END_STREAM goes out. One that threw has+ -- not: ending the stream all the same delivered a truncated body to+ -- the peer as if it were complete. So it is cancelled instead, and+ -- the peer gets RST_STREAM (INTERNAL_ERROR).+ finished :: Maybe SomeException -> IO ()+ finished mErr = atomically $ do mTerminated <- readTVar terminated mClosed <- getIsClosed case (mClosed, mTerminated) of- (Nothing, Nothing) -> do- writeTVar terminated (Just StreamOutOfScope)- writeTBQueue tbq $ StreamingFinished Nothing+ (Nothing, Nothing) -> case mErr of+ Nothing -> do+ writeTVar terminated (Just StreamOutOfScope)+ writeTBQueue tbq $ StreamingFinished Nothing+ Just _ -> do+ writeTVar terminated (Just StreamCancelled)+ writeTBQueue tbq $ StreamingCancelled mErr (Nothing, Just _) -> -- We already terminated return ()@@ -127,4 +136,8 @@ -- Peer already closed return () - k iface `finally` finished+ -- Like 'finally', telling the two apart.+ mask $ \restore -> do+ r <- restore (k iface) `catch` \e -> finished (Just e) >> throwIO e+ finished Nothing+ return r
Network/HTTP2/H2/Queue.hs view
@@ -12,8 +12,47 @@ enqueueOutputSTM :: TQueue Output -> Output -> STM () enqueueOutputSTM outQ out = writeTQueue outQ out +newControlQ :: IO ControlQ+newControlQ = ControlQ <$> newTQueueIO <*> newTVarIO 0++-- | Never blocks: the sender itself enqueues control frames (resets), and+-- would wait for ever on a queue only it empties. {-# INLINE enqueueControl #-}-enqueueControl :: TQueue Control -> Control -> IO ()-enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl+enqueueControl :: ControlQ -> Control -> IO ()+enqueueControl (ControlQ q n) ctl = atomically $ do+ writeTQueue q ctl+ modifyTVar' n (+ 1)++dequeueControlSTM :: ControlQ -> STM Control+dequeueControlSTM (ControlQ q n) = do+ ctl <- readTQueue q+ modifyTVar' n (subtract 1)+ return ctl++isEmptyControlQ :: ControlQ -> STM Bool+isEmptyControlQ (ControlQ q _) = isEmptyTQueue q++-- | Wait until fewer than 'controlQLimit' control frames are waiting for the+-- sender. The receiver does, before reading each frame.+--+-- Most of the control frames are answers to what the peer sends:+-- RST_STREAM(REFUSED_STREAM) to a stream over our+-- SETTINGS_MAX_CONCURRENT_STREAMS, PING and SETTINGS acks, WINDOW_UPDATE.+-- A peer that does not read them blocks the sender on the socket, and if+-- we read on regardless, they pile up here without bound: a refused stream+-- is a few octets of HEADERS, and not rate-limited, since a peer is meant+-- to be able to retry it. So we stop reading a peer that does not read+-- us, until the sender has caught up -- or the receive timeout gives up on+-- it. A peer that reads loses nothing: it could not go on sending without+-- our WINDOW_UPDATEs anyway.+waitControlQ :: ControlQ -> STM ()+waitControlQ (ControlQ _ n) = do+ len <- readTVar n+ check (len < controlQLimit)++-- | How many control frames may wait for the sender before the receiver+-- stops reading: some 150 KiB of them.+controlQLimit :: Int+controlQLimit = 1000 ----------------------------------------------------------------
Network/HTTP2/H2/Receiver.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}@@ -72,6 +73,7 @@ loop1 :: IO Void loop1 = do+ atomically $ waitControlQ $ controlQ ctx hd <- confReadN frameHeaderLength -- throwing an exception on timeout when (BS.null hd) $ E.throwIO ConnectionIsClosed processFrame ctx conf $ decodeFrameHeader hd@@ -80,7 +82,9 @@ loop2 :: T.Handle -> IO Void loop2 th = do -- If 'confReadN' is timeouted, 'ConnectionIsTimeout' is thrown- -- to destroy the thread trees.+ -- 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 when (BS.null hd) $ E.throwIO ConnectionIsClosed@@ -256,8 +260,8 @@ tbl <- hpackDecodeHeader blk streamId ctx state <- onResponseHeaders ctx streamId hcl (hcEndOfStream hc) tbl processState state ctx strm streamId- Open _ (Body q _ _ tlr) -> do- state <- onTrailers ctx streamId blk q tlr+ Open _ (Body q mcl bodyLength tlr) -> do+ state <- onTrailers ctx streamId blk q mcl bodyLength tlr processState state ctx strm streamId _otherwise -> -- The block began on a stream that was open for@@ -406,15 +410,22 @@ | isServer ctx = do csid <- getPeerStreamID ctx if streamId <= csid -- consider the stream closed- then+ then do -- RFC 9113 section 5.1: "An endpoint MUST ignore frames that -- it receives on closed streams after it has sent a -- RST_STREAM frame." DATA is in that list because resetting a -- stream mid-body leaves whatever the peer already put on the- -- wire still to arrive. HEADERS is not: that would be reuse- -- of a stream identifier, which section 5.1.1 makes a- -- connection error.+ -- wire still to arrive. HEADERS is, for a stream we reset:+ -- trailers the peer sent before our reset reached it. They+ -- used to close the connection, every other stream on it with+ -- it. Their field block is still decoded, for the dynamic+ -- table ('hpackDiscardHeader'), CONTINUATION and all.+ -- HEADERS on any other closed+ -- stream is the reuse of a stream identifier, which section+ -- 5.1.1 makes a connection error.+ resetByUs <- wasResetByMe ctx streamId if ftyp `elem` [FrameData, FrameWindowUpdate, FrameRSTStream, FramePriority]+ || (ftyp `elem` [FrameHeaders, FrameContinuation] && resetByUs) then return Nothing -- will be ignored else E.throwIO $@@ -623,14 +634,14 @@ return s -- Transition (stream2)-stream FrameHeaders header@FrameHeader{flags, streamId} bs ctx s@(Open _ (Body q _ _ tlr)) _ = do+stream FrameHeaders header@FrameHeader{flags, streamId} bs ctx s@(Open _ (Body q mcl bodyLength tlr)) _ = do HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs let endOfStream = testEndStream flags -- checking frag == "" is not necessary if endOfStream then do if testEndHeader flags- then onTrailers ctx streamId frag q tlr+ then onTrailers ctx streamId frag q mcl bodyLength tlr else do startHeaderBlock ctx streamId endOfStream frag return s@@ -683,6 +694,25 @@ -- than its content-length. let len = len0 + BS.length body endOfStream = testEndStream flags+ -- RFC 9113, section 8.1.1: a body that does not add up to its+ -- content-length makes the message malformed. Checked before any+ -- of this frame is delivered: it used to be checked once the last+ -- of the body had been queued with END_STREAM, and the reader took+ -- the body for complete before the reset reached it -- a server+ -- handler, say, or a proxy that went by the content-length. Now+ -- the reader gets the reset ('closed', by 'resettable') in place of+ -- the end, and a body longer than its content-length is cut off as+ -- soon as it is. What is not queued goes back to the connection+ -- window.+ when (just mcl (len >) || (endOfStream && just mcl (len <))) $ do+ unless (connectionCreditedOnArrival streamId) $+ giveBackConnectionWindow ctx $+ BS.length body+ E.throwIO $+ StreamErrorIsSent+ ProtocolError+ streamId+ "actual body length is not the same as content-length" -- Empty Frame Flooding - CVE-2019-9518 if body == "" then unless endOfStream $ do@@ -694,30 +724,31 @@ -- Not for a stream closed since its state was read, by -- a reader that has done with it ('giveBackUnread') or a -- reset of ours: nothing would ever read it, or give it- -- back to the connection window. Checked in the same- -- transaction, so that a closer that has emptied the- -- queue finds nothing put in after it.- queued <- atomically $ do+ -- back to the connection window. Nor for one whose+ -- handler has returned ('streamDiscardBody'): nobody+ -- will read it either, and it is given back to both+ -- windows, so that the peer can send the rest and end+ -- the stream. Checked in the same transaction, so that+ -- a closer that has emptied the queue finds nothing put+ -- in after it.+ outcome <- atomically $ do st <- readTVar streamState- if isClosed st- then return False- else do+ discard <- readTVar streamDiscardBody+ if+ | isClosed st -> return Dropped+ | discard -> return Discarded+ | otherwise -> do writeTQueue q $ Right (body, endOfStream)- return True- unless (queued || connectionCreditedOnArrival streamId) $- giveBackConnectionWindow ctx $- BS.length body+ return Queued+ case outcome of+ Queued -> return ()+ Discarded -> informWindowUpdate ctx strm $ BS.length body+ Dropped ->+ unless (connectionCreditedOnArrival streamId) $+ giveBackConnectionWindow ctx $+ BS.length body if endOfStream then do- case mcl of- Nothing -> return ()- Just cl ->- when (cl /= len) $- E.throwIO $- StreamErrorIsSent- ProtocolError- streamId- "actual body length is not the same as content-length" -- no trailers atomically $ writeTQueue q $ Right (mempty, True) return HalfClosedRemote@@ -824,6 +855,17 @@ ---------------------------------------------------------------- +-- | What became of the content of a DATA frame.+data DataOutcome+ = -- | Put in the stream's queue for the reader+ Queued+ | -- | Thrown away, the reader gone ('streamDiscardBody')+ Discarded+ | -- | Thrown away, the stream closed+ Dropped++----------------------------------------------------------------+ -- | Type for input streaming. data Source = Source RxQ (Int -> IO ()) (IORef Bool) @@ -908,15 +950,31 @@ ---------------------------------------------------------------- -- | Deliver a complete trailer block: the body ends with it.+--+-- So it has to add up to its content-length, as it does when it ends with+-- END_STREAM on DATA ('stream'). It was not checked here at all: a body+-- of any length went through as long as trailers ended it. Checked once+-- the block is decoded, for the dynamic table. onTrailers :: Context -> StreamId -> HeaderBlockFragment -> TQueue (Either E.SomeException (ByteString, Bool))+ -> Maybe Int+ -- ^ content-length+ -> IORef Int+ -- ^ The length of the body received -> IORef (Maybe TokenHeaderTable) -> IO StreamState-onTrailers ctx streamId blk q tlr = do+onTrailers ctx streamId blk q mcl bodyLength tlr = do tbl <- hpackDecodeTrailer blk streamId ctx+ len <- readIORef bodyLength+ when (just mcl (/= len)) $+ E.throwIO $+ StreamErrorIsSent+ ProtocolError+ streamId+ "actual body length is not the same as content-length" writeIORef tlr (Just tbl) atomically $ writeTQueue q $ Right (mempty, True) return HalfClosedRemote
Network/HTTP2/H2/Sender.hs view
@@ -68,11 +68,22 @@ E.throwIO $ ConnectionErrorIsSent err sid msg connectionError e = E.throwIO e -checkDone :: Context -> Int -> IO (Maybe E.SomeException)-checkDone Context{..} 0 = atomically $ do- isEmptyC <- isEmptyTQueue controlQ+-- | Whether the sender is done: nothing left to send, and the receiver+-- done. Otherwise it waits for something to send.+--+-- 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+-- puts nothing in either: everything parked stayed parked, until some+-- other frame happened to come along -- and when none did, the connection+-- stalled.+checkDone :: Context -> TVar [Output] -> Int -> IO (Maybe E.SomeException)+checkDone ctx@Context{..} parked 0 = atomically $ do+ isEmptyC <- isEmptyControlQ controlQ isEmptyO <- isEmptyTQueue outputQ- if not isEmptyC || not isEmptyO+ ps <- readTVar parked+ cws <- connectionWindowSizeSTM ctx+ if not isEmptyC || not isEmptyO || (not (null ps) && cws > 0) then return Nothing else do@@ -82,7 +93,7 @@ return $ Just done _otherwise -> retry-checkDone _ _ = return Nothing+checkDone _ _ _ = return Nothing frameSender :: Context -> Config -> IO E.SomeException frameSender@@ -99,7 +110,7 @@ ---------------------------------------------------------------- loop :: TVar [Output] -> Offset -> IO E.SomeException loop parked off = do- mDone <- checkDone ctx off+ mDone <- checkDone ctx parked off case mDone of Just done -> return done@@ -138,7 +149,7 @@ -- first and in order, once there is. dequeue :: TVar [Output] -> Offset -> STM Switch dequeue parked off = do- isEmptyC <- isEmptyTQueue controlQ+ isEmptyC <- isEmptyControlQ controlQ if isEmptyC then do ps <- readTVar parked@@ -153,7 +164,7 @@ if isEmptyO then if off /= 0 then return Flush else retry else O <$> readTQueue outputQ- else C <$> readTQueue controlQ+ else C <$> dequeueControlSTM controlQ ---------------------------------------------------------------- copyAll [] buf = return buf
Network/HTTP2/H2/Settings.hs view
@@ -21,7 +21,11 @@ , maxFrameSize :: Int -- ^ SETTINGS_MAX_FRAME_SIZE , maxHeaderListSize :: Maybe Int- -- ^ SETTINGS_MAX_HEADER_LIST_SIZE+ -- ^ SETTINGS_MAX_HEADER_LIST_SIZE. Our own value is also enforced:+ -- a field block whose decoded size (RFC 9113 section 6.5.2: the+ -- length of each field's name plus its value plus 32) exceeds it+ -- resets the stream. With 'Nothing', nothing is advertised but a+ -- limit of 64 KiB is enforced all the same (CVE-2026-49975). , pingRateLimit :: Int -- ^ Maximum number of pings allowed per second (CVE-2019-9512) , emptyFrameRateLimit :: Int@@ -57,13 +61,21 @@ -- | The default settings. -- -- >>> defaultSettings--- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}+-- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Just 65536, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4} defaultSettings :: Settings defaultSettings = baseSettings { maxConcurrentStreams = Just defaultMaxStreams , initialWindowSize = defaultMaxStreamData+ , maxHeaderListSize = Just defaultHeaderListSizeLimit }++-- | The limit on the decoded size of a field block, measured as in RFC+-- 9113 section 6.5.2: 64 KiB. 'defaultSettings' advertises it as+-- SETTINGS_MAX_HEADER_LIST_SIZE, and it is enforced even when+-- 'maxHeaderListSize' is 'Nothing'.+defaultHeaderListSizeLimit :: Int+defaultHeaderListSizeLimit = 64 * 1024 ----------------------------------------------------------------
Network/HTTP2/H2/Stream.hs view
@@ -54,6 +54,7 @@ <*> newIORef (newRxFlow rxwin) <*> newIORef Nothing <*> newIORef Nothing+ <*> newTVarIO False newEvenStream :: StreamId -> WindowSize -> WindowSize -> IO Stream newEvenStream sid txwin rxwin =@@ -64,6 +65,7 @@ <*> newIORef (newRxFlow rxwin) <*> newIORef Nothing <*> newIORef Nothing+ <*> newTVarIO False ----------------------------------------------------------------
Network/HTTP2/H2/Types.hs view
@@ -155,6 +155,10 @@ , streamRequestMethod :: IORef (Maybe ByteString) -- ^ Client only: the method of the request, which decides whether the -- response may have content at all (RFC 9110, section 6.4.1)+ , streamDiscardBody :: TVar Bool+ -- ^ Server only: the handler has returned, and nobody will read the+ -- rest of the request body. It is taken in and thrown away, both+ -- windows given back as it comes, until the peer ends it. } instance Show Stream where@@ -185,6 +189,10 @@ ---------------------------------------------------------------- data Control = CFrames (Maybe SettingsList) [ByteString]++-- | Control frames waiting for the sender, and how many there are: see+-- 'Network.HTTP2.H2.Queue.waitControlQ'.+data ControlQ = ControlQ (TQueue Control) (TVar Int) ----------------------------------------------------------------
Network/HTTP2/Server/Run.hs view
@@ -33,7 +33,7 @@ -- | The default server config. -- -- >>> defaultServerConfig--- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}}+-- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Just 65536, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}} defaultServerConfig :: ServerConfig defaultServerConfig = ServerConfig
Network/HTTP2/Server/Worker.hs view
@@ -42,8 +42,11 @@ } request = Request req' lc <- newLoopCheck strm Nothing (Just th)- server request aux $ sendResponse conf ctx lc strm request- adjustRxWindow ctx strm+ server request aux (sendResponse conf ctx lc strm request)+ `E.catch` \e -> do+ resetFailedStream ctx strm e+ E.throwIO (e :: E.SomeException)+ doneWithRequestBody ctx strm where label = "H2 response sender for stream " ++ show (streamNumber strm) pauseRequestBody th = req{inpObjBody = readBody'}@@ -54,6 +57,61 @@ bs <- readBody T.resume th -- this is the same as 'tickle' return bs++-- | Called once the handler has returned: nobody reads the request body+-- from here on.+--+-- What is left of it used to be queued all the same, for a reader that was+-- gone, one entry per DATA frame. Flow control bounds the octets, not the+-- frames: a peer sending one octet a frame had us hold some ten times what+-- it sent, for as long as it kept the stream open. Nor was any of it given+-- back to the windows, so a peer still sending the rest of a body the+-- handler had not waited for -- a 404 to a POST, say -- stalled once the+-- stream's window was used up, and took the connection window with it.+--+-- So the rest is thrown away as it comes ('streamDiscardBody') and given+-- back to both windows, and the peer can send it to the end and close the+-- stream. What was already queued is given back too, and a reader still+-- there -- a thread the handler left behind -- is told.+doneWithRequestBody :: Context -> Stream -> IO ()+doneWithRequestBody ctx strm@Stream{..} = do+ atomically $ writeTVar streamDiscardBody True+ adjustRxWindow ctx strm+ mq <- readIORef streamRxQ+ forM_ mq $ \q ->+ atomically $ writeTQueue q $ Left $ E.toException CancelledStream++-- | Reset the stream of a handler that has failed: it threw, or the timeout+-- manager killed it.+--+-- Nothing else would. The response, or the rest of it, never comes, so+-- the stream stayed open: the client waited for ever, the stream held its+-- slot of our SETTINGS_MAX_CONCURRENT_STREAMS -- after that many failures+-- every new request was refused -- and, after a GOAWAY, the connection+-- never drained. A stream already closed, by a response that went out in+-- full or by a reset, is left alone.+--+-- Closed in the same transaction as it is checked, so that a reader of the+-- request body is told ('informReplaced'), and so is the sender, which+-- sends nothing more on a closed stream. What was left unread goes back+-- to the connection window.+resetFailedStream :: Context -> Stream -> E.SomeException -> IO ()+resetFailedStream ctx strm@Stream{..} e = do+ open <- atomically $ do+ st <- readTVar streamState+ if isClosed st+ then return False+ else do+ informReplaced streamNumber st (Closed cc)+ writeTVar streamState (Closed cc)+ return True+ when open $ do+ closed ctx strm cc+ enqueueControl (controlQ ctx) $+ CFrames Nothing [resetFrame InternalError streamNumber]+ giveBackUnread ctx strm+ where+ cc = ResetByMe e ----------------------------------------------------------------
bench-hpack/Main.hs view
@@ -21,7 +21,7 @@ main = do hdrs <- read <$> readFile "bench-hpack/headers.hs" hpacks <- prepare hdrs- _ <- evaluate hpacks+ _ <- E.evaluate hpacks defaultMain [ bgroup "HPACK decoding"
http2.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: http2-version: 5.4.8+version: 5.4.9 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -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.4,+ time-manager >=0.3.0 && <0.5, unix-time >=0.4.11 && <0.6, utf8-string >=1.0 && <1.1
test/HPACK/DecodeSpec.hs view
@@ -3,6 +3,7 @@ module HPACK.DecodeSpec where import Control.Monad (forM_)+import Data.Bits ((.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.String (fromString)@@ -101,6 +102,111 @@ decodeTokenHeader dtbl blk1 `shouldThrow` (== err) (tvs, _) <- decodeTokenHeader dtbl blk2 map (\(t, v) -> (tokenKey t, v)) tvs `shouldBe` [("x-after", "2")]+ it "rejects a field block whose decoded size exceeds the limit" $+ -- CVE-2026-49975: a large value inserted into the dynamic table+ -- once and then referenced expands cheaply on the wire. The+ -- decoded header list size (RFC 9113 6.5.2) is bounded all the+ -- same. The crumbs of one Cookie are the worst case, each+ -- reproducing the whole value.+ withDynamicTableForEncoding 4096 $ \etbl ->+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ setHeaderListSizeLimit (Just (64 * 1024)) dtbl+ let big = BS8.replicate 4000 'a'+ many = replicate 20 ("cookie", big) -- ~80 KiB decoded+ blk <- encodeHeader defaultEncodeStrategy 131072 etbl many+ decodeTokenHeader dtbl blk `shouldThrow` (== TooLargeHeader)+ it "accepts a field block within the limit" $+ withDynamicTableForEncoding 4096 $ \etbl ->+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ setHeaderListSizeLimit (Just (64 * 1024)) dtbl+ let big = BS8.replicate 4000 'a'+ few = replicate 5 ("cookie", big) -- ~20 KiB decoded+ blk <- encodeHeader defaultEncodeStrategy 131072 etbl few+ (tvs, _) <- decodeTokenHeader dtbl blk+ -- The crumbs are merged into one Cookie value.+ map (\(t, v) -> (tokenKey t, v)) tvs+ `shouldBe` [("cookie", BS.intercalate "; " (replicate 5 big))]+ it "does not limit the decoded size when there is no limit" $+ withDynamicTableForEncoding 4096 $ \etbl ->+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ let big = BS8.replicate 4000 'a'+ many = replicate 20 ("cookie", big)+ blk <- encodeHeader defaultEncodeStrategy 131072 etbl many+ -- No limit by default: decodes fine.+ (tvs, _) <- decodeTokenHeader dtbl blk+ length tvs `shouldBe` 1+ it "bounds a field referenced many times in the dynamic table" $+ -- Not only the crumbs of a Cookie: any field the encoder+ -- inserted once and refers to by index afterwards.+ withDynamicTableForEncoding 4096 $ \etbl ->+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ setHeaderListSizeLimit (Just (64 * 1024)) dtbl+ let big = BS8.replicate 4000 'a'+ many = replicate 20 ("x-big", big) -- ~80 KiB decoded+ blk <- encodeHeader defaultEncodeStrategy 131072 etbl many+ -- One literal, the rest are references.+ BS.length blk < 4000 + 100 `shouldBe` True+ decodeTokenHeader dtbl blk `shouldThrow` (== TooLargeHeader)+ it "bounds the pseudo-header fields too" $+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ setHeaderListSizeLimit (Just 100) dtbl+ -- 5 + 80 + 32 = 117+ let blk = literal ":path" (BS8.replicate 80 'a')+ decodeTokenHeader dtbl blk `shouldThrow` (== TooLargeHeader)+ it "accepts a field block of exactly the limit" $+ -- "x-a: 1" is 3 + 1 + 32 = 36 octets, twice 72.+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ let blk = literal "x-a" "1" <> literal "x-b" "2"+ setHeaderListSizeLimit (Just 72) dtbl+ (tvs, _) <- decodeTokenHeader dtbl blk+ map (\(t, v) -> (tokenKey t, v)) tvs+ `shouldBe` [("x-a", "1"), ("x-b", "2")]+ setHeaderListSizeLimit (Just 71) dtbl+ decodeTokenHeader dtbl blk `shouldThrow` (== TooLargeHeader)+ it "decodes the rest of a block over the limit" $+ -- As for the other malformed blocks: the field after the one+ -- over the limit still goes into the dynamic table, and the+ -- next block refers to it.+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ setHeaderListSizeLimit (Just 100) dtbl+ let blk1 =+ literal "x-big" (BS8.replicate 80 'a')+ <> incremental "x-after" "2"+ blk2 = BS.pack [0xbe]+ decodeTokenHeader dtbl blk1 `shouldThrow` (== TooLargeHeader)+ (tvs, _) <- decodeTokenHeader dtbl blk2+ map (\(t, v) -> (tokenKey t, v)) tvs `shouldBe` [("x-after", "2")]+ it "applies table size updates as if one after another" $+ -- Applied at once now, two copies of the table at most: the+ -- entries that fit in the smallest size are kept, in a table of+ -- the last size. "aa: x" and "bb: y" are 35 octets each, and 40+ -- keeps only the newer, index 62.+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ _ <- decodeHeader dtbl $ incremental "aa" "x" <> incremental "bb" "y"+ let ref62 = BS.pack [0xbe]+ ref63 = BS.pack [0xbf]+ decodeHeader dtbl (sizeUpdate 40 <> sizeUpdate 4096 <> ref62)+ `shouldReturn` [("bb", "y")]+ decodeHeader dtbl ref63 `shouldThrow` anyException+ -- The table has its last size: room for both again.+ _ <- decodeHeader dtbl $ incremental "cc" "z"+ decodeHeader dtbl (ref62 <> BS.pack [0xbf])+ `shouldReturn` [("cc", "z"), ("bb", "y")]+ it "takes any number of table size updates" $+ -- RFC 7541 needs two at most; a peer sending thousands, each+ -- one copying the table, made a block costly to decode.+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ _ <- decodeHeader dtbl $ incremental "aa" "x" <> incremental "bb" "y"+ let updates = mconcat $ replicate 1000 $ sizeUpdate 4095 <> sizeUpdate 4096+ decodeHeader dtbl (updates <> BS.pack [0xbe, 0xbf])+ `shouldReturn` [("bb", "y"), ("aa", "x")]+ it "rejects every field when the limit is zero" $+ -- A limit of zero must not be taken for no limit.+ withDynamicTableForEncoding 4096 $ \etbl ->+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ setHeaderListSizeLimit (Just 0) dtbl+ blk <- encodeHeader defaultEncodeStrategy 4096 etbl [("x-a", "1")]+ decodeTokenHeader dtbl blk `shouldThrow` (== TooLargeHeader) it "round-trips through tables small enough to fill up" $ -- Entries near the 32-octet minimum fill a table of these sizes -- to its last slot. The encoder follows the peer's@@ -134,6 +240,16 @@ -- | A literal field with a new name, with incremental indexing (6.2.1). incremental :: BS.ByteString -> BS.ByteString -> BS.ByteString incremental = field 0x40++-- | A dynamic table size update (RFC 7541, section 6.3).+sizeUpdate :: Int -> BS.ByteString+sizeUpdate n+ | n < 31 = BS.singleton (0x20 .|. fromIntegral n)+ | otherwise = BS.pack (0x3f : go (n - 31))+ where+ go m+ | m < 128 = [fromIntegral m]+ | otherwise = fromIntegral (m `mod` 128 + 128) : go (m `div` 128) -- | Names and values shorter than 127 octets. field :: Word8 -> BS.ByteString -> BS.ByteString -> BS.ByteString
test/HTTP2/ServerSpec.hs view
@@ -154,6 +154,40 @@ threadDelay 10000 runAsyncCancelClient + it "resets a stream whose response body throws" $+ -- The body was ended with END_STREAM all the same, and the client+ -- took what had been sent so far for the whole of it.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runStreamThrowClient++ it "resets a stream whose request body throws" $+ -- Likewise the other way round: the server took a truncated+ -- request body for a complete one, and answered it.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runRequestThrowClient++ it "gives back the window of requests interrupted waiting for the response" $+ -- 'timeout' fired while the client waited for the response+ -- headers, and the stream was left open: the 60000 octets of+ -- each response came in and were never given back to the+ -- connection window, so after a few the connection stalled.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ interruptedRequests $ \_ ->+ C.requestNoBody methodGet "/late-big" []++ it "gives back the window of requests interrupted sending the body" $+ -- Likewise while the request body was still going out: the+ -- stream is idle then, and its reset waits until it is not.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ interruptedRequests $ \_ ->+ C.requestStreaming methodPost "/big-after-body" [] $ \write flush -> do+ write "x" >> flush+ threadDelay 300000+ it "keeps a stream that goes on sending past the timeout" $ -- The worker's timer was only tickled by reading the request -- body, so a response streamed for longer than the timeout was@@ -416,6 +450,113 @@ timeout 5000000 malformedRequest `shouldReturn` Just ["RST_STREAM 1 ProtocolError", "HEADERS 3"] + it "resets a request whose decoded headers are too large and goes on" $+ -- The HTTP/2 Bomb (CVE-2026-49975): a field inserted into the+ -- dynamic table once and referred to again and again is cheap+ -- on the wire but large once decoded. The server advertises+ -- its limit, resets the stream over it, and keeps its dynamic+ -- table in step: the next request refers to the same entry.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 bombRequest+ `shouldReturn` Just+ [ "SETTINGS_MAX_HEADER_LIST_SIZE 65536"+ , "RST_STREAM 1 ProtocolError"+ , "HEADERS 3"+ ]++ it "resets the stream of a handler that throws and gives its slot back" $+ -- The handler throws before it responds. The stream used to be+ -- left open: no response and no RST_STREAM, so the client waited+ -- for ever, and the stream kept its slot of+ -- SETTINGS_MAX_CONCURRENT_STREAMS. With room for one stream,+ -- the next request was refused.+ E.bracket (forkIO runServerMaxConc1) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 (failingHandler "/throw")+ `shouldReturn` Just ["RST_STREAM 1 InternalError", "HEADERS 3"]++ it "resets the stream of a handler killed by the timeout" $+ -- Likewise for a handler the timeout manager kills.+ E.bracket (forkIO runServerShortTimeout) killThread $ \_ -> do+ threadDelay 10000+ timeout 10000000 (failingHandler "/hang")+ `shouldReturn` Just ["RST_STREAM 1 InternalError", "HEADERS 3"]++ it "takes in the rest of a body its handler did not wait for" $+ -- The handler answers a POST without reading the body. The rest+ -- of it was queued for nobody, and never given back to the+ -- windows: the upload stalled, and with it the connection, whose+ -- window is 64K here. The rest is now thrown away as it comes,+ -- and given back.+ E.bracket (forkIO runServerSmallConnWindow) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 unreadBody `shouldReturn` Just "100000"++ it "stops reading a peer that does not read what it sends" $+ -- A peer that never reads, with a response filling the socket, and+ -- streams over SETTINGS_MAX_CONCURRENT_STREAMS one after another.+ -- Each refusal is queued for a sender that cannot send, and the+ -- server read on regardless: the queue grew without bound. Now+ -- it stops reading, and the peer's sending blocks.+ E.bracket (forkIO runServerMaxConc1) killThread $ \_ -> do+ threadDelay 10000+ unreadFlood `shouldReturn` Nothing++ it "tells the handler of a body that does not add up to its content-length" $+ -- RFC 9113, section 8.1.1: malformed. The handler used to read+ -- the body to a clean end, and only the client heard of it: one+ -- short of its content-length was checked once its END_STREAM had+ -- been delivered, one longer only at its end, and one ending with+ -- trailers not at all.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ let short = [dataFrame 1 "0123456789" True]+ long = [dataFrame 1 "0123456789" False, dataFrame 1 "0123456789" True]+ trailers = [dataFrame 1 "0123456789" False, trailersFrame 1]+ forM_ [("100", short), ("5", long), ("100", trailers)] $ \(cl, frames) -> do+ r <- recordExchange (recordRequest cl : frames)+ r `shouldSatisfy` \x -> case x of+ Just (Left _) -> True+ _ -> False++ it "gives the handler a body that adds up to its content-length" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ let plain = [dataFrame 1 "0123456789" True]+ trailers = [dataFrame 1 "0123456789" False, trailersFrame 1]+ forM_ [plain, trailers] $ \frames ->+ recordExchange (recordRequest "10" : frames) `shouldReturn` Just (Right 10)++ it "ignores trailers on a stream it has reset" $+ -- The server resets a request whose body outgrows its+ -- content-length; the trailers the client had sent by then arrive+ -- on a stream gone from the table. They used to be taken for the+ -- reuse of a stream identifier, and closed the connection. Now+ -- they are ignored, their field block decoded all the same: the+ -- next request refers to the entry they put in the dynamic table.+ -- In one HEADERS frame, or splitBlock with a CONTINUATION.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ let whole = [trailerBlock (setEndHeader defaultFlags) indexedTrailer]+ (frag1, frag2) = B.splitAt 4 indexedTrailer+ splitBlock =+ [ trailerBlock defaultFlags frag1+ , encodeFrame (EncodeInfo (setEndHeader defaultFlags) 1 Nothing) $+ ContinuationFrame frag2+ ]+ forM_ [whole, splitBlock] $ \trailers ->+ timeout 5000000 (trailersAfterReset trailers)+ `shouldReturn` Just ["RST_STREAM 1 ProtocolError", "HEADERS 3"]++ it "closes the connection on HEADERS reusing a closed stream" $+ -- Not to be taken for the above: a stream closed without a reset+ -- of ours, its response over and gone from the table, is not to+ -- be reused (RFC 9113, section 5.1.1).+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 reuseClosedStream `shouldReturn` Just "GOAWAY ProtocolError"+ it "answers without a body while the connection window is shut" $ -- HEADERS are not flow-controlled (RFC 9113, section 6.9). The -- sender used to wait for the connection window before taking@@ -726,11 +867,20 @@ Just "/stream" -> sendResponse responseInfinite [] -- Some of the body, then cancelled with an asynchronous exception. Just "/cancel-async" -> sendResponse responseCancelAsync []+ -- Some of the body, then the body throws.+ Just "/stream-throw" -> sendResponse responseStreamThrow []+ -- 60000 octets, a moment later.+ Just "/late-big" -> threadDelay 200000 >> sendResponse response60k [] -- Longer than the timeout of 'runServerShortTimeout', a chunk at a time. Just "/drip" -> sendResponse responseDrip [] -- Like /stream, but going quietly once the client resets it. Just "/endless" -> sendResponse responseEndless [] Just "/not-modified" -> sendResponse (responseNoBody notModified304 bigLength) []+ -- A handler that fails before it responds.+ Just "/throw" -> E.throwIO $ userError "handler failed"+ -- A handler that outlives the timeout of 'runServerShortTimeout'+ -- without a word, and is killed.+ Just "/hang" -> threadDelay 10000000 >> sendResponse responseHello [] -- Says it has content, and has none: malformed. Just "/no-content" -> sendResponse (responseNoBody ok200 bigLength) [] Just "/big" -> sendResponse responseBig []@@ -745,6 +895,15 @@ Just "POST" -> case requestPath req of Just "/echo" -> sendResponse (responseEcho req) [] -- How many octets of body arrived.+ -- What the handler made of the body: how long it was, or what it+ -- was told instead of the end ('recordedBody').+ Just "/record" -> do+ let count n = do+ bs <- getRequestBodyChunk req+ if B.null bs then return n else count (n + B.length bs)+ r <- E.try $ count (0 :: Int)+ putMVar recordedBody $ either (\e -> Left (show (e :: E.SomeException))) Right r+ sendResponse responseHello [] Just "/count" -> do let count n = do bs <- getRequestBodyChunk req@@ -759,6 +918,11 @@ let d = getRequestBodyChunk req >>= \bs -> unless (B.null bs) d in d sendResponse responseBoth []+ -- 60000 octets, once the whole of the request body is in.+ Just "/big-after-body" -> do+ let d = getRequestBodyChunk req >>= \bs -> unless (B.null bs) d+ d+ sendResponse response60k [] _ -> sendResponse responseHello [] Just "HEAD" -> case requestPath req of -- HEADERS, then an empty DATA frame with END_STREAM.@@ -842,6 +1006,15 @@ outBodyFlush iface outBodyCancel iface $ Just $ E.toException AsyncCancelled +response60k :: Response+response60k = responseBuilder ok200 [] $ byteString $ B.replicate 60000 0x61++responseStreamThrow :: Response+responseStreamThrow = responseStreaming ok200 [] $ \write flush -> do+ write "partial-"+ flush+ E.throwIO $ userError "body failed"+ responseInfinite :: Response responseInfinite = responseStreaming ok200 header body where@@ -1485,6 +1658,260 @@ return ["GOAWAY " ++ show err] Just _ -> collect s +-- | A request whose 4000-octet field is inserted into the dynamic table+-- and referred to 16 times more, about 68 KiB decoded, then one referring+-- to it once: the SETTINGS_MAX_HEADER_LIST_SIZE the server advertises, and+-- what it answers.+bombRequest :: IO [String]+bombRequest = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let pseudo =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]+ request sid blk =+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $+ HeadersFrame Nothing blk+ big = C8.replicate 4000 'a'+ -- A literal with a new name, with incremental indexing (RFC 7541,+ -- section 6.2.1): index 62 from now on.+ insert =+ B.singleton 0x40+ <> unsafePerformIO (encodeInteger 7 5)+ <> "x-big"+ <> unsafePerformIO (encodeInteger 7 (B.length big))+ <> big+ ref = B.singleton 0xbe+ sendAll s $ request 1 $ pseudo <> insert <> mconcat (replicate 16 ref)+ sendAll s $ request 3 $ pseudo <> ref+ collect s+ where+ collect s = do+ mf <- recvFrame s+ case mf of+ Nothing -> return []+ Just (FrameSettings, fh, p)+ | not (testAck (flags fh))+ , Right (SettingsFrame alist) <- decodeSettingsFrame fh p ->+ let lim = lookup SettingsMaxHeaderListSize alist+ in (maybe id (\x -> (("SETTINGS_MAX_HEADER_LIST_SIZE " ++ show x) :)) lim)+ <$> collect s+ Just (FrameHeaders, fh, _)+ | streamId fh == 3 -> return ["HEADERS 3"]+ Just (FrameRSTStream, fh, p)+ | Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p ->+ (("RST_STREAM " ++ show (streamId fh) ++ " " ++ show err) :) <$> collect s+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return ["GOAWAY " ++ show err]+ Just _ -> collect s++-- | A request to a handler that fails, and once its stream is reset, a+-- request to one that answers: what the server says about each.+--+-- The second request goes out only after the first stream is reset, so+-- that a server with room for one stream has given the slot back if it+-- ever will. PINGs keep the connection from timing out meanwhile.+failingHandler :: ByteString -> IO [String]+failingHandler path = runTCPClient host port $ \s -> do+ lock <- newMVar ()+ let sendFrame bs = withMVar lock $ \_ -> sendAll s bs+ request sid p =+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $+ HeadersFrame Nothing $+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", p)+ , (":method", "GET")+ ]+ ping = encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ PingFrame "01234567"+ pinger = forever $ threadDelay 300000 >> sendFrame ping+ sendFrame connectionPreface+ sendFrame $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ sendFrame $ request 1 path+ withAsync pinger $ \_ -> collect s sendFrame request False+ where+ collect s sendFrame request sent = do+ mf <- recvFrame s+ case mf of+ Nothing -> return []+ Just (FrameHeaders, fh, _)+ | streamId fh == 1 -> return ["HEADERS 1"]+ | streamId fh == 3 -> return ["HEADERS 3"]+ Just (FrameRSTStream, fh, p)+ | Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p -> do+ unless (sent || streamId fh /= 1) $ sendFrame $ request 3 "/"+ (("RST_STREAM " ++ show (streamId fh) ++ " " ++ show err) :)+ <$> collect s sendFrame request (sent || streamId fh == 1)+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return ["GOAWAY " ++ show err]+ Just _ -> collect s sendFrame request sent++-- | Never reading, an endless response with all the room it wants, then+-- 200000 streams over the limit: whether they all go out within 5 seconds.+unreadFlood :: IO (Maybe ())+unreadFlood = runTCPClient host port $ \s -> do+ let maxWindow = 2147483647+ request sid path =+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $+ HeadersFrame Nothing $+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", path)+ , (":method", "GET")+ ]+ sendAll s connectionPreface+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $+ SettingsFrame [(SettingsInitialWindowSize, maxWindow)]+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $+ WindowUpdateFrame (maxWindow - defaultWindowSize)+ sendAll s $ request 1 "/endless"+ -- Time for the response to fill the socket.+ threadDelay 200000+ timeout 5000000 $+ forM_ [3, 5 .. 400001] $+ \sid -> sendAll s $ request sid "/"++-- | A literal field with a new name and incremental indexing (RFC 7541,+-- section 6.2.1): index 62 once decoded.+indexedTrailer :: ByteString+indexedTrailer = B.pack [0x40, 9] <> "x-trailer" <> B.pack [1] <> "1"++-- | HEADERS with END_STREAM on stream 1: trailers.+trailerBlock :: FrameFlags -> ByteString -> ByteString+trailerBlock flags' frag =+ encodeFrame (EncodeInfo (setEndStream flags') 1 Nothing) $+ HeadersFrame Nothing frag++-- | A GET on stream 1, and once its response is over, another HEADERS on+-- stream 1: what the server says to that.+reuseClosedStream :: IO String+reuseClosedStream = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ sendAll s $ openStreamFrame' 1+ let awaitEnd = do+ mf <- recvFrame s+ case mf of+ Just (FrameData, fh, _) | testEndStream (flags fh) -> return ()+ Just _ -> awaitEnd+ Nothing -> return ()+ collect = do+ mf <- recvFrame s+ case mf of+ Nothing -> return "closed"+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return $ "GOAWAY " ++ show err+ Just _ -> collect+ awaitEnd+ -- The stream is closed once the response is out; a moment for the+ -- server to have taken it out of the table.+ threadDelay 100000+ sendAll s $ openStreamFrame' 1+ collect++-- | A GET on a stream, ending it.+openStreamFrame' :: StreamId -> ByteString+openStreamFrame' sid =+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $+ HeadersFrame Nothing $+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]++-- | A body outgrowing its content-length, which the server resets; once it+-- has, the given trailers on that stream, then a request referring to index+-- 62 of the dynamic table. What the server says.+trailersAfterReset :: [ByteString] -> IO [String]+trailersAfterReset trailers = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ sendAll s $ recordRequest "5"+ sendAll s $ dataFrame 1 "0123456789" False+ collect s+ where+ sendTrailers s = do+ mapM_ (sendAll s) trailers+ sendAll s $+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) 3 Nothing) $+ HeadersFrame Nothing $+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]+ <> B.singleton 0xbe+ collect s = do+ mf <- recvFrame s+ case mf of+ Nothing -> return []+ Just (FrameHeaders, fh, _)+ | streamId fh == 3 -> return ["HEADERS 3"]+ Just (FrameRSTStream, fh, p)+ | Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p -> do+ when (streamId fh == 1) $ sendTrailers s+ (("RST_STREAM " ++ show (streamId fh) ++ " " ++ show err) :) <$> collect s+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return ["GOAWAY " ++ show err]+ Just _ -> collect s++-- | What the handler of /record made of the body it was sent.+recordedBody :: MVar (Either String Int)+recordedBody = unsafePerformIO newEmptyMVar+{-# NOINLINE recordedBody #-}++-- | Send raw frames, and what the handler of /record made of the body.+--+-- The connection stays open until the handler has said, or it would take+-- the connection closing under it for what it is told.+recordExchange :: [ByteString] -> IO (Maybe (Either String Int))+recordExchange out = runTCPClient host port $ \s -> do+ _ <- tryTakeMVar recordedBody+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ mapM_ (sendAll s) out+ timeout 5000000 $ takeMVar recordedBody++-- | A POST to /record with the given content-length, its body to follow.+recordRequest :: ByteString -> ByteString+recordRequest cl =+ encodeFrame (EncodeInfo (setEndHeader defaultFlags) 1 Nothing) $+ HeadersFrame Nothing $+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/record")+ , (":method", "POST")+ , ("content-length", cl)+ ]++dataFrame :: StreamId -> ByteString -> Bool -> ByteString+dataFrame sid body end =+ encodeFrame (EncodeInfo flags' sid Nothing) $ DataFrame body+ where+ flags' = if end then setEndStream defaultFlags else defaultFlags++trailersFrame :: StreamId -> ByteString+trailersFrame sid =+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $+ HeadersFrame Nothing $+ hpackEncode [("x-trailer", "1")]+ -- | /endless until the server has used up the connection window, which we -- do not open, then a request whose answer has no body: what the server -- sends for it. Then the windows opened a little: whether the body held@@ -1753,6 +2180,98 @@ C.responseStatus rsp `shouldBe` Just ok200 where cliconf = C.defaultClientConfig{C.authority = host}++runStreamThrowClient :: IO ()+runStreamThrowClient = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cliconf conf $ \sendRequest _aux -> do+ let req = C.requestNoBody methodGet "/stream-throw" []+ drain rsp = do+ bs <- C.getResponseBodyChunk rsp+ unless (B.null bs) $ drain rsp+ sendRequest req drain `shouldThrow` resetWith C.InternalError+ let good = C.requestNoBody methodGet "/" []+ sendRequest good $ \rsp ->+ C.responseStatus rsp `shouldBe` Just ok200+ where+ cliconf = C.defaultClientConfig{C.authority = host}++-- | A request whose streaming body throws after "partial-": what+-- the server makes of it must not be an answer to an 8-octet body.+runRequestThrowClient :: IO ()+runRequestThrowClient = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cliconf conf $ \sendRequest _aux -> do+ let req = C.requestStreaming methodPost "/count" [] $ \write flush -> do+ write "partial-"+ flush+ threadDelay 10000+ E.throwIO $ userError "body failed"+ body rsp acc = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return acc else body rsp (acc <> bs)+ r <- E.try $ sendRequest req $ \rsp -> body rsp ""+ case r :: Either C.HTTP2Error ByteString of+ Left _ -> return ()+ Right bs -> expectationFailure $ "answered: " ++ show bs+ let good = C.requestNoBody methodGet "/" []+ sendRequest good $ \rsp ->+ C.responseStatus rsp `shouldBe` Just ok200+ where+ cliconf = C.defaultClientConfig{C.authority = host}++-- | Three requests, each interrupted by 'timeout' 100 ms in, before any+-- response, on a connection window of 100000 octets. Then a request for+-- the 60000 octets of /late-big, which must still come in full.+interruptedRequests :: (Int -> C.Request) -> IO ()+interruptedRequests mkreq = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cliconf conf $ \sendRequest _aux -> do+ let body rsp n = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return n else body rsp (n + B.length bs)+ forM_ [1 .. 3] $ \i ->+ timeout 100000 (sendRequest (mkreq i) $ \rsp -> body rsp 0)+ `shouldReturn` Nothing+ -- The interrupted responses come in meanwhile.+ threadDelay 500000+ let req = C.requestNoBody methodGet "/late-big" []+ timeout 3000000 (sendRequest req $ \rsp -> body rsp 0)+ `shouldReturn` Just 60000+ where+ cliconf =+ C.defaultClientConfig+ { C.authority = host+ , C.connectionWindowSize = 100000+ }++-- | A POST of 200000 octets to a handler that does not read them, then a+-- POST of 100000 octets to /count: what /count says.+unreadBody :: IO ByteString+unreadBody = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cliconf conf $ \sendRequest _aux -> do+ let upload path n = C.requestStreaming methodPost path [] $ \write flush ->+ replicateM_ (n `div` 1000) $+ write (byteString (C8.replicate 1000 'a')) >> flush+ body rsp acc = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return acc else body rsp (acc <> bs)+ -- The response read to the end, or the client would reset the+ -- stream itself ('doneWithStream') and send no more of the body.+ sendRequest (upload "/" 200000) $ \rsp ->+ body rsp ""+ `shouldReturn` "Hello, world!\n"+ -- Time for the rest of the first body to use up what it can of+ -- the connection window.+ threadDelay 300000+ sendRequest (upload "/count" 100000) $ \rsp -> body rsp ""+ where+ cliconf = C.defaultClientConfig{C.authority = host}++resetWith :: C.ErrorCode -> Selector C.HTTP2Error+resetWith ec (C.StreamResetIsReceived ec' _) = ec == ec'+resetWith _ _ = False streamWasReset :: Selector C.HTTP2Error streamWasReset C.StreamResetIsReceived{} = True