http2 5.4.6 → 5.4.9
raw patch · 28 files changed
Files
- ChangeLog.md +92/−72
- Network/HPACK.hs +2/−0
- Network/HPACK/HeaderBlock/Decode.hs +115/−34
- Network/HPACK/Huffman/Decode.hs +21/−6
- Network/HPACK/Table.hs +2/−0
- Network/HPACK/Table/Dynamic.hs +27/−2
- Network/HPACK/Types.hs +2/−1
- Network/HTTP2/Client/Run.hs +71/−11
- Network/HTTP2/H2/Config.hs +8/−3
- Network/HTTP2/H2/Context.hs +165/−13
- Network/HTTP2/H2/HPACK.hs +25/−13
- Network/HTTP2/H2/OutBodyIface.hs +19/−6
- Network/HTTP2/H2/Queue.hs +41/−2
- Network/HTTP2/H2/Receiver.hs +159/−33
- Network/HTTP2/H2/Sender.hs +77/−35
- Network/HTTP2/H2/Settings.hs +14/−2
- Network/HTTP2/H2/Stream.hs +2/−0
- Network/HTTP2/H2/Sync.hs +6/−2
- Network/HTTP2/H2/Types.hs +8/−0
- Network/HTTP2/H2/Window.hs +57/−23
- Network/HTTP2/Server/Run.hs +1/−1
- Network/HTTP2/Server/Worker.hs +75/−14
- bench-hpack/Main.hs +1/−1
- http2.cabal +2/−2
- test/HPACK/DecodeSpec.hs +180/−0
- test/HPACK/HuffmanSpec.hs +4/−0
- test/HTTP2/FrameSpec.hs +4/−4
- test/HTTP2/ServerSpec.hs +2125/−908
ChangeLog.md view
@@ -1,101 +1,121 @@ # 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+ closing the connection.+ [#214](https://github.com/kazu-yamamoto/http2/pull/214)+* Server: tickle the worker's timer on sending, so that a response+ streamed longer than the timeout is not killed.+ [#174](https://github.com/kazu-yamamoto/http2/pull/174)+* `freeSimpleConfig` no longer calls the no-op `killManager`.+ Timeout actions registered with `confTimeoutManager` must be+ cancelled by their owner.+ [#215](https://github.com/kazu-yamamoto/http2/pull/215)++## 5.4.7++* Decode a Huffman-coded field value longer than 4096 octets.+ [#201](https://github.com/kazu-yamamoto/http2/pull/201)+* Accept a header block with no fields, as empty trailers are sent.+ [#202](https://github.com/kazu-yamamoto/http2/pull/202)+* Decode a malformed field block to the end and reset only its stream.+ [#211](https://github.com/kazu-yamamoto/http2/pull/211)+* Give the padding of DATA frames back to the flow control windows.+ [#204](https://github.com/kazu-yamamoto/http2/pull/204)+* Charge refused or ignored DATA to the connection window.+ [#205](https://github.com/kazu-yamamoto/http2/pull/205)+* Client: reset with CANCEL a response not read to the end.+ [#207](https://github.com/kazu-yamamoto/http2/pull/207)+* Client: give back the window used by unwanted pushes.+ [#208](https://github.com/kazu-yamamoto/http2/pull/208)+* Do not count padding into the length checked against content-length.+ [#203](https://github.com/kazu-yamamoto/http2/pull/203)+* Make no push when the client allows no concurrent streams.+ [#206](https://github.com/kazu-yamamoto/http2/pull/206)+* Include running streams in the last stream identifier of GOAWAY.+ [#209](https://github.com/kazu-yamamoto/http2/pull/209)+* Let streams up to the last stream identifier finish after a GOAWAY+ with NO_ERROR.+ [#210](https://github.com/kazu-yamamoto/http2/pull/210)+* Send frames other than DATA while the connection window is shut.+ [#212](https://github.com/kazu-yamamoto/http2/pull/212)+ ## 5.4.6 -* Security: a regression in 5.4.5. Since stream errors reset the stream- rather than the connection, a peer could have the server reset streams- for it -- with a PRIORITY on a stream depending on itself, DATA on a- half-closed stream, and the like -- and so free concurrency slots while- the handlers went on running, without ever sending RST_STREAM itself- (MadeYouReset, CVE-2025-8671). Resets we send because of the peer now- count against `rstRateLimit` with the peer's own.+* Security: count the resets we send against `rstRateLimit`+ (MadeYouReset, CVE-2025-8671). [#190](https://github.com/kazu-yamamoto/http2/pull/190)-* Security: a PRIORITY frame for a stream that was never opened created- the stream and took a concurrency slot for good, so 64 PRIORITY frames- were enough to have every later request refused.+* Security: do not create a stream for a PRIORITY frame. [#195](https://github.com/kazu-yamamoto/http2/pull/195)-* Security: a SETTINGS_INITIAL_WINDOW_SIZE that overflowed a stream's- window stopped the sender without a word, leaving the connection open- and silent. It is now a connection error of type FLOW_CONTROL_ERROR,- and any failure of the sender closes the connection.+* Security: treat an overflowing SETTINGS_INITIAL_WINDOW_SIZE as+ FLOW_CONTROL_ERROR. [#196](https://github.com/kazu-yamamoto/http2/pull/196)-* The HPACK dynamic table lost entries, or had the encoder send the wrong- one (index 61 of the static table), once it held as many entries as it- has room for -- which a small or odd SETTINGS_HEADER_TABLE_SIZE from the- peer makes easy. Headers were silently wrong on both sides.+* Fix the HPACK dynamic table when it is full. [#192](https://github.com/kazu-yamamoto/http2/pull/192)-* A Huffman-coded string of 16K or more was corrupted by the encoder: the- length's fourth octet overwrote the start of the code.+* Fix encoding a Huffman-coded string of 16K or more. [#188](https://github.com/kazu-yamamoto/http2/pull/188)-* Header blocks and trailers larger than a frame are sent and received as- HEADERS and CONTINUATION frames, and the header blocks of streams that- are already reset are still decoded, so that the HPACK tables stay in- step. Thanks to Edsko de Vries.+* Send and receive large header blocks with CONTINUATION frames, and keep+ decoding the header blocks of reset streams. Thanks to Edsko de Vries. [#187](https://github.com/kazu-yamamoto/http2/pull/187) [#189](https://github.com/kazu-yamamoto/http2/pull/189)-* A race between the receiver and the sender lost a stream's half-closed- state, so that it was never removed from the stream table: with both- ends streaming, a client ran out of streams and a server refused every- new one.+* Fix a race that lost a stream's half-closed state. [#193](https://github.com/kazu-yamamoto/http2/pull/193)-* A client no longer rejects a response that has no content but a- non-zero content-length, as responses to HEAD and 304 responses do.+* Client: accept a response with no content but a non-zero+ content-length. [#194](https://github.com/kazu-yamamoto/http2/pull/194)-* A client request that failed before it was queued -- a `requestFile` for- a file that cannot be opened, say -- made every later request on the- connection wait for ever.+* Client: a request that fails before it is queued no longer blocks later+ ones. [#198](https://github.com/kazu-yamamoto/http2/pull/198)-* Server push: a PUSH_PROMISE could come after the response it belongs- to, and pushed streams were never closed, so a connection stopped after- 64 pushes.+* Server push: send PUSH_PROMISE before the response and close pushed+ streams. [#199](https://github.com/kazu-yamamoto/http2/pull/199)-* An upload through `runIO` larger than the stream's window was cut short- with END_STREAM after the first window's worth.+* Fix an upload through `runIO` larger than the stream's window. [#200](https://github.com/kazu-yamamoto/http2/pull/200)-* GHC 9.12 and later, with `-O`, miscompile a value holding a- never-returning streaming body into one with no body- ([GHC #27857](https://gitlab.haskell.org/ghc/ghc/-/work_items/27857)).- The test suite works around it.+* Tests: work around a GHC 9.12 miscompilation. [#197](https://github.com/kazu-yamamoto/http2/pull/197) ## 5.4.5 -* Security: frame payload decoders read their fixed-size fields without- checking that the payload holds them, so a truncated frame, or padding- covering a field, read past the end of the buffer -- and an empty payload- is the shared empty `ByteString`, whose pointer is null. An- unauthenticated peer could segfault the process with 33 bytes.+* Security: check the length of a frame payload before decoding its+ fixed-size fields. [#182](https://github.com/kazu-yamamoto/http2/pull/182)-* Security: HPACK integer decoding overflowed `Int` silently, so a long- enough encoding decoded to whatever value the sender aimed at and two- different byte strings could decode to the same header. Integers are now- bounded and over-long encodings are a decoding error, as RFC 7541- section 5.1 requires.+* Security: bound HPACK integer decoding. [#181](https://github.com/kazu-yamamoto/http2/pull/181)-* A RST_STREAM gave a stream's concurrency slot back twice, so a peer could- walk `SETTINGS_MAX_CONCURRENT_STREAMS` upwards and hold open as many- streams as it liked.+* Give a stream's concurrency slot back only once on RST_STREAM. [#178](https://github.com/kazu-yamamoto/http2/pull/178)-* A stream reset while its response was still being produced left the- worker blocked until the timeout manager killed it, one thread per reset- stream.+* Stop the worker of a stream reset while its response is produced. [#179](https://github.com/kazu-yamamoto/http2/pull/179)-* Stream errors now reset the stream and the connection carries on, as- RFC 9113 section 5.4.2 requires. A field block abandoned part-way is- still a connection error, since the HPACK tables have diverged by then.+* Reset the stream, not the connection, on a stream error. [#183](https://github.com/kazu-yamamoto/http2/pull/183)-* A stream over `SETTINGS_MAX_CONCURRENT_STREAMS` is refused with- RST_STREAM(REFUSED_STREAM) rather than ending the connection.+* Refuse a stream over `SETTINGS_MAX_CONCURRENT_STREAMS` with+ RST_STREAM(REFUSED_STREAM). [#184](https://github.com/kazu-yamamoto/http2/pull/184)-* `DecodeError` has a new constructor, `TooLargeInteger`. Strictly this is- a breaking change -- an exhaustive match on `DecodeError` no longer- compiles -- but it ships as a patch version on purpose: no package on- Hackage names any constructor of that type, while a minor bump would- shut out every dependant carrying a `< 5.5` bound, these security fixes- along with it.-* A malformed request now reaches a client as `StreamResetIsReceived` on- the stream it concerns, where it used to arrive as- `ConnectionErrorIsReceived` on the connection.+* `DecodeError` has a new constructor, `TooLargeInteger`.+* A malformed request reaches a client as `StreamResetIsReceived`. ## 5.4.4
Network/HPACK.hs view
@@ -22,6 +22,8 @@ withDynamicTableForEncoding, withDynamicTableForDecoding, setLimitForEncoding,+ setHeaderListSizeLimit,+ getHeaderListSizeLimit, -- * Strategy for encoding CompressionAlgo (..),
Network/HPACK/HeaderBlock/Decode.hs view
@@ -37,7 +37,6 @@ -- -- * Headers are decoded as is. -- * 'DecodeError' would be thrown if the HPACK format is broken.--- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. decodeHeader :: DynamicTable -> ByteString@@ -57,38 +56,70 @@ -- 'IllegalHeaderName' is thrown. -- * If a header key contains capital letters, -- 'IllegalHeaderName' is thrown.+-- * If the number of header fields is too large,+-- 'TooLargeHeader' is thrown.+-- * 'IllegalHeaderName' and 'TooLargeHeader' are thrown only once the+-- 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.--- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. decodeTokenHeader :: DynamicTable -> 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- w <- read8 rbuf- if isTableSizeUpdate w- then do- tableSizeUpdate dyntbl w rbuf- chkChange rbuf+ 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 apply mupd >> dec rbuf else do- ff rbuf (-1)- dec rbuf+ w <- read8 rbuf+ if isTableSizeUpdate w+ then do+ 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]'. -- -- * Headers are decoded as is. -- * 'DecodeError' would be thrown if the HPACK format is broken.--- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small. decodeSimple :: (Word8 -> ReadBuffer -> IO TokenHeader) -> ReadBuffer@@ -124,64 +155,96 @@ -- 'IllegalHeaderName' is thrown. -- * If the number of header fields is too large, -- 'TooLargeHeader' is thrown+-- * 'IllegalHeaderName' and 'TooLargeHeader' are thrown only once the+-- 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.--- * 'BufferOverrun' will be thrown if the temporary buffer for Huffman decoding is too small.+--+-- 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 -- duplicated- when (isJust mx) $ E.throwIO IllegalHeaderName+ when (isJust mx) $ malformed IllegalHeaderName -- unknown- when (isMaxTokenIx tokenIx) $ E.throwIO IllegalHeaderName+ 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 == "") $ E.throwIO IllegalHeaderName+ when (tokenKey == "") $ malformed IllegalHeaderName when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $- E.throwIO IllegalHeaderName+ 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- | n > headerLimit = E.throwIO TooLargeHeader+ normal n siz builder cookie+ | n > headerLimit = malformed TooLargeHeader | otherwise = do leftover <- remainingSize rbuf if leftover >= 1 then do w <- read8 rbuf tv@(Token{..}, v) <- decTokenHeader w rbuf- when isPseudo $ E.throwIO IllegalHeaderName+ when isPseudo $ malformed IllegalHeaderName -- 0-Length Headers Leak - CVE-2019-9516- when (tokenKey == "") $ E.throwIO IllegalHeaderName+ when (tokenKey == "") $ malformed IllegalHeaderName when (isMaxTokenIx tokenIx && B8.any isUpper (original tokenKey)) $- E.throwIO IllegalHeaderName+ 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@@ -193,6 +256,22 @@ unsafeWrite arr cookieTokenIx (Just v) return tvs + -- A field that makes the message malformed, as opposed to the block.+ -- The rest of the block is decoded all the same, and only then is the+ -- error thrown: every field of it may change the dynamic table, and one+ -- left undecoded leaves our table out of step with the peer's encoder,+ -- so that nothing after it on the connection decodes. So decoded, a+ -- malformed message can be refused on its own (RFC 9113, section 8.1.1:+ -- a stream error), rather than with the connection.+ malformed :: DecodeError -> IO a+ malformed err = skipRest >> E.throwIO err+ skipRest = do+ leftover <- remainingSize rbuf+ when (leftover >= 1) $ do+ w <- read8 rbuf+ _ <- decTokenHeader w rbuf+ skipRest+ toTokenHeader :: DynamicTable -> Word8 -> ReadBuffer -> IO TokenHeader toTokenHeader dyntbl w rbuf | w `testBit` 7 = indexed dyntbl w rbuf@@ -201,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/Huffman/Decode.hs view
@@ -59,11 +59,26 @@ -> Int -- ^ The target length -> IO ByteString-decodeH gcbuf bufsiz rbuf len = withForeignPtr gcbuf $ \buf -> do- wbuf <- newWriteBuffer buf bufsiz- decH wbuf rbuf len- toByteString wbuf+decodeH gcbuf bufsiz rbuf len+ -- The working space is only a cache. A value that may not fit gets a+ -- buffer of its own: running out of room part-way used to throw+ -- 'BufferOverrun', which the header block decoder reported as a+ -- truncated block, so a valid field longer than the working space+ -- (a long Huffman-coded @authorization@, say) closed the connection.+ | maxDecodedLength len > bufsiz =+ withWriteBuffer (maxDecodedLength len) $ \wbuf -> decH wbuf rbuf len+ | otherwise = withForeignPtr gcbuf $ \buf -> do+ wbuf <- newWriteBuffer buf bufsiz+ decH wbuf rbuf len+ toByteString wbuf +-- | The longest a Huffman-coded string of this many octets can decode to.+--+-- The shortest code is 5 bits long (RFC 7541, Appendix B), so each+-- decoded octet takes at least 5 of the input's bits.+maxDecodedLength :: Int -> Int+maxDecodedLength len = len * 8 `div` 5+ -- | Low devel Huffman decoding in a write buffer. decH :: WriteBuffer -> ReadBuffer -> Int -> IO () decH wbuf rbuf len = go len (way256 `unsafeAt` 0)@@ -88,9 +103,9 @@ write8 wbuf v2 return $ way256 `unsafeAt` fromIntegral n --- | Huffman decoding with a temporary buffer whose size is 4096.+-- | Huffman decoding. decodeHuffman :: ByteString -> IO ByteString-decodeHuffman bs = withWriteBuffer 4096 $ \wbuf ->+decodeHuffman bs = withWriteBuffer (max 1 $ maxDecodedLength $ BS.length bs) $ \wbuf -> withReadBuffer bs $ \rbuf -> decH wbuf rbuf $ BS.length bs ----------------------------------------------------------------
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 ()@@ -222,7 +244,8 @@ :: Size -- ^ The dynamic table size -> Size- -- ^ The size of temporary buffer for Huffman decoding+ -- ^ The size of temporary buffer for Huffman decoding.+ -- A longer value is decoded in a buffer of its own. -> IO DynamicTable newDynamicTableForDecoding maxsiz huftmpsiz = do lim <- newIORef maxsiz@@ -241,6 +264,7 @@ <*> newIORef maxN -- maxNumOfEntries <*> newIORef 0 -- dynamicTableSize <*> newIORef maxsiz -- maxDynamicTableSize+ <*> newIORef Nothing -- headerListSizeLimit (no limit) where maxN = maxNumbers maxsiz end = maxN - 1@@ -309,7 +333,8 @@ :: Size -- ^ The dynamic table size -> Size- -- ^ The size of temporary buffer for Huffman+ -- ^ The size of temporary buffer for Huffman decoding.+ -- A longer value is decoded in a buffer of its own. -> (DynamicTable -> IO a) -> IO a withDynamicTableForDecoding maxsiz huftmpsiz action =
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@@ -89,15 +89,20 @@ False "Haskell!" -- 8 bytes }- clientCore ctx req processResponse = do+ clientCore ctx req processResponse = counted ctx $ do (strm, moutobj) <- makeStream ctx scheme authority req case moutobj of Nothing -> return () Just outobj -> sendRequest conf ctx strm outobj False- rsp <- getResponse strm- x <- processResponse rsp- adjustRxWindow ctx strm- return x+ -- 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 =+ E.bracket_+ (atomically $ modifyTVar' (activeRequests ctx) (+ 1))+ (atomically $ modifyTVar' (activeRequests ctx) (subtract 1)) runClient ctx = client (clientCore ctx) $ aux ctx -- | Launching a receiver and a sender.@@ -117,6 +122,44 @@ action $ ClientIO confMySockAddr confPeerSockAddr putR get putB create runH2 conf ctx runClient +-- | 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+-- the stream's slot of the server's SETTINGS_MAX_CONCURRENT_STREAMS, and+-- the octets that came in were never given back to the connection window.+-- 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+ then do+ enqueueControl (controlQ ctx) $+ CFrames Nothing [resetFrame Cancel $ streamNumber strm]+ giveBackUnread ctx strm+ else adjustRxWindow ctx strm+ getResponse :: Stream -> IO Response getResponse strm = do mRsp <- takeMVar $ streamInput strm@@ -149,10 +192,27 @@ runSender = frameSender ctx conf runClientReceiver = do labelMe "H2 ClientReceiver"- er <- race runReceiver runClient- case er of- Right r -> return r- Left err -> E.throwIO err+ withAsync runReceiver $ \ar ->+ withAsync runClient $ \ac -> do+ er <- waitEither ar ac+ case er of+ Right r -> return r+ Left err -> do+ goingaway <- isJust <$> readTVarIO (peerGoAway ctx)+ case E.fromException err of+ -- The connection has run its course after the+ -- server's GOAWAY. The client function is let+ -- finish, rather than killed with it: every+ -- request it makes from here is refused, and+ -- one still waiting is failed now.+ Just ConnectionIsClosed+ | goingaway -> do+ closeAllStreams+ (oddStreamTable ctx)+ (evenStreamTable ctx)+ (Just err)+ wait ac+ _ -> E.throwIO err -- When 'runClientReceiver' terminates, it is important we give the sender -- a chance to terminate cleanly also (it's possible the client terminated@@ -248,7 +308,7 @@ else do (pop, out) <- makeOutput strm ot pushOutput sid out `E.onException` abandon sid- lc <- newLoopCheck strm mtbq+ lc <- newLoopCheck strm mtbq Nothing T.forkManaged threadManager label $ syncWithSender' ctx pop lc where label = "H2 request sender for stream " ++ show (streamNumber strm)
Network/HTTP2/H2/Config.hs view
@@ -37,7 +37,12 @@ return Config{..} -- | Deallocating the resource of the simple configuration.+--+-- This does not cancel timeout actions registered with+-- 'confTimeoutManager'. Since time-manager 0.3, a manager holds no+-- registrations, so there is nothing to kill: an action registered with+-- 'System.TimeManager.register' runs even after this returns unless it+-- is cancelled with 'System.TimeManager.cancel'. Use+-- 'System.TimeManager.withHandle', which cancels it when the scope ends. freeSimpleConfig :: Config -> IO ()-freeSimpleConfig conf = do- free $ confWriteBuffer conf- T.killManager $ confTimeoutManager conf+freeSimpleConfig conf = free $ confWriteBuffer conf
Network/HTTP2/H2/Context.hs view
@@ -7,6 +7,8 @@ import Control.Concurrent.STM 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@@ -14,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@@ -72,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@@ -91,6 +94,16 @@ -- ^ Client only: called when a 1xx informational response (e.g. 103 Early -- Hints) is received, ahead of the final response. Copied from -- 'confOnInformational'; no-op by default.+ , peerGoAway :: TVar (Maybe StreamId)+ -- ^ The last stream identifier of the peer's GOAWAY(NO_ERROR), once+ -- one has come: see 'goingAway'.+ , activeRequests :: TVar Int+ -- ^ 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 -} @@ -139,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@@ -156,6 +176,9 @@ receiverDone <- newTVarIO Nothing let informationalCallback = confOnInformational let workersDone = fromMaybe (T.isAllGone threadManager) mdone+ peerGoAway <- newTVarIO Nothing+ activeRequests <- newTVarIO 0+ resetByMe <- newIORef IntSet.empty return Context{..} where role = case roleInfo of@@ -289,16 +312,67 @@ closeHalf (Open Nothing o) = (False, Open (Just cc) o) closeHalf _ = (False, Open (Just cc) JustOpened) +-- | Closing a stream whose response is still coming in, and saying+-- whether it was.+--+-- Decided and done in one transaction, so that a stream the peer finishes+-- meanwhile is not taken for one still open. A response whose END_STREAM+-- the receiver has already queued, and not yet recorded in the state, can+-- still be taken for one coming in; the reset that follows is one RFC 9113+-- section 5.1 has the peer ignore ("for a short period after a DATA or+-- HEADERS frame containing an END_STREAM flag is sent").+closeIfReceiving :: Context -> Stream -> ClosedCode -> IO Bool+closeIfReceiving ctx strm@Stream{streamNumber, streamState} cc = do+ receiving <- atomically $ do+ st <- readTVar streamState+ case st of+ -- END_STREAM came with the headers.+ Open _ (NoBody _) -> return False+ Open{} -> do+ informReplaced streamNumber st (Closed cc)+ writeTVar streamState (Closed cc)+ return True+ _otherwise -> return False+ -- Out of the stream table, giving its concurrency slot back.+ when receiving $ closed ctx strm cc+ return receiving+ closed :: Context -> Stream -> ClosedCode -> IO () closed ctx@Context{oddStreamTable, evenStreamTable} strm@Stream{streamNumber} cc = do if isServerInitiated streamNumber 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 @@ -369,13 +443,16 @@ let rxws = initialWindowSize mySettings case mMaxConc of Nothing -> do- sid <- atomically $ getMyNewStreamId ctx+ sid <- atomically $ do+ refuseIfGoingAway ctx+ getMyNewStreamId ctx txws <- initialWindowSize <$> readIORef peerSettings newstrm <- newOddStream sid txws rxws insertOdd oddStreamTable sid newstrm return (sid, newstrm) Just maxConc -> do sid <- atomically $ do+ refuseIfGoingAway ctx waitIncOdd oddStreamTable maxConc getMyNewStreamId ctx txws <- initialWindowSize <$> readIORef peerSettings@@ -384,8 +461,21 @@ return (sid, newstrm) -- Server-openEvenStreamWait :: Context -> IO (StreamId, Stream)-openEvenStreamWait ctx@Context{..} = do++-- | Opening a stream for a push, if the peer's+-- SETTINGS_MAX_CONCURRENT_STREAMS leaves room for one.+--+-- Not waiting for room: the response the push belongs to waits for its+-- PUSH_PROMISE to go out, and with no room -- a peer can announce 0 to+-- refuse pushes (RFC 9113, section 8.4) -- it waited for ever. A push is+-- only ever an offer, so one there is no room for is not made.+openEvenStreamTry :: Context -> IO (Maybe (StreamId, Stream))+openEvenStreamTry ctx@Context{..} = do+ goingaway <- isJust <$> readTVarIO peerGoAway+ if goingaway then return Nothing else openEvenStreamTry' ctx++openEvenStreamTry' :: Context -> IO (Maybe (StreamId, Stream))+openEvenStreamTry' ctx@Context{..} = do -- Peer SETTINGS_MAX_CONCURRENT_STREAMS mMaxConc <- maxConcurrentStreams <$> readIORef peerSettings let rxws = initialWindowSize mySettings@@ -395,12 +485,74 @@ txws <- initialWindowSize <$> readIORef peerSettings newstrm <- newEvenStream sid txws rxws insertEven evenStreamTable sid newstrm- return (sid, newstrm)+ return $ Just (sid, newstrm) Just maxConc -> do- sid <- atomically $ do- waitIncEven evenStreamTable maxConc- getMyNewStreamId ctx- txws <- initialWindowSize <$> readIORef peerSettings- newstrm <- newEvenStream sid txws rxws- insertEven' evenStreamTable sid newstrm- return (sid, newstrm)+ msid <- atomically $ do+ let open = do+ waitIncEven evenStreamTable maxConc+ Just <$> getMyNewStreamId ctx+ open `orElse` return Nothing+ forM msid $ \sid -> do+ txws <- initialWindowSize <$> readIORef peerSettings+ newstrm <- newEvenStream sid txws rxws+ insertEven' evenStreamTable sid newstrm+ return (sid, newstrm)++----------------------------------------------------------------+-- GOAWAY from the peer++-- | No new stream once the peer has sent GOAWAY: "Receivers of a GOAWAY+-- frame MUST NOT open additional streams on the connection" (RFC 9113,+-- section 6.8). A request that has not got a stream yet is answered as+-- one on a stream above the last stream identifier would be.+refuseIfGoingAway :: Context -> STM ()+refuseIfGoingAway Context{peerGoAway} = do+ goingaway <- isJust <$> readTVar peerGoAway+ when goingaway $ throwSTM ConnectionIsClosed++-- | Taking the peer's GOAWAY(NO_ERROR) on board.+--+-- The peer has said it will go no further than the last stream identifier,+-- not that it is going at once. Streams of ours above it will not be+-- processed, and are closed with 'ConnectionIsClosed', which a client may+-- retry elsewhere; no stream is opened from now on. The others go on+-- until they are done, and then so is the connection: 'drained' tells+-- when. It used to be closed right away, cutting off every stream in+-- flight, even those the peer had promised to finish.+--+-- A later GOAWAY can lower the last stream identifier, not raise it.+-- Answers whether this is the first.+goingAway :: Context -> StreamId -> IO Bool+goingAway ctx@Context{peerGoAway, oddStreamTable, evenStreamTable} lastSid = do+ first <- atomically $ do+ old <- readTVar peerGoAway+ writeTVar peerGoAway $ Just $ maybe lastSid (min lastSid) old+ return $ isNothing old+ mine <-+ if isClient ctx+ then getOddStreams oddStreamTable+ else getEvenStreams evenStreamTable+ let (_, above) = IntMap.split lastSid mine+ forM_ above $ \strm -> closed ctx strm Finished+ return first++-- | Waiting until nothing is left in flight after the peer's GOAWAY:+-- neither a stream of the peer's, nor one of ours the peer is to process,+-- nor -- on a client -- a response still being read. Streams of ours above+-- the last stream identifier are not waited for; those that got their+-- identifier too late to be closed by 'goingAway' are closed with the+-- connection.+drained :: Context -> STM ()+drained ctx@Context{peerGoAway, oddStreamTable, evenStreamTable, activeRequests} = do+ mlast <- readTVar peerGoAway+ case mlast of+ Nothing -> retry+ Just lastSid -> do+ odds <- oddTable <$> readTVar oddStreamTable+ evens <- evenTable <$> readTVar evenStreamTable+ active <- readTVar activeRequests+ let (mine, theirs)+ | isClient ctx = (odds, evens)+ | otherwise = (evens, odds)+ noneOfMine = maybe True ((> lastSid) . fst) $ IntMap.lookupMin mine+ check $ IntMap.null theirs && noneOfMine && active == 0
Network/HTTP2/H2/HPACK.hs view
@@ -115,10 +115,17 @@ -- -- The block must still be decoded: it may modify the dynamic table. hpackDiscardHeader :: HeaderBlockFragment -> StreamId -> Context -> IO ()-hpackDiscardHeader hdrblk sid ctx = void $ hpackDecode "illegal header" hdrblk sid ctx+hpackDiscardHeader hdrblk sid ctx =+ void (hpackDecode "illegal header" hdrblk sid ctx) `E.catch` ignore+ where+ -- Decoded to the end, so there is nothing to refuse: the message goes+ -- nowhere anyway.+ ignore StreamErrorIsSent{} = return ()+ ignore e = E.throwIO e -- | Decode a field block, reporting a block we could not get through as a--- connection error.+-- connection error, and a malformed message in a block decoded to the end+-- as a stream error. -- -- The first argument says which kind of block it was, since the peer reads -- this in the GOAWAY and "illegal trailer" about a request's headers is a@@ -132,18 +139,23 @@ hpackDecode illegal hdrblk sid Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl where- -- Connection errors, both of them, even though a malformed message is a- -- stream error by RFC 9113 section 8.1.1. Either way the field block was- -- abandoned part-way through, so 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 block MUST- -- be processed to ensure a consistent connection state, unless the- -- connection is closed." We did not, so it must be.- --- -- A malformed message caught /after/ a complete decode is a different- -- matter, and 'hpackDecodeHeader' reports those as stream errors.+ -- A malformed message: 'decodeTokenHeader' says so only once it has+ -- decoded the whole block, so the dynamic table is up to date and the+ -- connection can go on. A stream error, as RFC 9113 section 8.1.1 has+ -- it. This used to be a connection error, as the block was abandoned+ -- at the malformed field; one request with an upper-case field name+ -- closed the connection, every other stream on it with it. handl IllegalHeaderName =- E.throwIO $ ConnectionErrorIsSent ProtocolError sid illegal+ 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 "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+ -- block MUST be processed to ensure a consistent connection state,+ -- unless the connection is closed." We did not, so it must be. handl e = do let msg = fromString $ show e E.throwIO $ ConnectionErrorIsSent CompressionError sid msg
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@@ -296,7 +300,7 @@ processState :: StreamState -> Context -> Stream -> StreamId -> IO () -- Transition (process1)-processState (Open _ (NoBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do+processState (Open _ (NoBody tbl@(_, reqvt))) ctx strm@Stream{streamInput} streamId = do -- My SETTINGS_MAX_CONCURRENT_STREAMS when (isServer ctx) $ checkOddConcurrency ctx streamId noContent <- hasNoContent ctx strm reqvt@@ -311,13 +315,12 @@ let inpObj = InpObj tbl (Just 0) (return (mempty, True)) tlr if isServer ctx then do- let ServerInfo{..} = toServerInfo roleInfo- launch ctx strm inpObj+ launchHandler ctx strm inpObj else putMVar streamInput $ Right inpObj halfClosedRemote ctx strm -- Transition (process2)-processState (Open _ (HasBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput, streamRxQ} _streamId = do+processState (Open _ (HasBody tbl@(_, reqvt))) ctx strm@Stream{streamInput, streamRxQ} _streamId = do -- My SETTINGS_MAX_CONCURRENT_STREAMS when (isServer ctx) $ checkOddConcurrency ctx _streamId noContent <- hasNoContent ctx strm reqvt@@ -336,8 +339,7 @@ let inpObj = InpObj tbl mcl (readSource bodySource) tlr if isServer ctx then do- let ServerInfo{..} = toServerInfo roleInfo- launch ctx strm inpObj+ launchHandler ctx strm inpObj else putMVar streamInput $ Right inpObj -- Transition (process4)@@ -356,6 +358,21 @@ -- Idle setStreamState ctx strm s +-- | Handing a request to the server's handler.+--+-- The stream counts towards the last stream identifier of our GOAWAY from+-- here on: from now its request "might have been processed" (RFC 9113,+-- section 6.8), and a client is free to retry, on another connection, any+-- request on a stream above it. It used to be counted once the handler+-- had returned, so a GOAWAY sent while handlers were running left their+-- streams out, and a client could send again a request -- a POST, say --+-- that had been acted on.+launchHandler :: Context -> Stream -> InpObj -> IO ()+launchHandler ctx@Context{roleInfo} strm inpObj = do+ modifyPeerLastStreamId ctx $ streamNumber strm+ let ServerInfo{..} = toServerInfo roleInfo+ launch ctx strm inpObj+ ---------------------------------------------------------------- {- FOURMOLU_DISABLE -}@@ -393,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 $@@ -477,10 +501,19 @@ if rate > pingRateLimit mySettings then E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many ping" else sendPing ctx True bs-control FrameGoAway header bs _ = do+control FrameGoAway header bs ctx = do GoAwayFrame sid err msg <- guardIt $ decodeGoAwayFrame header bs if err == NoError- then E.throwIO ConnectionIsClosed+ then do+ first <- goingAway ctx sid+ -- The receiver goes on reading for the streams left, and stops+ -- the way it does when the peer closes the connection, once+ -- they are done.+ when first $ do+ receiver <- myThreadId+ T.forkManaged (threadManager ctx) "H2 draining after GOAWAY" $ do+ atomically $ drained ctx+ E.throwTo receiver ConnectionIsClosed else E.throwIO $ ConnectionErrorIsReceived err sid $ Short.toShort msg control FrameWindowUpdate header bs ctx = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs@@ -507,7 +540,9 @@ ProtocolError streamId "wrong header fragment for push promise"- (_, vt) <- hpackDecodeHeader frag streamId ctx+ -- A malformed promised request is an error on the promised stream,+ -- which 'resetPromised' resets.+ (_, vt) <- hpackDecodeHeader frag streamId ctx `E.catch` onPromised sid let ClientInfo{..} = toClientInfo $ roleInfo ctx when ( getFieldValue tokenAuthority vt == Just (UTF8.fromString authority)@@ -524,6 +559,10 @@ ---------------------------------------------------------------- +onPromised :: StreamId -> HTTP2Error -> IO a+onPromised sid (StreamErrorIsSent err _ msg) = E.throwIO $ StreamErrorIsSent err sid msg+onPromised _ e = E.throwIO e+ {-# INLINE guardIt #-} guardIt :: Either FrameDecodeError a -> IO a guardIt x = case x of@@ -595,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@@ -618,9 +657,9 @@ FrameData header@FrameHeader{flags, payloadLength, streamId} bs- Context{emptyFrameRate, rxFlow, mySettings}+ ctx@Context{emptyFrameRate, rxFlow, mySettings} s@(Open _ (Body q mcl bodyLength _))- Stream{..} = do+ strm@Stream{..} = do DataFrame body <- guardIt $ decodeDataFrame header bs -- FLOW CONTROL: WINDOW_UPDATE 0: recv: rejecting if over my limit okc <- atomicModifyIORef' rxFlow $ checkRxLimit payloadLength@@ -638,9 +677,42 @@ EnhanceYourCalm streamId "exceeds stream flow-control limit"+ -- A push gives the connection window everything back now, padding+ -- and all ('connectionCreditedOnArrival'); its stream window, and+ -- any other stream's windows, as below.+ when (connectionCreditedOnArrival streamId) $+ giveBackConnectionWindow ctx payloadLength+ -- The padding is charged to both windows, as it must be, but it+ -- never reaches the reader, whose reading is what gives octets+ -- back ('readSource'). Left there, each padded frame shrank the+ -- peer's windows for good, until the connection stalled. It is+ -- done with as soon as it arrives, so it goes straight back.+ informWindowUpdate ctx strm $ payloadLength - BS.length body len0 <- readIORef bodyLength- let len = len0 + payloadLength+ -- The content itself: 'payloadLength', which flow control goes by,+ -- also counts the padding, and so made a padded body look longer+ -- 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@@ -649,18 +721,34 @@ E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty data" else do writeIORef bodyLength len- atomically $ writeTQueue q $ Right (body, endOfStream)+ -- 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. 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+ discard <- readTVar streamDiscardBody+ if+ | isClosed st -> return Dropped+ | discard -> return Discarded+ | otherwise -> do+ writeTQueue q $ Right (body, endOfStream)+ 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@@ -743,9 +831,20 @@ stream FrameContinuation FrameHeader{streamId} _ _ _ _ = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "continue frame cannot come here"+-- DATA that is not taken in, below, is still paid for. RFC 9113 section+-- 6.9: "A receiver that receives a flow-controlled frame MUST always account+-- for its contribution against the connection flow-control window, unless+-- the receiver treats this as a connection error." The peer charged it to+-- the connection window before sending it, and unless it is charged and+-- given back here as well, the peer's view of that window shrinks for good.+-- -- Ignore frames to streams we have just reset, per section 5.1.+stream FrameData FrameHeader{payloadLength, streamId} _ ctx st@(Closed (ResetByMe _)) _ = do+ informIgnoredData ctx streamId payloadLength+ return st stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st-stream FrameData FrameHeader{streamId} _ _ _ _ =+stream FrameData FrameHeader{payloadLength, streamId} _ ctx _ _ = do+ informIgnoredData ctx streamId payloadLength E.throwIO $ StreamErrorIsSent StreamClosed streamId $ fromString ("illegal data frame for " ++ show streamId)@@ -756,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) @@ -840,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,30 +93,36 @@ return $ Just done _otherwise -> retry-checkDone _ _ = return Nothing+checkDone _ _ _ = return Nothing frameSender :: Context -> Config -> IO E.SomeException frameSender ctx@Context{outputQ, controlQ, encodeDynamicTable, outputBufferLimit} Config{..} = do labelMe "H2 sender"+ -- DATA that has to wait for the connection window, in the order it+ -- came: see 'dequeue'.+ parked <- newTVarIO [] -- This catches an asynchronous exception. -- It is re-thrown by "runH2"- loop 0 `E.catch` return+ loop parked 0 `E.catch` return where ----------------------------------------------------------------- loop :: Offset -> IO E.SomeException- loop off = do- mDone <- checkDone ctx off+ loop :: TVar [Output] -> Offset -> IO E.SomeException+ loop parked off = do+ mDone <- checkDone ctx parked off case mDone of Just done -> return done Nothing -> do- x <- atomically $ dequeue off+ x <- atomically $ dequeue parked off case x of- C ctl -> flushN off >> control ctl >> loop 0- O out -> outputAndSync out off >>= flushIfNecessary >>= loop- Flush -> flushN off >> loop 0+ C ctl -> flushN off >> control ctl >> loop parked 0+ O out ->+ outputAndSync parked out off+ >>= flushIfNecessary+ >>= loop parked+ Flush -> flushN off >> loop parked 0 -- Flush the connection buffer to the socket, where the first 'n' bytes of -- the buffer are filled.@@ -122,18 +139,32 @@ flushN off return 0 - dequeue :: Offset -> STM Switch- dequeue off = do- isEmptyC <- isEmptyTQueue controlQ+ -- Only DATA is flow-controlled (RFC 9113, section 6.9), so only DATA+ -- waits for the connection window. The whole output queue used to:+ -- with the window shut, no HEADERS, PUSH_PROMISE or RST_STREAM went+ -- out either, on any stream -- not even the response to a request+ -- that has no body, or the reset that would have freed some of the+ -- window. Now outputs are taken as they come, and DATA there is no+ -- connection window for is parked ('outputAndSync') and goes out,+ -- first and in order, once there is.+ dequeue :: TVar [Output] -> Offset -> STM Switch+ dequeue parked off = do+ isEmptyC <- isEmptyControlQ controlQ if isEmptyC then do- -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit- waitConnectionWindowSize ctx- isEmptyO <- isEmptyTQueue outputQ- if isEmptyO- then if off /= 0 then return Flush else retry- else O <$> readTQueue outputQ- else C <$> readTQueue controlQ+ ps <- readTVar parked+ cws <- connectionWindowSizeSTM ctx+ case ps of+ -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit+ p : rest | cws > 0 -> do+ writeTVar parked rest+ return $ O p+ _ -> do+ isEmptyO <- isEmptyTQueue outputQ+ if isEmptyO+ then if off /= 0 then return Flush else retry+ else O <$> readTQueue outputQ+ else C <$> dequeueControlSTM controlQ ---------------------------------------------------------------- copyAll [] buf = return buf@@ -169,10 +200,10 @@ -- -- Both the stream window and the connection window are open. ----------------------------------------------------------------- outputAndSync :: Output -> Offset -> IO Offset+ outputAndSync :: TVar [Output] -> Output -> Offset -> IO Offset -- "handler" catches an asynchronous exception and -- re-throws it.- outputAndSync out@(Output strm otyp sync) off = E.handle (handler strm off) $ do+ outputAndSync parked out@(Output strm otyp sync) off = E.handle (handler strm off) $ do state <- readStreamState strm if isHalfClosedLocal state then do@@ -207,10 +238,15 @@ return off _ -> do sws <- getStreamWindowSize strm- cws <- getConnectionWindowSize ctx -- not 0+ cws <- getConnectionWindowSize ctx let lim = min cws sws case otyp of ONext{}+ | cws <= 0 -> do+ -- To wait for the connection window,+ -- without holding up anything else.+ atomically $ modifyTVar' parked (++ [out])+ return off | lim <= 0 -> do -- No room for any of the body: the -- window was shut after this was queued@@ -228,17 +264,23 @@ return off' ----------------------------------------------------------------- handler strm off e = do- resetStream strm InternalError e- return off-- resetStream :: Stream -> ErrorCode -> E.SomeException -> IO ()- resetStream strm err e+ handler strm off e | isAsyncException e = E.throwIO e | otherwise = do- closed ctx strm (ResetByMe e)- let rst = resetFrame err $ streamNumber strm- enqueueControl controlQ $ CFrames Nothing [rst]+ resetStream strm InternalError e+ return off++ -- 'e' is the reason for the reset, not something thrown to the+ -- sender. It may well be asynchronous: a streaming body killed+ -- by 'cancel' passes the exception to 'outBodyCancel'. Throwing+ -- it here would kill the sender and the whole connection with it.+ -- Asynchronous exceptions actually thrown to the sender are+ -- re-thrown by 'handler'.+ resetStream :: Stream -> ErrorCode -> E.SomeException -> IO ()+ resetStream strm err e = do+ closed ctx strm (ResetByMe e)+ let rst = resetFrame err $ streamNumber strm+ enqueueControl controlQ $ CFrames Nothing [rst] resetStreamWith :: Stream -> Maybe E.SomeException -> IO () resetStreamWith strm (Just err) =
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/Sync.hs view
@@ -108,13 +108,15 @@ case s of Done -> return () Cont newout -> do+ mapM_ T.tickle (lcTimeHandle lc) cont <- checkLoop lc when cont $ do enqueueOutput outputQ newout loop -newLoopCheck :: Stream -> Maybe (TBQueue StreamingChunk) -> IO LoopCheck-newLoopCheck strm mtbq = do+newLoopCheck+ :: Stream -> Maybe (TBQueue StreamingChunk) -> Maybe T.Handle -> IO LoopCheck+newLoopCheck strm mtbq mth = do tovar <- newTVarIO False return $ LoopCheck@@ -122,6 +124,7 @@ , lcTBQ = mtbq , lcTimeout = tovar , lcWindow = streamTxFlow strm+ , lcTimeHandle = mth } data LoopCheck = LoopCheck@@ -129,6 +132,7 @@ , lcTBQ :: Maybe (TBQueue StreamingChunk) , lcTimeout :: TVar Bool , lcWindow :: TVar TxFlow+ , lcTimeHandle :: Maybe T.Handle } checkLoop :: LoopCheck -> IO Bool
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/H2/Window.hs view
@@ -30,6 +30,9 @@ w <- txWindowSize <$> readTVar streamTxFlow check (w > 0) +connectionWindowSizeSTM :: Context -> STM WindowSize+connectionWindowSizeSTM Context{txFlow} = txWindowSize <$> readTVar txFlow+ waitConnectionWindowSize :: Context -> STM () waitConnectionWindowSize Context{txFlow} = do w <- txWindowSize <$> readTVar txFlow@@ -68,14 +71,22 @@ ---------------------------------------------------------------- -- Sending window update +-- | Whether a stream's DATA is given back to the connection window as it+-- arrives, rather than as it is read.+--+-- So it is for pushes, the only streams of the server's we receive on. A+-- push is read only if a request for it comes along, and maybe never: held+-- against the connection window until then, pushes that nobody asked for+-- used it up, and the connection stalled, responses to requests and all.+-- Their stream windows still hold back what each can send unread.+connectionCreditedOnArrival :: StreamId -> Bool+connectionCreditedOnArrival = isServerInitiated+ informWindowUpdate :: Context -> Stream -> Int -> IO () informWindowUpdate _ _ 0 = return ()-informWindowUpdate Context{controlQ, rxFlow} Stream{streamNumber, streamRxFlow} len = do- mxc <- atomicModifyIORef rxFlow $ maybeOpenRxWindow len FCTWindowUpdate- forM_ mxc $ \ws -> do- let frame = windowUpdateFrame 0 ws- cframe = CFrames Nothing [frame]- enqueueControl controlQ cframe+informWindowUpdate ctx@Context{controlQ} Stream{streamNumber, streamRxFlow} len = do+ unless (connectionCreditedOnArrival streamNumber) $+ giveBackConnectionWindow ctx len mxs <- atomicModifyIORef streamRxFlow $ maybeOpenRxWindow len FCTWindowUpdate forM_ mxs $ \ws -> do let frame = windowUpdateFrame streamNumber ws@@ -92,7 +103,7 @@ -- charge them and give them straight back. informIgnoredData :: Context -> StreamId -> Int -> IO () informIgnoredData _ _ 0 = return ()-informIgnoredData Context{controlQ, rxFlow} sid len = do+informIgnoredData ctx@Context{rxFlow} sid len = do ok <- atomicModifyIORef' rxFlow $ checkRxLimit len unless ok $ E.throwIO $@@ -100,6 +111,14 @@ EnhanceYourCalm sid "exceeds connection flow-control limit"+ giveBackConnectionWindow ctx len++-- | Give octets already charged to the connection window back to it, and to+-- it alone: for a stream that is closed, whose own window no longer+-- matters.+giveBackConnectionWindow :: Context -> Int -> IO ()+giveBackConnectionWindow _ 0 = return ()+giveBackConnectionWindow Context{controlQ, rxFlow} len = do mxc <- atomicModifyIORef rxFlow $ maybeOpenRxWindow len FCTWindowUpdate forM_ mxc $ \ws -> enqueueControl controlQ $ CFrames Nothing [windowUpdateFrame 0 ws]@@ -107,22 +126,37 @@ -- This must be called after an application is finished -- to adjust RX window. adjustRxWindow :: Context -> Stream -> IO ()-adjustRxWindow ctx stream@Stream{streamRxQ} = do+adjustRxWindow ctx stream = do+ len <- takeUnread stream+ informWindowUpdate ctx stream len++-- | Like 'adjustRxWindow', for a stream that has been closed: what was+-- left unread goes back to the connection window only.+--+-- Closed first, so that nothing is queued after this has looked: the+-- receiver does not queue DATA for a closed stream ('stream'), but gives+-- it back to the connection window itself.+giveBackUnread :: Context -> Stream -> IO ()+giveBackUnread ctx stream = do+ len <- takeUnread stream+ unless (connectionCreditedOnArrival $ streamNumber stream) $+ giveBackConnectionWindow ctx len++-- | Take what is left unread in a stream's queue, and say how many octets+-- of body it was.+takeUnread :: Stream -> IO Int+takeUnread Stream{streamRxQ} = do mq <- readIORef streamRxQ case mq of- Nothing -> return ()- Just q -> do- len <- readQ q- informWindowUpdate ctx stream len+ Nothing -> return 0+ Just q -> atomically $ loop q 0 where- readQ q = atomically $ loop 0- where- loop !total = do- meb <- tryReadTQueue q- case meb of- Just (Right (bs, _)) -> loop (total + BS.length bs)- Just le@(Left _) -> do- -- reserving HTTP2Error- writeTQueue q le- return total- _ -> return total+ loop q !total = do+ meb <- tryReadTQueue q+ case meb of+ Just (Right (bs, _)) -> loop q (total + BS.length bs)+ Just le@(Left _) -> do+ -- reserving HTTP2Error+ writeTQueue q le+ return total+ _ -> return total
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
@@ -41,10 +41,12 @@ #endif } request = Request req'- lc <- newLoopCheck strm Nothing- server request aux $ sendResponse conf ctx lc strm request- adjustRxWindow ctx strm- modifyPeerLastStreamId ctx $ streamNumber strm+ lc <- newLoopCheck strm Nothing (Just th)+ 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'}@@ -56,6 +58,61 @@ 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+ ---------------------------------------------------------------- #if MIN_VERSION_http_semantics(0,4,1)@@ -66,7 +123,7 @@ -- ordering with respect to the final response. sendInformational :: Context -> Stream -> Status -> ResponseHeaders -> IO () sendInformational ctx strm st hdrs = do- lc <- newLoopCheck strm Nothing+ lc <- newLoopCheck strm Nothing Nothing let hdr = (":status", C8.pack (show (statusCode st))) : hdrs syncWithSender ctx strm (OInformational hdr) lc #endif@@ -126,9 +183,10 @@ push _ [] n = return (n :: Int) push tvar (pp : pps) n = do T.forkManaged threadManager "H2 server push" $ do- (newstrm, lc) <- promise pp `E.finally` increment tvar- let Response rsp = promiseResponse pp- sendHeaderBody conf ctx lc newstrm rsp+ mpushed <- promise pp `E.finally` increment tvar+ forM_ mpushed $ \(newstrm, lc) -> do+ let Response rsp = promiseResponse pp+ sendHeaderBody conf ctx lc newstrm rsp push tvar pps (n + 1) -- Sending the PUSH_PROMISE, and only then counting the push as done: -- 'waiter' holds the parent's response back until every push is@@ -138,9 +196,12 @@ -- was queued, the parent's response could overtake it, and a client -- asked for the pushed resource itself before hearing of the promise. -- 'syncWithSender' returns once the sender has written the frame.- -- Counted however it ends, or the parent would wait for ever.+ -- Counted however it ends, or the parent would wait for ever. A push+ -- the peer has no room for is not made ('openEvenStreamTry'). promise pp = do- (pid, newstrm) <- makePushStream ctx pstrm+ mstrm <- makePushStream ctx pstrm+ forM mstrm $ \(pid, newstrm) -> promiseOn pp pid newstrm+ promiseOn pp pid newstrm = do let scheme = fromJust $ getFieldValue tokenScheme reqvt -- fixme: this value can be Nothing auth =@@ -156,7 +217,7 @@ , (tokenPath, path) ] ot = OPush promiseRequest pid- lc <- newLoopCheck newstrm Nothing+ lc <- newLoopCheck newstrm Nothing Nothing syncWithSender ctx newstrm ot lc -- Reserved (local) until now. The peer sends nothing on a pushed -- stream, so its side is closed from here (RFC 9113, section 5.1:@@ -171,12 +232,12 @@ ---------------------------------------------------------------- -makePushStream :: Context -> Stream -> IO (StreamId, Stream)+makePushStream :: Context -> Stream -> IO (Maybe (StreamId, Stream)) makePushStream ctx pstrm = do -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit- (_, newstrm) <- openEvenStreamWait ctx+ mstrm <- openEvenStreamTry ctx let pid = streamNumber pstrm- return (pid, newstrm)+ return $ (\(_, newstrm) -> (pid, newstrm)) <$> mstrm ----------------------------------------------------------------
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.6+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,10 +3,14 @@ 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)+import Data.Word (Word8) import Network.HPACK import Network.HPACK.Table+import Network.HPACK.Token (tokenKey) import Test.Hspec import HPACK.HeaderBlock@@ -64,6 +68,145 @@ , 0xbe -- indexed 62 ] decodeHeader dtbl blk `shouldReturn` [("a", ""), ("b", ""), ("b", "")]+ it "decodes a Huffman-coded value longer than the Huffman buffer" $+ -- The value decodes to more than the 4096 octets of the+ -- decoder's Huffman buffer. It used to be reported as a+ -- truncated block, although the same value as a plain literal+ -- was accepted.+ withDynamicTableForEncoding 4096 $ \etbl ->+ withDynamicTableForDecoding 4096 4096 $ \dtbl ->+ forM_ [False, True] $ \huff -> do+ let hs = [("x-long", BS8.replicate 5000 'a')]+ stgy = defaultEncodeStrategy{useHuffman = huff}+ blk <- encodeHeader stgy 8192 etbl hs+ decodeHeader dtbl blk `shouldReturn` hs+ (tvs, _) <- decodeTokenHeader dtbl blk+ map (\(t, v) -> (tokenKey t, v)) tvs `shouldBe` hs+ it "decodes a block with no fields" $+ -- Empty, or only dynamic table size updates: both are valid+ -- blocks of no fields, and both used to be taken for truncated.+ withDynamicTableForDecoding 4096 4096 $ \dtbl ->+ forM_ ["", "\x20", "\x3f\xe1\x1f"] $ \blk -> do+ decodeHeader dtbl blk `shouldReturn` []+ (tvs, _) <- decodeTokenHeader dtbl blk+ tvs `shouldBe` []+ it "decodes the rest of a block with a malformed field" $+ -- The field after the malformed ones goes into the dynamic+ -- table, and the next block refers to it: index 62, the newest+ -- entry. The decoder used to stop at the malformed field, so+ -- that reference went astray.+ forM_ [illegalName, tooMany] $ \(fields, err) ->+ withDynamicTableForDecoding 4096 4096 $ \dtbl -> do+ let blk1 = fields <> incremental "x-after" "2"+ blk2 = BS.pack [0xbe]+ 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@@ -78,6 +221,43 @@ let stgy = defaultEncodeStrategy{useHuffman = huff} blk <- encodeHeader stgy 4096 etbl hs decodeHeader dtbl blk `shouldReturn` hs++-- | A field name the encoder would have made lower-case.+illegalName :: (BS.ByteString, DecodeError)+illegalName = (literal "X-Upper" "1", IllegalHeaderName)++-- | One field more than the decoder takes.+tooMany :: (BS.ByteString, DecodeError)+tooMany =+ ( mconcat [literal (BS8.pack ('f' : show i)) "v" | i <- [1 .. 202 :: Int]]+ , TooLargeHeader+ )++-- | A literal field with a new name, without indexing (RFC 7541, 6.2.2).+literal :: BS.ByteString -> BS.ByteString -> BS.ByteString+literal = field 0x00++-- | 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+field w k v =+ BS.pack [w, fromIntegral (BS.length k)]+ <> k+ <> BS.pack [fromIntegral (BS.length v)]+ <> v -- | Blocks of fields close to the 32-octet minimum entry size, coming back -- to earlier ones so that the encoder refers to what it inserted.
test/HPACK/HuffmanSpec.hs view
@@ -60,6 +60,10 @@ es <- encodeHuffman bs ds <- decodeHuffman es ds `shouldBe` bs+ it "decodes a string longer than 4096 octets" $ do+ let bs = BS.replicate 6000 'a' -- 3750 octets encoded+ es <- encodeHuffman bs+ decodeHuffman es `shouldReturn` bs describe "encode" $ do it "encodes" $ do mapM_ (\(x, y) -> x `shouldBeEncoded` y) testData
test/HTTP2/FrameSpec.hs view
@@ -32,14 +32,14 @@ -- Six octets is the smallest payload the header check accepts for -- PADDED and PRIORITY together, and a Pad Length of five leaves -- none of the five priority octets behind.- let flags = setPadded $ setPriority defaultFlags- header = FrameHeader 6 flags 1+ let flags' = setPadded $ setPriority defaultFlags+ header = FrameHeader 6 flags' 1 decodeError FrameHeaders header (BS.pack [5, 0, 0, 0, 0, 0]) `shouldBe` Just FrameSizeError it "rejects a padded PUSH_PROMISE whose padding covers the promised id" $ do- let flags = setPadded defaultFlags- header = FrameHeader 5 flags 1+ let flags' = setPadded defaultFlags+ header = FrameHeader 5 flags' 1 decodeError FramePushPromise header (BS.pack [4, 0, 0, 0, 0]) `shouldBe` Just FrameSizeError
test/HTTP2/ServerSpec.hs view
@@ -147,914 +147,2131 @@ threadDelay 10000 runStreamErrorClient - it "limits the resets a peer can make us send (MadeYouReset)" $- E.bracket (forkIO runServer) killThread $ \_ -> do- threadDelay 10000- -- Not through the client library: it would take the- -- server's first RST_STREAM, on a stream it never opened- -- itself, for a protocol error of its own.- timeout 5000000 rapidStreamError- `shouldReturn` Just (Just (EnhanceYourCalm, "too many stream errors"))-- it "gives back the slot of a stream both sides streamed on" $- -- Room for four concurrent streams, so a few slots that are- -- never given back stop the connection within a few thousand- -- requests one after another. Both sides stream with flushes: the receiver used to write back a stream state- -- it had read before the sender half-closed the stream, undoing- -- the half-close, so the peer's END_STREAM then left the stream- -- half-closed instead of closed and in the table for good.- --- -- It is a race between the receiver and the sender, so it needs- -- them running in parallel: on one capability it hardly ever- -- shows.- withCapabilities 4 $- E.bracket (forkIO runServerSmallWindow) killThread $ \_ -> do- threadDelay 10000- done <- newIORef (0 :: Int)- r <- timeout 60000000 $ runTCPClient host port $ \s -> do- -- Fifty small writes each way per request: without- -- this, Nagle and delayed ACKs can hold each one up.- setSocketOption s NoDelay 1- E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->- C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ ->- forM_ [1 .. 2000 :: Int] $ \_ -> do- let req = C.requestStreaming methodPost "/both" [] $ \write flush ->- replicateM_ 50 $ write (byteString (C8.replicate 50 'a')) >> flush- sendRequest req $ \rsp -> do- let drain n = do- bs <- C.getResponseBodyChunk rsp- if B.null bs then return n else drain (n + B.length bs)- drain 0 `shouldReturn` 2500- modifyIORef' done (+ 1)- -- How far it got tells a hang from a slow run.- n <- readIORef done- when (isNothing r) $- expectationFailure $- "timed out after " ++ show n ++ " of 2000 requests"-- it "accepts a content-length on a response with no content" $- -- RFC 9113, section 8.1.1: the response to HEAD, 204 and 304 can- -- carry a non-zero content-length without content. The client- -- used to take each of these for a malformed response.- E.bracket (forkIO runServer) killThread $ \_ -> do- threadDelay 10000- runTCPClient host port $ \s ->- E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->- C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do- let noContent method path =- sendRequest (C.requestNoBody method path []) $ \rsp -> do- C.responseStatus rsp `shouldSatisfy` isJust- C.getResponseBodyChunk rsp `shouldReturn` ""- noContent methodHead "/"- noContent methodHead "/data"- noContent methodGet "/not-modified"- -- A response that is meant to have content still- -- has to match its content-length.- sendRequest (C.requestNoBody methodGet "/no-content" []) (const $ return ())- `shouldThrow` malformedResponse-- it "does not open a stream for a PRIORITY frame" $- -- Over a raw socket, as the client library does not send- -- PRIORITY. The server allows 64 concurrent streams; each of- -- these PRIORITY frames used to open one and hold its slot,- -- so the request after them was refused.- E.bracket (forkIO runServer) killThread $ \_ -> do- threadDelay 10000- timeout 5000000 idlePriority `shouldReturn` Just (Just "HEADERS")-- it "closes the connection when SETTINGS overflow a stream's window" $- -- RFC 9113, section 6.9.2: a connection error of type- -- FLOW_CONTROL_ERROR. The overflow is found in the sender,- -- which used to stop on it without a word, leaving the- -- connection open and silent.- E.bracket (forkIO runServer) killThread $ \_ -> do- threadDelay 10000- -- A connection error: GOAWAY, with no RST_STREAM before it.- timeout 5000000 settingsOverflow- `shouldReturn` Just (False, Just FlowControlError)-- it "goes on sending requests after one fails before it is queued" $- -- The file of this requestFile does not exist, so the request- -- fails after its stream id is taken and before it is queued.- -- Requests are queued in stream id order, so every one after it- -- used to wait for its turn for ever.- E.bracket (forkIO runServer) killThread $ \_ -> do- threadDelay 10000- r <- timeout 5000000 $ runTCPClient host port $ \s ->- E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->- C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do- let missing =- C.requestFile methodPost "/echo" [] $- FileSpec "test/no-such-file" 0 10- failed <- E.try $ sendRequest missing (const $ return ())- either (const True) (const False) (failed :: Either E.SomeException ())- `shouldBe` True- replicateM_ 3 $- sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->- C.responseStatus rsp `shouldBe` Just ok200- r `shouldBe` Just ()-- it "sends a PUSH_PROMISE before the response that carries it" $- -- /push answers with a push of /push-pp, so a request for- -- /push-pp after it is served from the push. The server used to- -- let the response to /push overtake the PUSH_PROMISE now and- -- then; the client then asked the server for /push-pp itself,- -- and got 404. One round in a few dozen did, so 200 of them --- -- which also takes more pushes than the peer allows concurrent- -- streams, so pushed streams that are never closed show too.- E.bracket (forkIO runServer) killThread $ \_ -> do- threadDelay 10000- done <- newIORef (0 :: Int)- r <- timeout 30000000 $ runTCPClient host port $ \s ->- E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->- C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ ->- replicateM_ 200 $ do- -- Bodies are read to the end, so that the- -- streams close and give their slots back.- let drain rsp = do- bs <- C.getResponseBodyChunk rsp- unless (B.null bs) $ drain rsp- sendRequest (C.requestNoBody methodGet "/push" []) $ \rsp -> do- C.responseStatus rsp `shouldBe` Just ok200- drain rsp- sendRequest (C.requestNoBody methodGet "/push-pp" []) $ \rsp -> do- C.responseStatus rsp `shouldBe` Just ok200- drain rsp- modifyIORef' done (+ 1)- -- How far it got tells a hang (at 64, the peer's concurrency- -- limit, if pushed streams leak) from a slow run.- n <- readIORef done- when (isNothing r) $- expectationFailure $- "timed out after " ++ show n ++ " of 200 rounds"-- it "uploads a file through runIO past the stream's window" $- -- The server announces an 8192-octet window. runIO put the rest- -- of a body back on the queue without waiting for the window to- -- open; with none left, the file was read into no room, and a- -- read of 0 octets is the end of the file, so the request ended- -- with END_STREAM after the first window's worth.- E.bracket (forkIO runServerSmallWindow) killThread $ \_ -> do- threadDelay 10000- timeout 10000000 uploadIO `shouldReturn` Just 100000-- it "prevents attacks" $- E.bracket (forkIO runServer) killThread $ \_ -> do- threadDelay 10000- runAttack rapidSettings `shouldThrow` connectionError "too many settings"- runAttack rapidPing `shouldThrow` connectionError "too many ping"- runAttack rapidEmptyHeader- `shouldThrow` connectionError "too many empty headers"- runAttack rapidEmptyData `shouldThrow` connectionError "too many empty data"- runAttack rapidRst `shouldThrow` connectionError "too many rst_stream"--ignoreHTTP2Error :: C.HTTP2Error -> IO ()-ignoreHTTP2Error _ = pure ()--runServer :: IO ()-runServer = runTCPServer (Just host) port runHTTP2Server- where- runHTTP2Server s =- E.bracket- (allocSimpleConfig s 32768)- freeSimpleConfig- (\conf -> run defaultServerConfig conf server)---- | Like 'runServer', but announcing room for a single concurrent stream.--- | Uploading 100000 octets of a file through 'C.runIO', and what the server--- says it received.-uploadIO :: IO Int-uploadIO = runTCPClient host port $ \s ->- E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->- C.runIO C.defaultClientConfig{C.authority = host} conf $ \C.ClientIO{..} ->- return $ do- let body rsp acc = do- bs <- C.getResponseBodyChunk rsp- if B.null bs then return acc else body rsp (acc <> bs)- exchange req = cioWriteRequest req >>= cioReadResponse . snd- -- A request first, so that the server's SETTINGS -- and its- -- small window -- are known before the upload starts.- _ <- exchange (C.requestNoBody methodGet "/" []) >>= (`body` "")- rsp <-- exchange $- C.requestFile methodPost "/count" [] $- FileSpec "test/inputFile" 0 100000- read . C8.unpack <$> body rsp ""---- | Running with at least this many capabilities.-withCapabilities :: Int -> IO a -> IO a-withCapabilities n act =- E.bracket getNumCapabilities setNumCapabilities $ \old -> do- setNumCapabilities (max n old)- act---- | Room for four concurrent streams and a small window, so that WINDOW_UPDATE--- frames go back and forth all the time.-runServerSmallWindow :: IO ()-runServerSmallWindow = runTCPServer (Just host) port runHTTP2Server- where- sconf =- defaultServerConfig- { settings =- (settings defaultServerConfig)- { maxConcurrentStreams = Just 4- , initialWindowSize = 8192- }- }- runHTTP2Server s = do- setSocketOption s NoDelay 1- E.bracket- (allocSimpleConfig s 32768)- freeSimpleConfig- (\conf -> run sconf conf server)--runServerMaxConc1 :: IO ()-runServerMaxConc1 = runTCPServer (Just host) port runHTTP2Server- where- sconf =- defaultServerConfig- { settings = (settings defaultServerConfig){maxConcurrentStreams = Just 1}- }- runHTTP2Server s =- E.bracket- (allocSimpleConfig s 32768)- freeSimpleConfig- (\conf -> run sconf conf server)---- | A server whose handler waits long enough for a RST_STREAM to arrive--- before it responds, and then signals that 'sendResponse' returned.-runServerCancel :: MVar () -> IO ()-runServerCancel doneVar = runTCPServer (Just host) port runHTTP2Server- where- runHTTP2Server s =- E.bracket- (allocSimpleConfig s 32768)- freeSimpleConfig- (\conf -> run defaultServerConfig conf cancelServer)- cancelServer _req _aux sendResponse = do- threadDelay 200000- sendResponse responseHello []- putMVar doneVar ()--runFakeServer :: MVar ByteString -> IO ()-runFakeServer prefaceVar = do- runTCPServer (Just host) port $ \s -> do- ref <- newIORef Nothing-- -- send settings- sendAll s $- "\x00\x00\x12\x04\x00\x00\x00\x00\x00"- `mappend` "\x00\x03\x00\x00\x00\x80\x00\x04\x00"- `mappend` "\x01\x00\x00\x00\x05\x00\xff\xff\xff"-- -- receive preface- value <- defaultReadN s ref (B.length connectionPreface)- putMVar prefaceVar value-- -- send goaway frame- sendAll s "\x00\x00\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01"-- -- wait for a few ms to make sure the client has a chance to close the- -- socket on its end- threadDelay 10000--server :: Server-server req aux sendResponse = case requestMethod req of- Just "GET" -> case requestPath req of- Just "/" -> sendResponse responseHello []- Just "/early" -> do- auxSendInformational- aux- earlyHints103- [("link", "</style.css>; rel=preload; as=style")]- auxSendInformational- aux- earlyHints103- [("link", "</app.js>; rel=preload; as=script")]- sendResponse responseHello []- Just "/stream" -> sendResponse responseInfinite []- Just "/not-modified" -> sendResponse (responseNoBody notModified304 bigLength) []- -- Says it has content, and has none: malformed.- Just "/no-content" -> sendResponse (responseNoBody ok200 bigLength) []- Just "/big" -> sendResponse responseBig []- Just "/push" -> do- let pp = pushPromise "/push-pp" responsePP 0- sendResponse responseHello [pp]- _ -> sendResponse response404 []- Just "POST" -> case requestPath req of- Just "/echo" -> sendResponse (responseEcho req) []- -- How many octets of body arrived.- Just "/count" -> do- let count n = do- bs <- getRequestBodyChunk req- if B.null bs then return n else count (n + B.length bs)- n <- count (0 :: Int)- sendResponse (responseBuilder ok200 [] (byteString (C8.pack (show n)))) []- Just "/both" -> do- -- Read the body on the side, so that the response does not- -- wait for it.- _ <-- forkIO $- let d = getRequestBodyChunk req >>= \bs -> unless (B.null bs) d- in d- sendResponse responseBoth []- _ -> sendResponse responseHello []- Just "HEAD" -> case requestPath req of- -- HEADERS, then an empty DATA frame with END_STREAM.- Just "/data" -> sendResponse (responseBuilder ok200 bigLength mempty) []- -- HEADERS with END_STREAM.- _ -> sendResponse (responseNoBody ok200 bigLength) []- _ -> sendResponse response405 []---- | Larger than the default frame size and than the server's 32K buffer.-bigVal :: ByteString-bigVal = C8.replicate 40000 'x'--responseBig :: Response-responseBig = setResponseTrailersMaker rsp maker- where- rsp = responseBuilder ok200 [("x-big", bigVal)] "hello"- maker Nothing = return $ Trailers [("x-big-trailer", bigVal)]- maker (Just _) = return $ NextTrailersMaker maker---- | The stream error a client raises for a malformed response, as--- 'sendRequest' hands it on.-malformedResponse :: C.HTTP2Error -> Bool-malformedResponse (C.StreamErrorIsSent C.ProtocolError _ _) = True-malformedResponse (C.BadThingHappen se) =- maybe False malformedResponse $ E.fromException se-malformedResponse _ = False---- | The content-length of content that is not there.-bigLength :: ResponseHeaders-bigLength = [("content-length", "1234")]--responseHello :: Response-responseHello = responseBuilder ok200 header body- where- header = [("Content-Type", "text/plain")]- body = byteString "Hello, world!\n"--earlyHints103 :: Status-earlyHints103 = mkStatus 103 "Early Hints"--responsePP :: Response-responsePP = responseBuilder ok200 header body- where- header =- [ ("Content-Type", "text/plain")- , ("x-push", "True")- ]- body = byteString "Push\n"---- | A streaming response that does not wait for the request body, so that--- both ends are sending at once and either can finish first.-responseBoth :: Response-responseBoth = responseStreaming ok200 [] $ \write flush ->- replicateM_ 50 $ write (byteString (C8.replicate 50 'b')) >> flush--responseInfinite :: Response-responseInfinite = responseStreaming ok200 header body- where- header = [("Content-Type", "text/plain")]- body :: (Builder -> IO ()) -> IO () -> IO ()- body write flush = do- let go n = write (byteString (C8.pack (show n)) `mappend` "\n") *> flush *> go (succ n)- go (0 :: Int)--response404 :: Response-response404 = responseNoBody notFound404 []--response405 :: Response-response405 = responseNoBody methodNotAllowed405 []--responseEcho :: Request -> Response-responseEcho req = setResponseTrailersMaker h2rsp maker- where- h2rsp = responseStreaming ok200 header streamingBody- header = [("Content-Type", "text/plain")]- mhx = getFieldValue (toToken "X-Tag") (snd (requestHeaders req))- streamingBody write _flush = do- loop- mt <- getRequestTrailers req- firstTrailerValue <$> mt `shouldBe` mhx- where- loop = do- bs <- getRequestBodyChunk req- when (bs /= "") $ do- void $ write $ byteString bs- loop- maker = trailersMaker (CH.hashInit :: Context SHA1)---- Strictness is important for Context.-trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker-trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]- where- !sha1 = C8.pack $ show $ CH.hashFinalize ctx-trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'- where- !ctx' = CH.hashUpdate ctx bs---- | Request @/early@ with an informational handler installed, recording each--- 103 Early Hints section and returning the final response status.-runClientEarly :: IORef [TokenHeaderTable] -> IO (Maybe Status)-runClientEarly hintsRef = runTCPClient host port $ \s ->- E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf0 ->- C.run cliconf (conf0{confOnInformational = onInformational}) $ \sendRequest _aux ->- sendRequest (C.requestNoBody methodGet "/early" []) (return . C.responseStatus)- where- cliconf = C.defaultClientConfig{C.authority = host}- onInformational _sid tbl = modifyIORef' hintsRef (++ [tbl])--runClient :: (Socket -> BufferSize -> IO Config) -> IO ()-runClient allocConfig =- runTCPClient host port runHTTP2Client- where- auth = host- cliconf = C.defaultClientConfig{C.authority = auth}- runHTTP2Client s =- E.bracket- (allocConfig s 4096)- freeSimpleConfig- (\conf -> C.run cliconf conf client)-- client :: C.Client ()- client sendRequest aux =- foldr1- concurrently_- [ client0 sendRequest aux- , client1 sendRequest aux- , client2 sendRequest aux- , client3 sendRequest aux- , client3' sendRequest aux- , client3'' sendRequest aux- , client4 sendRequest aux- , client5 sendRequest aux- ]---- delay sending preface to be able to test if it is always sent first-allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config-allocSlowPrefaceConfig s size = do- config <- allocSimpleConfig s size- pure config{confSendAll = slowPrefaceSend (confSendAll config)}- where- slowPrefaceSend :: (ByteString -> IO ()) -> ByteString -> IO ()- slowPrefaceSend orig chunk = do- when (C8.pack "PRI" `C8.isPrefixOf` chunk) $ do- threadDelay 10000- orig chunk--client0 :: C.Client ()-client0 sendRequest _aux = do- let req = C.requestNoBody methodGet "/" []- sendRequest req $ \rsp -> do- C.responseStatus rsp `shouldBe` Just ok200- fmap statusMessage (C.responseStatus rsp) `shouldBe` Just "OK"--client1 :: C.Client ()-client1 sendRequest _aux = do- let req = C.requestNoBody methodGet "/push-pp" []- sendRequest req $ \rsp -> do- C.responseStatus rsp `shouldBe` Just notFound404--client2 :: C.Client ()-client2 sendRequest _aux = do- let req = C.requestNoBody methodPut "/" []- sendRequest req $ \rsp -> do- C.responseStatus rsp `shouldBe` Just methodNotAllowed405--client3 :: C.Client ()-client3 sendRequest _aux = do- let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a"- req0 =- C.requestFile methodPost "/echo" [("X-Tag", hx)] $- FileSpec "test/inputFile" 0 1012731- req = C.setRequestTrailersMaker req0 maker- sendRequest req $ \rsp -> do- let consumeBody = do- bs <- C.getResponseBodyChunk rsp- when (bs /= "") consumeBody- consumeBody- mt <- C.getResponseTrailers rsp- firstTrailerValue <$> mt `shouldBe` Just hx- where- !maker = trailersMaker (CH.hashInit :: Context SHA1)--client3' :: C.Client ()-client3' sendRequest _aux = do- let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a"- req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do- let sendFile h = do- bs <- B.hGet h 1024- when (bs /= "") $ do- write $ byteString bs- sendFile h- withFile "test/inputFile" ReadMode sendFile- req = C.setRequestTrailersMaker req0 maker- sendRequest req $ \rsp -> do- let consumeBody = do- bs <- C.getResponseBodyChunk rsp- when (bs /= "") consumeBody- consumeBody- mt <- C.getResponseTrailers rsp- firstTrailerValue <$> mt `shouldBe` Just hx- where- !maker = trailersMaker (CH.hashInit :: Context SHA1)--client3'' :: C.Client ()-client3'' sendRequest _axu = do- let hx = "59f82dfddc0adf5bdf7494b8704f203a67e25d4a"- req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do- let chunk = C8.replicate (16384 * 2) 'c'- tag = C8.replicate 16 't'- -- I don't think 9 is important here, this is just what I have, the client hangs on receiving the last one- replicateM_ 9 $ write $ byteString chunk- write $ byteString tag- req = C.setRequestTrailersMaker req0 maker- sendRequest req $ \rsp -> do- let consumeBody = do- bs <- C.getResponseBodyChunk rsp- when (bs /= "") consumeBody- consumeBody- mt <- C.getResponseTrailers rsp- firstTrailerValue <$> mt `shouldBe` Just hx- where- !maker = trailersMaker (CH.hashInit :: Context SHA1)--client4 :: C.Client ()-client4 sendRequest _aux = do- let req0 = C.requestNoBody methodGet "/push" []- sendRequest req0 $ \rsp -> do- C.responseStatus rsp `shouldBe` Just ok200- let req1 = C.requestNoBody methodGet "/push-pp" []- sendRequest req1 $ \rsp -> do- C.responseStatus rsp `shouldBe` Just ok200--client5 :: C.Client ()-client5 sendRequest _aux = do- let req0 = C.requestNoBody methodGet "/stream" []- sendRequest req0 $ \rsp -> do- C.responseStatus rsp `shouldBe` Just ok200- let go n- | n > 0 = do- _ <- C.getResponseBodyChunk rsp- go (pred n)- | otherwise = pure ()- go (100 :: Int)--firstTrailerValue :: TokenHeaderTable -> FieldValue-firstTrailerValue tbl = case fst tbl of- [] -> error "firstTrailerValue"- x : _ -> snd x--runAttack :: (C.ClientIO -> IO ()) -> IO ()-runAttack attack =- runTCPClient host port runHTTP2Client- where- auth = host- cliconf = C.defaultClientConfig{C.authority = auth}- runHTTP2Client s =- E.bracket- (allocSimpleConfig s 4096)- freeSimpleConfig- (\conf -> C.runIO cliconf conf client)- client cconf = return $ do- attack cconf- threadDelay 1000000--rapidSettings :: C.ClientIO -> IO ()-rapidSettings C.ClientIO{..} = do- let einfo = EncodeInfo defaultFlags 0 Nothing- bs = encodeFrame einfo $ SettingsFrame [(SettingsEnablePush, 0)]- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs--rapidPing :: C.ClientIO -> IO ()-rapidPing C.ClientIO{..} = do- let einfo = EncodeInfo defaultFlags 0 Nothing- opaque64 = "01234567"- bs = encodeFrame einfo $ PingFrame opaque64- replicateM_ 20 $ cioWriteBytes bs--rapidEmptyHeader :: C.ClientIO -> IO ()-rapidEmptyHeader C.ClientIO{..} = do- (sid, _) <- cioCreateStream- let einfo = EncodeInfo defaultFlags sid Nothing- bs = encodeFrame einfo $ HeadersFrame Nothing ""- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs- cioWriteBytes bs--rapidEmptyData :: C.ClientIO -> IO ()-rapidEmptyData C.ClientIO{..} = do- (sid, _) <- cioCreateStream- let einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing- hdr =- hpackEncode- [ (":scheme", "http")- , (":authority", "127.0.0.1")- , (":path", "/")- , (":method", "GET")- ]- bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr- cioWriteBytes bsH- let einfoD = EncodeInfo defaultFlags sid Nothing- bsD = encodeFrame einfoD $ DataFrame ""- cioWriteBytes bsD- cioWriteBytes bsD- cioWriteBytes bsD- cioWriteBytes bsD- cioWriteBytes bsD- cioWriteBytes bsD- cioWriteBytes bsD- cioWriteBytes bsD--rapidRst :: C.ClientIO -> IO ()-rapidRst C.ClientIO{..} = do- reset- reset- reset- reset- reset- reset- reset- reset- where- reset = do- (sid, _) <- cioCreateStream- -- setEndStream for HalfClosedRemote- let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing- hdr =- hpackEncode- [ (":scheme", "http")- , (":authority", "127.0.0.1")- , (":path", "/")- , (":method", "GET")- ]- bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr- cioWriteBytes bsH- let einfoR = EncodeInfo defaultFlags sid Nothing- -- Only (HalfClosedRemote, NoError) is accepted.- -- Otherwise, a stream error terminates the connection.- bsR = encodeFrame einfoR $ RSTStreamFrame NoError- cioWriteBytes bsR---- | MadeYouReset (CVE-2025-8671): the same churn as 'rapidRst' without a--- single RST_STREAM from us. Each stream gets a handler that goes on--- running, then a PRIORITY making it depend on itself, which the server--- answers by resetting the stream -- giving its concurrency slot back while--- the handler runs on. Those resets did not count against the limit on--- resets, so this could be kept up for as long as the peer liked.-rapidStreamError :: IO (Maybe (ErrorCode, ByteString))-rapidStreamError = runTCPClient host port $ \s -> do- sendAll s connectionPreface- sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []- forM_ [1, 3 .. 15] $ \sid -> do- let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing- hdr =- hpackEncode- [ (":scheme", "http")- , (":authority", "127.0.0.1")- , (":path", "/stream")- , (":method", "GET")- ]- einfoP = EncodeInfo defaultFlags sid Nothing- sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr- sendAll s $ encodeFrame einfoP $ PriorityFrame $ Priority False sid 16- awaitGoAway s---- | What the server says in its GOAWAY, if it sends one before closing.-awaitGoAway :: Socket -> IO (Maybe (ErrorCode, ByteString))-awaitGoAway s = do- mf <- recvFrame s- case mf of- Nothing -> return Nothing- Just (FrameGoAway, fh, p)- | Right (GoAwayFrame _ err msg) <- decodeGoAwayFrame fh p ->- return $ Just (err, msg)- Just _ -> awaitGoAway s---- | A SETTINGS_INITIAL_WINDOW_SIZE that takes an open stream's window past--- 2^31-1. What the server answers with: whether it reset the stream, and--- the error in its GOAWAY.-settingsOverflow :: IO (Bool, Maybe ErrorCode)-settingsOverflow = runTCPClient host port $ \s -> do- sendAll s connectionPreface- sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []- let sid = 1- -- No END_STREAM: the stream stays open, waiting for the body.- einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing- hdr =- hpackEncode- [ (":scheme", "http")- , (":authority", "127.0.0.1")- , (":path", "/echo")- , (":method", "POST")- ]- sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr- -- The stream's window is now the largest there is ...- sendAll s $- encodeFrame (EncodeInfo defaultFlags sid Nothing) $- WindowUpdateFrame (maxWindowSize - defaultWindowSize)- -- ... and one more octet of initial window takes it over.- sendAll s $- encodeFrame (EncodeInfo defaultFlags 0 Nothing) $- SettingsFrame [(SettingsInitialWindowSize, defaultWindowSize + 1)]- answer s False- where- answer s reset = do- mf <- recvFrame s- case mf of- Nothing -> return (reset, Nothing)- Just (FrameRSTStream, _, _) -> answer s True- Just (FrameGoAway, fh, p)- | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->- return (reset, Just err)- Just _ -> answer s reset---- | PRIORITY frames for 100 streams that are never opened, then a request.--- What the server answers the request with.-idlePriority :: IO (Maybe String)-idlePriority = runTCPClient host port $ \s -> do- sendAll s connectionPreface- sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []- forM_ [3, 5 .. 201] $ \sid ->- sendAll s $- encodeFrame (EncodeInfo defaultFlags sid Nothing) $- PriorityFrame $- Priority False 0 16- let sid = 203- einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing- hdr =- hpackEncode- [ (":scheme", "http")- , (":authority", "127.0.0.1")- , (":path", "/")- , (":method", "GET")- ]- sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr- answer s sid- where- answer s sid = do- mf <- recvFrame s- case mf of- Nothing -> return Nothing- Just (FrameHeaders, fh, _)- | streamId fh == sid -> return $ Just "HEADERS"- Just (FrameRSTStream, fh, p)- | streamId fh == sid- , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p ->- return $ Just $ "RST_STREAM " ++ show err- Just (FrameGoAway, fh, p)- | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->- return $ Just $ "GOAWAY " ++ show err- Just _ -> answer s sid---- | One frame off a raw connection, or 'Nothing' once it is closed.-recvFrame :: Socket -> IO (Maybe (FrameType, FrameHeader, ByteString))-recvFrame s = do- mh <- recvExactly frameHeaderLength- case mh of- Nothing -> return Nothing- Just h -> do- let (ftyp, fh) = decodeFrameHeader h- fmap (\p -> (ftyp, fh, p)) <$> recvExactly (payloadLength fh)- where- recvExactly n = go n []- where- go 0 acc = return $ Just $ B.concat $ reverse acc- go k acc = do- bs <- recv s k- if B.null bs- then return Nothing- else go (k - B.length bs) (bs : acc)---- | Open a stream, reset it, then open two more. The server announced room--- for one concurrent stream, so the third one here must be refused.------ Closing a stream used to give its slot back twice -- a RST_STREAM carrying a--- non-critical error code is closed by both 'stream' and 'processState' -- so--- the count drifted down by one on every reset and this sequence went through--- unchallenged.--- | A HEADERS frame opening a stream and leaving it open, so that it goes on--- holding a concurrency slot.------ Stream identifiers are written out rather than taken from--- 'C.cioCreateStream': the limit being overrun is the one the server--- announced, and asking for a stream the proper way would block on that same--- limit on this side.-openStreamFrame :: StreamId -> ByteString-openStreamFrame sid = encodeFrame einfo $ HeadersFrame Nothing hdr- where- einfo = EncodeInfo (setEndHeader defaultFlags) sid Nothing- hdr =- hpackEncode- [ (":scheme", "http")- , (":authority", "127.0.0.1")- , (":path", "/")- , (":method", "GET")- ]---- | Speak raw frames to the server and collect what it says back.-rawExchange :: [ByteString] -> IO [(FrameType, StreamId, ByteString)]-rawExchange out = runTCPClient host port $ \s -> do- sendAll s connectionPreface- sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []- mapM_ (sendAll s) out- splitFrames <$> collect mempty s- where- collect acc s = do- mbs <- timeout 300000 $ recv s 4096- case mbs of- Just bs | not (B.null bs) -> collect (acc `B.append` bs) s- _ -> return acc--splitFrames :: ByteString -> [(FrameType, StreamId, ByteString)]-splitFrames bs- | B.length bs < frameHeaderLength = []- | otherwise =- let (h, rest) = B.splitAt frameHeaderLength bs- (typ, FrameHeader{payloadLength, streamId}) = decodeFrameHeader h- (body, rest') = B.splitAt payloadLength rest- in (typ, streamId, body) : splitFrames rest'---- | The RST_STREAM and GOAWAY frames among them, with their error codes.-resets- :: [(FrameType, StreamId, ByteString)] -> [(FrameType, StreamId, ErrorCode)]-resets frames =- [ (typ, sid, ec)- | (typ, sid, body) <- frames- , typ == FrameRSTStream || typ == FrameGoAway- , Just ec <- [errorCodeOf typ sid body]- ]- where- errorCodeOf FrameRSTStream sid body =- case decodeRSTStreamFrame (FrameHeader (B.length body) defaultFlags sid) body of- Right (RSTStreamFrame ec) -> Just ec- _ -> Nothing- errorCodeOf FrameGoAway sid body =- case decodeGoAwayFrame (FrameHeader (B.length body) defaultFlags sid) body of- Right (GoAwayFrame _ ec _) -> Just ec- _ -> Nothing- errorCodeOf _ _ _ = Nothing---- | Open a stream and cancel it straight away, while the server is still--- working on the response.------ The sender skips a stream that is already half-closed, and used to return--- without telling the thread that enqueued the output. That thread sat in--- 'syncWithSender'' on an MVar nothing would fill, so 'sendResponse' never--- returned and the worker was only reclaimed when the timeout manager killed--- it, seconds later.-cancelInFlight :: C.ClientIO -> IO ()-cancelInFlight C.ClientIO{..} = do- -- setEndStream for HalfClosedRemote, so that CANCEL is accepted as a- -- stream error rather than taken down the connection.- let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) 1 Nothing- hdr =- hpackEncode- [ (":scheme", "http")- , (":authority", "127.0.0.1")- , (":path", "/")- , (":method", "GET")- ]- cioWriteBytes $ encodeFrame einfoH $ HeadersFrame Nothing hdr- cioWriteBytes $- encodeFrame (EncodeInfo defaultFlags 1 Nothing) $- RSTStreamFrame Cancel---- | Send a malformed request, then a good one down the same connection.------ RFC 9113 section 8.1.1 makes a malformed request a stream error, so the--- server must reset that one stream and keep serving: the second request is--- the point of the test. The whole connection used to come down with the--- first, taking every other stream on it along.-runStreamErrorClient :: IO ()-runStreamErrorClient = runTCPClient host port $ \s ->- E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->- C.run cliconf conf $ \sendRequest _aux -> do- -- "te" may only ever be "trailers" (section 8.2.2), and unlike- -- "connection" it is not one of the headers the sender strips.- let bad = C.requestNoBody methodGet "/" [("te", "gzip")]- sendRequest bad (\_ -> return ()) `shouldThrow` streamWasReset- let good = C.requestNoBody methodGet "/" []- sendRequest good $ \rsp ->- C.responseStatus rsp `shouldBe` Just ok200- where- cliconf = C.defaultClientConfig{C.authority = host}+ it "resets a stream cancelled with an asynchronous exception and goes on" $+ -- The exception is only the reason for the reset. The sender+ -- once threw it, which took the whole connection down.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ 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+ -- killed half-way (#173).+ E.bracket (forkIO runServerShortTimeout) killThread $ \_ -> do+ threadDelay 10000+ runDripClient `shouldReturn` dripChunks++ it "limits the resets a peer can make us send (MadeYouReset)" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ -- Not through the client library: it would take the+ -- server's first RST_STREAM, on a stream it never opened+ -- itself, for a protocol error of its own.+ timeout 5000000 rapidStreamError+ `shouldReturn` Just (Just (EnhanceYourCalm, "too many stream errors"))++ it "gives back the slot of a stream both sides streamed on" $+ -- Room for four concurrent streams, so a few slots that are+ -- never given back stop the connection within a few thousand+ -- requests one after another. Both sides stream with flushes: the receiver used to write back a stream state+ -- it had read before the sender half-closed the stream, undoing+ -- the half-close, so the peer's END_STREAM then left the stream+ -- half-closed instead of closed and in the table for good.+ --+ -- It is a race between the receiver and the sender, so it needs+ -- them running in parallel: on one capability it hardly ever+ -- shows.+ withCapabilities 4 $+ E.bracket (forkIO runServerSmallWindow) killThread $ \_ -> do+ threadDelay 10000+ done <- newIORef (0 :: Int)+ r <- timeout 60000000 $ runTCPClient host port $ \s -> do+ -- Fifty small writes each way per request: without+ -- this, Nagle and delayed ACKs can hold each one up.+ setSocketOption s NoDelay 1+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ ->+ forM_ [1 .. 2000 :: Int] $ \_ -> do+ let req = C.requestStreaming methodPost "/both" [] $ \write flush ->+ replicateM_ 50 $ write (byteString (C8.replicate 50 'a')) >> flush+ sendRequest req $ \rsp -> do+ let drain n = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return n else drain (n + B.length bs)+ drain 0 `shouldReturn` 2500+ modifyIORef' done (+ 1)+ -- How far it got tells a hang from a slow run.+ n <- readIORef done+ when (isNothing r) $+ expectationFailure $+ "timed out after " ++ show n ++ " of 2000 requests"++ it "accepts a content-length on a response with no content" $+ -- RFC 9113, section 8.1.1: the response to HEAD, 204 and 304 can+ -- carry a non-zero content-length without content. The client+ -- used to take each of these for a malformed response.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do+ let noContent method path =+ sendRequest (C.requestNoBody method path []) $ \rsp -> do+ C.responseStatus rsp `shouldSatisfy` isJust+ C.getResponseBodyChunk rsp `shouldReturn` ""+ noContent methodHead "/"+ noContent methodHead "/data"+ noContent methodGet "/not-modified"+ -- A response that is meant to have content still+ -- has to match its content-length.+ sendRequest (C.requestNoBody methodGet "/no-content" []) (const $ return ())+ `shouldThrow` malformedResponse++ it "does not open a stream for a PRIORITY frame" $+ -- Over a raw socket, as the client library does not send+ -- PRIORITY. The server allows 64 concurrent streams; each of+ -- these PRIORITY frames used to open one and hold its slot,+ -- so the request after them was refused.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 idlePriority `shouldReturn` Just (Just "HEADERS")++ it "closes the connection when SETTINGS overflow a stream's window" $+ -- RFC 9113, section 6.9.2: a connection error of type+ -- FLOW_CONTROL_ERROR. The overflow is found in the sender,+ -- which used to stop on it without a word, leaving the+ -- connection open and silent.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ -- A connection error: GOAWAY, with no RST_STREAM before it.+ timeout 5000000 settingsOverflow+ `shouldReturn` Just (False, Just FlowControlError)++ it "accepts empty trailers" $+ -- A HEADERS frame with END_STREAM and an empty field block ends+ -- the body with no trailer fields. The empty block used to be+ -- taken for a truncated one: COMPRESSION_ERROR, and the+ -- connection closed.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 emptyTrailers `shouldReturn` Just (Just "HEADERS")++ it "checks a padded body against its content-length" $+ -- Padding is not content (RFC 9113, section 6.1). It used to+ -- be counted into the body's length, so a padded body that+ -- matched its content-length was reset as one that did not.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 paddedBody `shouldReturn` Just (Just "DATA 4")++ it "gives the padding of a body back to the windows" $+ -- 2000 DATA frames of one octet of content and 255 of padding:+ -- about twice the stream's window. The padding used to be+ -- charged and never given back, so a peer keeping to the+ -- windows stalled, and one that did not, like this one, broke+ -- the stream's limit and had the connection closed.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 paddingWindow `shouldReturn` Just (Just "DATA 2000")++ it "gives DATA it refuses back to the connection window" $+ -- DATA on a stream the peer has half-closed is a stream error+ -- (RFC 9113, section 5.1), but it still counts against the+ -- connection window (section 6.9). It used to be left out, so+ -- the peer's view of that window shrank for good. With a+ -- window of 65535, the refused 16384 octets and the 16384 of+ -- the next request make up the half that is given back.+ E.bracket (forkIO runServerSmallConnWindow) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 refusedData `shouldReturn` Just (Just (32768, "16384"))++ it "goes on sending requests after one fails before it is queued" $+ -- The file of this requestFile does not exist, so the request+ -- fails after its stream id is taken and before it is queued.+ -- Requests are queued in stream id order, so every one after it+ -- used to wait for its turn for ever.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ r <- timeout 5000000 $ runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do+ let missing =+ C.requestFile methodPost "/echo" [] $+ FileSpec "test/no-such-file" 0 10+ failed <- E.try $ sendRequest missing (const $ return ())+ either (const True) (const False) (failed :: Either E.SomeException ())+ `shouldBe` True+ replicateM_ 3 $+ sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->+ C.responseStatus rsp `shouldBe` Just ok200+ r `shouldBe` Just ()++ it "answers without a push when the peer has no room for one" $+ -- SETTINGS_MAX_CONCURRENT_STREAMS of 0 is how a peer can refuse+ -- pushes (RFC 9113, section 8.4). The push of /push-pp used to+ -- wait for room for ever, and the response to /push with it.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 pushNoRoom `shouldReturn` Just (Just "HEADERS")++ it "frees the stream of a response the client did not read to the end" $+ -- /endless never ends. Each request here reads one chunk of it+ -- and is done, by returning or by throwing. Its stream used to+ -- stay open, holding one of the server's 64 slots, with what the+ -- server sent never given back to the connection window: the+ -- 65th request waited for a slot for ever. Now each is reset,+ -- 70 in a burst, which takes a server allowing more resets a+ -- second than the default.+ E.bracket (forkIO runServerManyResets) killThread $ \_ -> do+ threadDelay 10000+ r <- timeout 10000000 $ runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do+ forM_ [1 .. 70 :: Int] $ \i -> do+ let abandon rsp = do+ _ <- C.getResponseBodyChunk rsp+ when (even i) $ E.throwIO $ userError "done with it"+ r <- E.try $ sendRequest (C.requestNoBody methodGet "/endless" []) abandon+ either (\e -> const (return ()) (e :: E.IOException)) return r+ sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->+ C.responseStatus rsp `shouldBe` Just ok200+ r `shouldBe` Just ()++ it "goes on when pushes nobody asks for fill the connection window" $+ -- Each /push-big comes with a push of 20000 octets that is never+ -- asked for. With a connection window of 65535, the fourth push+ -- used to find it used up by the first three, unread, and the+ -- connection stalled, the responses to /push-big with it.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ let cconf =+ C.defaultClientConfig+ { C.authority = host+ , C.connectionWindowSize = defaultWindowSize+ }+ r <- timeout 5000000 $ runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cconf conf $ \sendRequest _ ->+ replicateM_ 10 $+ sendRequest (C.requestNoBody methodGet "/push-big" []) $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200+ let body = do+ bs <- C.getResponseBodyChunk rsp+ unless (B.null bs) body+ body+ r `shouldBe` Just ()++ it "counts streams whose handlers are running in its GOAWAY" $+ -- RFC 9113, section 6.8: the last stream identifier is the+ -- highest one that "might have been processed". Streams 1 and+ -- 3 are being answered when the connection is closed, and used+ -- to be left out until their handlers had returned, so the+ -- GOAWAY said 0: as if the client could send them again.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 goAwayLastStream `shouldReturn` Just (Just (3, ProtocolError))++ it "finishes what the server will still answer after its GOAWAY" $+ -- RFC 9113, section 6.8: a GOAWAY with NO_ERROR and last stream 1+ -- says stream 1 will still be answered, stream 3 will not. The+ -- client used to close the connection as soon as it came,+ -- failing both, and the client function with them.+ E.bracket (forkIO runGoAwayServer) killThread $ \_ -> do+ threadDelay 10000+ r <- timeout 5000000 $ E.try $ runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ -> do+ let get = E.try . flip sendRequest readAll . C.requestNoBody methodGet "/" $ []+ readAll rsp = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return "" else (bs <>) <$> readAll rsp+ (r1, r3) <- concurrently get (threadDelay 50000 >> get)+ -- By now the connection has run its course,+ -- and the client function goes on: nothing new+ -- goes out, and it is not killed either.+ threadDelay 100000+ r5 <- get+ return (status r1, status r3, status r5)+ case r of+ Just (Right rs) -> rs `shouldBe` ("hello", "closed", "closed")+ Just (Left e) -> expectationFailure $ show (e :: C.HTTP2Error)+ Nothing -> expectationFailure "timed out"++ 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.+ -- The server used to close the connection on it at once.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 goAwayFromClient+ `shouldReturn` Just ["HEADERS 1", "DATA 1 END_STREAM", "GOAWAY NoError"]++ it "resets a malformed request and goes on serving the connection" $+ -- An upper-case field name makes the request malformed: a+ -- stream error (RFC 9113, section 8.1.1). It used to close the+ -- connection, and the next request on it went unanswered.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ 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+ -- anything off its queue, so once /endless had used it up, the+ -- response to a request with no body never went out.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ timeout 5000000 shutWindow `shouldReturn` Just (Just "HEADERS 3, then DATA 1")++ it "sends a PUSH_PROMISE before the response that carries it" $+ -- /push answers with a push of /push-pp, so a request for+ -- /push-pp after it is served from the push. The server used to+ -- let the response to /push overtake the PUSH_PROMISE now and+ -- then; the client then asked the server for /push-pp itself,+ -- and got 404. One round in a few dozen did, so 200 of them --+ -- which also takes more pushes than the peer allows concurrent+ -- streams, so pushed streams that are never closed show too.+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ done <- newIORef (0 :: Int)+ r <- timeout 30000000 $ runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run C.defaultClientConfig{C.authority = host} conf $ \sendRequest _ ->+ replicateM_ 200 $ do+ -- Bodies are read to the end, so that the+ -- streams close and give their slots back.+ let drain rsp = do+ bs <- C.getResponseBodyChunk rsp+ unless (B.null bs) $ drain rsp+ sendRequest (C.requestNoBody methodGet "/push" []) $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200+ drain rsp+ sendRequest (C.requestNoBody methodGet "/push-pp" []) $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200+ drain rsp+ modifyIORef' done (+ 1)+ -- How far it got tells a hang (at 64, the peer's concurrency+ -- limit, if pushed streams leak) from a slow run.+ n <- readIORef done+ when (isNothing r) $+ expectationFailure $+ "timed out after " ++ show n ++ " of 200 rounds"++ it "uploads a file through runIO past the stream's window" $+ -- The server announces an 8192-octet window. runIO put the rest+ -- of a body back on the queue without waiting for the window to+ -- open; with none left, the file was read into no room, and a+ -- read of 0 octets is the end of the file, so the request ended+ -- with END_STREAM after the first window's worth.+ E.bracket (forkIO runServerSmallWindow) killThread $ \_ -> do+ threadDelay 10000+ timeout 10000000 uploadIO `shouldReturn` Just 100000++ it "prevents attacks" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runAttack rapidSettings `shouldThrow` connectionError "too many settings"+ runAttack rapidPing `shouldThrow` connectionError "too many ping"+ runAttack rapidEmptyHeader+ `shouldThrow` connectionError "too many empty headers"+ runAttack rapidEmptyData `shouldThrow` connectionError "too many empty data"+ runAttack rapidRst `shouldThrow` connectionError "too many rst_stream"++ignoreHTTP2Error :: C.HTTP2Error -> IO ()+ignoreHTTP2Error _ = pure ()++runServer :: IO ()+runServer = runTCPServer (Just host) port runHTTP2Server+ where+ runHTTP2Server s =+ E.bracket+ (allocSimpleConfig s 32768)+ freeSimpleConfig+ (\conf -> run defaultServerConfig conf server)++-- | Like 'runServer', but announcing room for a single concurrent stream.+-- | Uploading 100000 octets of a file through 'C.runIO', and what the server+-- says it received.+uploadIO :: IO Int+uploadIO = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.runIO C.defaultClientConfig{C.authority = host} conf $ \C.ClientIO{..} ->+ return $ do+ let body rsp acc = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return acc else body rsp (acc <> bs)+ exchange req = cioWriteRequest req >>= cioReadResponse . snd+ -- A request first, so that the server's SETTINGS -- and its+ -- small window -- are known before the upload starts.+ _ <- exchange (C.requestNoBody methodGet "/" []) >>= (`body` "")+ rsp <-+ exchange $+ C.requestFile methodPost "/count" [] $+ FileSpec "test/inputFile" 0 100000+ read . C8.unpack <$> body rsp ""++-- | Running with at least this many capabilities.+withCapabilities :: Int -> IO a -> IO a+withCapabilities n act =+ E.bracket getNumCapabilities setNumCapabilities $ \old -> do+ setNumCapabilities (max n old)+ act++-- | Room for four concurrent streams and a small window, so that WINDOW_UPDATE+-- frames go back and forth all the time.+runServerSmallWindow :: IO ()+runServerSmallWindow = runTCPServer (Just host) port runHTTP2Server+ where+ sconf =+ defaultServerConfig+ { settings =+ (settings defaultServerConfig)+ { maxConcurrentStreams = Just 4+ , initialWindowSize = 8192+ }+ }+ runHTTP2Server s = do+ setSocketOption s NoDelay 1+ E.bracket+ (allocSimpleConfig s 32768)+ freeSimpleConfig+ (\conf -> run sconf conf server)++-- | Like 'runServer', but with the connection window left at its initial+-- 65535 octets.+runServerSmallConnWindow :: IO ()+runServerSmallConnWindow = runTCPServer (Just host) port runHTTP2Server+ where+ sconf = defaultServerConfig{connectionWindowSize = defaultWindowSize}+ runHTTP2Server s =+ E.bracket+ (allocSimpleConfig s 32768)+ freeSimpleConfig+ (\conf -> run sconf conf server)++-- | Like 'runServer', but allowing a client to reset 1000 streams a second.+runServerManyResets :: IO ()+runServerManyResets = runTCPServer (Just host) port runHTTP2Server+ where+ sconf =+ defaultServerConfig+ { settings = (settings defaultServerConfig){rstRateLimit = 1000}+ }+ runHTTP2Server s =+ E.bracket+ (allocSimpleConfig s 32768)+ freeSimpleConfig+ (\conf -> run sconf conf server)++-- | A server whose timeout is one second. Like Warp, it sets+-- 'confReadNTimeout', so the receiver has no timer of its own, which would+-- close a connection the client sends nothing on.+runServerShortTimeout :: IO ()+runServerShortTimeout = runTCPServer (Just host) port runHTTP2Server+ where+ alloc s = do+ conf <- allocSimpleConfig' s 32768 1000000+ return conf{confReadNTimeout = True}+ runHTTP2Server s =+ E.bracket+ (alloc s)+ freeSimpleConfig+ (\conf -> run defaultServerConfig conf server)++runServerMaxConc1 :: IO ()+runServerMaxConc1 = runTCPServer (Just host) port runHTTP2Server+ where+ sconf =+ defaultServerConfig+ { settings = (settings defaultServerConfig){maxConcurrentStreams = Just 1}+ }+ runHTTP2Server s =+ E.bracket+ (allocSimpleConfig s 32768)+ freeSimpleConfig+ (\conf -> run sconf conf server)++-- | A server whose handler waits long enough for a RST_STREAM to arrive+-- before it responds, and then signals that 'sendResponse' returned.+runServerCancel :: MVar () -> IO ()+runServerCancel doneVar = runTCPServer (Just host) port runHTTP2Server+ where+ runHTTP2Server s =+ E.bracket+ (allocSimpleConfig s 32768)+ freeSimpleConfig+ (\conf -> run defaultServerConfig conf cancelServer)+ cancelServer _req _aux sendResponse = do+ threadDelay 200000+ _ <- sendResponse responseHello []+ putMVar doneVar ()++runFakeServer :: MVar ByteString -> IO ()+runFakeServer prefaceVar = do+ runTCPServer (Just host) port $ \s -> do+ ref <- newIORef Nothing++ -- send settings+ sendAll s $+ "\x00\x00\x12\x04\x00\x00\x00\x00\x00"+ `mappend` "\x00\x03\x00\x00\x00\x80\x00\x04\x00"+ `mappend` "\x01\x00\x00\x00\x05\x00\xff\xff\xff"++ -- receive preface+ value <- defaultReadN s ref (B.length connectionPreface)+ putMVar prefaceVar value++ -- send goaway frame+ sendAll s "\x00\x00\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01"++ -- wait for a few ms to make sure the client has a chance to close the+ -- socket on its end+ threadDelay 10000++-- | Answering two requests with a GOAWAY that leaves out the second: the+-- headers of the first response, GOAWAY(NO_ERROR) with last stream 1, and+-- the rest of the first response a little later.+runGoAwayServer :: IO ()+runGoAwayServer = runTCPServer (Just host) port $ \s -> do+ _ <- recvAll s (B.length connectionPreface)+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let awaitRequests :: Int -> IO ()+ awaitRequests 2 = return ()+ awaitRequests n = do+ mf <- recvFrame s+ case mf of+ Nothing -> return ()+ Just (FrameSettings, fh, _)+ | not (testAck (flags fh)) -> do+ sendAll s $+ encodeFrame (EncodeInfo (setAck defaultFlags) 0 Nothing) $+ SettingsFrame []+ awaitRequests n+ Just (FrameHeaders, _, _) -> awaitRequests (n + 1)+ Just _ -> awaitRequests n+ awaitRequests 0+ sendAll s $+ encodeFrame (EncodeInfo (setEndHeader defaultFlags) 1 Nothing) $+ HeadersFrame Nothing $+ hpackEncode [(":status", "200")]+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $+ GoAwayFrame 1 NoError "going"+ threadDelay 200000+ sendAll s $+ encodeFrame (EncodeInfo (setEndStream defaultFlags) 1 Nothing) $+ DataFrame "hello"+ -- Until the client closes it.+ let drain = recvFrame s >>= maybe (return ()) (const drain)+ drain++-- | How a request through the client ended: the body, or "closed" for+-- 'ConnectionIsClosed'.+status :: Either C.HTTP2Error ByteString -> ByteString+status (Right bs) = bs+status (Left C.ConnectionIsClosed) = "closed"+status (Left e) = C8.pack $ show e++-- | 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]+goAwayFromClient = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ sendAll s $+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) 1 Nothing) $+ HeadersFrame Nothing $+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/slow")+ , (":method", "GET")+ ]+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $+ GoAwayFrame 0 NoError "going"+ collect s+ where+ collect s = do+ mf <- recvFrame s+ case mf of+ Nothing -> return []+ Just (FrameHeaders, fh, _) -> (("HEADERS " ++ show (streamId fh)) :) <$> collect s+ Just (FrameData, fh, _)+ | testEndStream (flags fh) ->+ (("DATA " ++ show (streamId fh) ++ " END_STREAM") :) <$> collect s+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ (("GOAWAY " ++ show err) :) <$> collect s+ Just _ -> collect s++server :: Server+server req aux sendResponse = case requestMethod req of+ Just "GET" -> case requestPath req of+ Just "/" -> sendResponse responseHello []+ -- A moment before the answer.+ Just "/slow" -> threadDelay 200000 >> sendResponse responseHello []+ Just "/early" -> do+ auxSendInformational+ aux+ earlyHints103+ [("link", "</style.css>; rel=preload; as=style")]+ auxSendInformational+ aux+ earlyHints103+ [("link", "</app.js>; rel=preload; as=script")]+ sendResponse responseHello []+ 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 []+ Just "/push" -> do+ let pp = pushPromise "/push-pp" responsePP 0+ sendResponse responseHello [pp]+ -- A push of 20000 octets.+ Just "/push-big" -> do+ let pp = pushPromise "/push-big-pp" responsePushBig 0+ sendResponse responseHello [pp]+ _ -> sendResponse response404 []+ 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+ if B.null bs then return n else count (n + B.length bs)+ n <- count (0 :: Int)+ sendResponse (responseBuilder ok200 [] (byteString (C8.pack (show n)))) []+ Just "/both" -> do+ -- Read the body on the side, so that the response does not+ -- wait for it.+ _ <-+ forkIO $+ 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.+ Just "/data" -> sendResponse (responseBuilder ok200 bigLength mempty) []+ -- HEADERS with END_STREAM.+ _ -> sendResponse (responseNoBody ok200 bigLength) []+ _ -> sendResponse response405 []++-- | Larger than the default frame size and than the server's 32K buffer.+bigVal :: ByteString+bigVal = C8.replicate 40000 'x'++responseBig :: Response+responseBig = setResponseTrailersMaker rsp maker+ where+ rsp = responseBuilder ok200 [("x-big", bigVal)] "hello"+ maker Nothing = return $ Trailers [("x-big-trailer", bigVal)]+ maker (Just _) = return $ NextTrailersMaker maker++-- | The stream error a client raises for a malformed response, as+-- 'sendRequest' hands it on.+malformedResponse :: C.HTTP2Error -> Bool+malformedResponse (C.StreamErrorIsSent C.ProtocolError _ _) = True+malformedResponse (C.BadThingHappen se) =+ maybe False malformedResponse $ E.fromException se+malformedResponse _ = False++-- | The content-length of content that is not there.+bigLength :: ResponseHeaders+bigLength = [("content-length", "1234")]++responseHello :: Response+responseHello = responseBuilder ok200 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Hello, world!\n"++earlyHints103 :: Status+earlyHints103 = mkStatus 103 "Early Hints"++responsePushBig :: Response+responsePushBig = responseBuilder ok200 [] $ byteString $ C8.replicate 20000 'p'++responsePP :: Response+responsePP = responseBuilder ok200 header body+ where+ header =+ [ ("Content-Type", "text/plain")+ , ("x-push", "True")+ ]+ body = byteString "Push\n"++-- | A streaming response that does not wait for the request body, so that+-- both ends are sending at once and either can finish first.+responseBoth :: Response+responseBoth = responseStreaming ok200 [] $ \write flush ->+ replicateM_ 50 $ write (byteString (C8.replicate 50 'b')) >> flush++responseEndless :: Response+responseEndless = responseStreaming ok200 [] body+ where+ body :: (Builder -> IO ()) -> IO () -> IO ()+ body write flush = forever (write (byteString chunk) *> flush) `E.catch` quiet+ chunk = C8.replicate 1024 'x'+ quiet :: E.SomeException -> IO ()+ quiet _ = return ()++dripChunks :: Int+dripChunks = 8++-- | A chunk every 300 milliseconds: 2.4 seconds in all.+responseDrip :: Response+responseDrip = responseStreaming ok200 [] $ \write flush ->+ replicateM_ dripChunks $ do+ write (byteString "x") >> flush+ threadDelay 300000++responseCancelAsync :: Response+responseCancelAsync = responseStreamingIface ok200 [] $ \iface -> do+ outBodyPush iface "x"+ 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+ header = [("Content-Type", "text/plain")]+ body :: (Builder -> IO ()) -> IO () -> IO ()+ body write flush = do+ let go n = write (byteString (C8.pack (show n)) `mappend` "\n") *> flush *> go (succ n)+ go (0 :: Int)++response404 :: Response+response404 = responseNoBody notFound404 []++response405 :: Response+response405 = responseNoBody methodNotAllowed405 []++responseEcho :: Request -> Response+responseEcho req = setResponseTrailersMaker h2rsp maker+ where+ h2rsp = responseStreaming ok200 header streamingBody+ header = [("Content-Type", "text/plain")]+ mhx = getFieldValue (toToken "X-Tag") (snd (requestHeaders req))+ streamingBody write _flush = do+ loop+ mt <- getRequestTrailers req+ firstTrailerValue <$> mt `shouldBe` mhx+ where+ loop = do+ bs <- getRequestBodyChunk req+ when (bs /= "") $ do+ void $ write $ byteString bs+ loop+ maker = trailersMaker (CH.hashInit :: Context SHA1)++-- Strictness is important for Context.+trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker+trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]+ where+ !sha1 = C8.pack $ show $ CH.hashFinalize ctx+trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'+ where+ !ctx' = CH.hashUpdate ctx bs++-- | Request @/early@ with an informational handler installed, recording each+-- 103 Early Hints section and returning the final response status.+runClientEarly :: IORef [TokenHeaderTable] -> IO (Maybe Status)+runClientEarly hintsRef = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf0 ->+ C.run cliconf (conf0{confOnInformational = onInformational}) $ \sendRequest _aux ->+ sendRequest (C.requestNoBody methodGet "/early" []) (return . C.responseStatus)+ where+ cliconf = C.defaultClientConfig{C.authority = host}+ onInformational _sid tbl = modifyIORef' hintsRef (++ [tbl])++runClient :: (Socket -> BufferSize -> IO Config) -> IO ()+runClient allocConfig =+ runTCPClient host port runHTTP2Client+ where+ auth = host+ cliconf = C.defaultClientConfig{C.authority = auth}+ runHTTP2Client s =+ E.bracket+ (allocConfig s 4096)+ freeSimpleConfig+ (\conf -> C.run cliconf conf client)++ client :: C.Client ()+ client sendRequest aux =+ foldr1+ concurrently_+ [ client0 sendRequest aux+ , client1 sendRequest aux+ , client2 sendRequest aux+ , client3 sendRequest aux+ , client3' sendRequest aux+ , client3'' sendRequest aux+ , client4 sendRequest aux+ , client5 sendRequest aux+ ]++-- delay sending preface to be able to test if it is always sent first+allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config+allocSlowPrefaceConfig s size = do+ config <- allocSimpleConfig s size+ pure config{confSendAll = slowPrefaceSend (confSendAll config)}+ where+ slowPrefaceSend :: (ByteString -> IO ()) -> ByteString -> IO ()+ slowPrefaceSend orig chunk = do+ when (C8.pack "PRI" `C8.isPrefixOf` chunk) $ do+ threadDelay 10000+ orig chunk++client0 :: C.Client ()+client0 sendRequest _aux = do+ let req = C.requestNoBody methodGet "/" []+ sendRequest req $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200+ fmap statusMessage (C.responseStatus rsp) `shouldBe` Just "OK"++client1 :: C.Client ()+client1 sendRequest _aux = do+ let req = C.requestNoBody methodGet "/push-pp" []+ sendRequest req $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just notFound404++client2 :: C.Client ()+client2 sendRequest _aux = do+ let req = C.requestNoBody methodPut "/" []+ sendRequest req $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just methodNotAllowed405++client3 :: C.Client ()+client3 sendRequest _aux = do+ let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a"+ req0 =+ C.requestFile methodPost "/echo" [("X-Tag", hx)] $+ FileSpec "test/inputFile" 0 1012731+ req = C.setRequestTrailersMaker req0 maker+ sendRequest req $ \rsp -> do+ let consumeBody = do+ bs <- C.getResponseBodyChunk rsp+ when (bs /= "") consumeBody+ consumeBody+ mt <- C.getResponseTrailers rsp+ firstTrailerValue <$> mt `shouldBe` Just hx+ where+ !maker = trailersMaker (CH.hashInit :: Context SHA1)++client3' :: C.Client ()+client3' sendRequest _aux = do+ let hx = "b0870457df2b8cae06a88657a198d9b52f8e2b0a"+ req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do+ let sendFile h = do+ bs <- B.hGet h 1024+ when (bs /= "") $ do+ write $ byteString bs+ sendFile h+ withFile "test/inputFile" ReadMode sendFile+ req = C.setRequestTrailersMaker req0 maker+ sendRequest req $ \rsp -> do+ let consumeBody = do+ bs <- C.getResponseBodyChunk rsp+ when (bs /= "") consumeBody+ consumeBody+ mt <- C.getResponseTrailers rsp+ firstTrailerValue <$> mt `shouldBe` Just hx+ where+ !maker = trailersMaker (CH.hashInit :: Context SHA1)++client3'' :: C.Client ()+client3'' sendRequest _axu = do+ let hx = "59f82dfddc0adf5bdf7494b8704f203a67e25d4a"+ req0 = C.requestStreaming methodPost "/echo" [("X-Tag", hx)] $ \write _flush -> do+ let chunk = C8.replicate (16384 * 2) 'c'+ tag = C8.replicate 16 't'+ -- I don't think 9 is important here, this is just what I have, the client hangs on receiving the last one+ replicateM_ 9 $ write $ byteString chunk+ write $ byteString tag+ req = C.setRequestTrailersMaker req0 maker+ sendRequest req $ \rsp -> do+ let consumeBody = do+ bs <- C.getResponseBodyChunk rsp+ when (bs /= "") consumeBody+ consumeBody+ mt <- C.getResponseTrailers rsp+ firstTrailerValue <$> mt `shouldBe` Just hx+ where+ !maker = trailersMaker (CH.hashInit :: Context SHA1)++client4 :: C.Client ()+client4 sendRequest _aux = do+ let req0 = C.requestNoBody methodGet "/push" []+ sendRequest req0 $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200+ let req1 = C.requestNoBody methodGet "/push-pp" []+ sendRequest req1 $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200++client5 :: C.Client ()+client5 sendRequest _aux = do+ let req0 = C.requestNoBody methodGet "/stream" []+ sendRequest req0 $ \rsp -> do+ C.responseStatus rsp `shouldBe` Just ok200+ let go n+ | n > 0 = do+ _ <- C.getResponseBodyChunk rsp+ go (pred n)+ | otherwise = pure ()+ go (100 :: Int)++firstTrailerValue :: TokenHeaderTable -> FieldValue+firstTrailerValue tbl = case fst tbl of+ [] -> error "firstTrailerValue"+ x : _ -> snd x++runAttack :: (C.ClientIO -> IO ()) -> IO ()+runAttack attack =+ runTCPClient host port runHTTP2Client+ where+ auth = host+ cliconf = C.defaultClientConfig{C.authority = auth}+ runHTTP2Client s =+ E.bracket+ (allocSimpleConfig s 4096)+ freeSimpleConfig+ (\conf -> C.runIO cliconf conf client)+ client cconf = return $ do+ attack cconf+ threadDelay 1000000++rapidSettings :: C.ClientIO -> IO ()+rapidSettings C.ClientIO{..} = do+ let einfo = EncodeInfo defaultFlags 0 Nothing+ bs = encodeFrame einfo $ SettingsFrame [(SettingsEnablePush, 0)]+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs++rapidPing :: C.ClientIO -> IO ()+rapidPing C.ClientIO{..} = do+ let einfo = EncodeInfo defaultFlags 0 Nothing+ opaque64 = "01234567"+ bs = encodeFrame einfo $ PingFrame opaque64+ replicateM_ 20 $ cioWriteBytes bs++rapidEmptyHeader :: C.ClientIO -> IO ()+rapidEmptyHeader C.ClientIO{..} = do+ (sid, _) <- cioCreateStream+ let einfo = EncodeInfo defaultFlags sid Nothing+ bs = encodeFrame einfo $ HeadersFrame Nothing ""+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs+ cioWriteBytes bs++rapidEmptyData :: C.ClientIO -> IO ()+rapidEmptyData C.ClientIO{..} = do+ (sid, _) <- cioCreateStream+ let einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]+ bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr+ cioWriteBytes bsH+ let einfoD = EncodeInfo defaultFlags sid Nothing+ bsD = encodeFrame einfoD $ DataFrame ""+ cioWriteBytes bsD+ cioWriteBytes bsD+ cioWriteBytes bsD+ cioWriteBytes bsD+ cioWriteBytes bsD+ cioWriteBytes bsD+ cioWriteBytes bsD+ cioWriteBytes bsD++rapidRst :: C.ClientIO -> IO ()+rapidRst C.ClientIO{..} = do+ reset+ reset+ reset+ reset+ reset+ reset+ reset+ reset+ where+ reset = do+ (sid, _) <- cioCreateStream+ -- setEndStream for HalfClosedRemote+ let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]+ bsH = encodeFrame einfoH $ HeadersFrame Nothing hdr+ cioWriteBytes bsH+ let einfoR = EncodeInfo defaultFlags sid Nothing+ -- Only (HalfClosedRemote, NoError) is accepted.+ -- Otherwise, a stream error terminates the connection.+ bsR = encodeFrame einfoR $ RSTStreamFrame NoError+ cioWriteBytes bsR++-- | MadeYouReset (CVE-2025-8671): the same churn as 'rapidRst' without a+-- single RST_STREAM from us. Each stream gets a handler that goes on+-- running, then a PRIORITY making it depend on itself, which the server+-- answers by resetting the stream -- giving its concurrency slot back while+-- the handler runs on. Those resets did not count against the limit on+-- resets, so this could be kept up for as long as the peer liked.+rapidStreamError :: IO (Maybe (ErrorCode, ByteString))+rapidStreamError = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ forM_ [1, 3 .. 15] $ \sid -> do+ let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/stream")+ , (":method", "GET")+ ]+ einfoP = EncodeInfo defaultFlags sid Nothing+ sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ sendAll s $ encodeFrame einfoP $ PriorityFrame $ Priority False sid 16+ awaitGoAway s++-- | What the server says in its GOAWAY, if it sends one before closing.+awaitGoAway :: Socket -> IO (Maybe (ErrorCode, ByteString))+awaitGoAway s = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err msg) <- decodeGoAwayFrame fh p ->+ return $ Just (err, msg)+ Just _ -> awaitGoAway s++-- | A SETTINGS_INITIAL_WINDOW_SIZE that takes an open stream's window past+-- 2^31-1. What the server answers with: whether it reset the stream, and+-- the error in its GOAWAY.+settingsOverflow :: IO (Bool, Maybe ErrorCode)+settingsOverflow = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let sid = 1+ -- No END_STREAM: the stream stays open, waiting for the body.+ einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/echo")+ , (":method", "POST")+ ]+ sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ -- The stream's window is now the largest there is ...+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags sid Nothing) $+ WindowUpdateFrame (maxWindowSize - defaultWindowSize)+ -- ... and one more octet of initial window takes it over.+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $+ SettingsFrame [(SettingsInitialWindowSize, defaultWindowSize + 1)]+ answer s False+ where+ answer s reset = do+ mf <- recvFrame s+ case mf of+ Nothing -> return (reset, Nothing)+ Just (FrameRSTStream, _, _) -> answer s True+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return (reset, Just err)+ Just _ -> answer s reset++-- | A request whose body ends with an empty trailer block. What the+-- server answers it with.+emptyTrailers :: IO (Maybe String)+emptyTrailers = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let sid = 1+ einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/count")+ , (":method", "POST")+ ]+ einfoT = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing+ sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ sendAll s $ encodeFrame (EncodeInfo defaultFlags sid Nothing) $ DataFrame "body"+ sendAll s $ encodeFrame einfoT $ HeadersFrame Nothing ""+ answer s sid+ where+ answer s sid = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameHeaders, fh, _)+ | streamId fh == sid -> return $ Just "HEADERS"+ Just (FrameRSTStream, fh, p)+ | streamId fh == sid+ , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p ->+ return $ Just $ "RST_STREAM " ++ show err+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return $ Just $ "GOAWAY " ++ show err+ Just _ -> answer s sid++-- | A request with a content-length of 4, whose body comes in padded DATA+-- frames: "bo", "dy", and an empty one with END_STREAM. What the server+-- answers it with: the body of its response, which is the number of octets+-- of body that arrived.+paddedBody :: IO (Maybe String)+paddedBody = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let sid = 1+ einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/count")+ , (":method", "POST")+ , ("content-length", "4")+ ]+ padding = C8.replicate 10 '\0'+ einfoD = EncodeInfo defaultFlags sid (Just padding)+ einfoE = EncodeInfo (setEndStream defaultFlags) sid (Just padding)+ sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ sendAll s $ encodeFrame einfoD $ DataFrame "bo"+ sendAll s $ encodeFrame einfoD $ DataFrame "dy"+ sendAll s $ encodeFrame einfoE $ DataFrame ""+ answer s sid+ where+ answer s sid = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameData, fh, p)+ | streamId fh == sid -> return $ Just $ "DATA " ++ C8.unpack p+ Just (FrameRSTStream, fh, p)+ | streamId fh == sid+ , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p ->+ return $ Just $ "RST_STREAM " ++ show err+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return $ Just $ "GOAWAY " ++ show err+ Just _ -> answer s sid++-- | A request whose body is 2000 DATA frames of one octet each, padded to+-- 257 octets of payload, more than the stream's window in all. Sent+-- without waiting for WINDOW_UPDATE: every octet of padding has to have+-- been given back by the time the next frame is checked. What the server+-- answers it with: the number of octets of body that arrived.+paddingWindow :: IO (Maybe String)+paddingWindow = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let sid = 1+ einfoH = EncodeInfo (setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/count")+ , (":method", "POST")+ ]+ padding = C8.replicate 255 '\0'+ einfoD = EncodeInfo defaultFlags sid (Just padding)+ einfoE = EncodeInfo (setEndStream defaultFlags) sid Nothing+ sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ replicateM_ 2000 $ sendAll s $ encodeFrame einfoD $ DataFrame "x"+ sendAll s $ encodeFrame einfoE $ DataFrame ""+ answer s sid+ where+ answer s sid = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameData, fh, p)+ | streamId fh == sid -> return $ Just $ "DATA " ++ C8.unpack p+ Just (FrameRSTStream, fh, p)+ | streamId fh == sid+ , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p ->+ return $ Just $ "RST_STREAM " ++ show err+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err msg) <- decodeGoAwayFrame fh p ->+ return $ Just $ "GOAWAY " ++ show err ++ " " ++ C8.unpack msg+ Just _ -> answer s sid++-- | 16384 octets of DATA on a stream we have half-closed, then a request+-- with a body of 16384 octets. What the server gives back to the+-- connection window before answering the request, and the answer: the+-- number of octets of body that arrived.+refusedData :: IO (Maybe (Int, String))+refusedData = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let request sid method path flags =+ encodeFrame (EncodeInfo (flags $ setEndHeader defaultFlags) sid Nothing) $+ HeadersFrame Nothing $+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", path)+ , (":method", method)+ ]+ chunk = C8.replicate 16384 'x'+ -- A response that goes on for ever keeps stream 1 in the table.+ sendAll s $ request 1 "GET" "/stream" setEndStream+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 1 Nothing) $ DataFrame chunk+ sendAll s $ request 3 "POST" "/count" id+ sendAll s $+ encodeFrame (EncodeInfo (setEndStream defaultFlags) 3 Nothing) $+ DataFrame chunk+ answer s 0+ where+ answer s n = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameWindowUpdate, fh, p)+ | streamId fh == 0+ , Right (WindowUpdateFrame w) <- decodeWindowUpdateFrame fh p ->+ answer s (n + w)+ Just (FrameData, fh, p)+ | streamId fh == 3 -> return $ Just (n, C8.unpack p)+ Just (FrameGoAway, _, _) -> return Nothing+ Just _ -> answer s n++-- | A request for /push, which comes with a push, from a peer that has+-- announced room for no streams of the server's. What the server answers+-- it with first.+pushNoRoom :: IO (Maybe String)+pushNoRoom = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $+ SettingsFrame [(SettingsMaxConcurrentStreams, 0)]+ -- The server takes our SETTINGS on board once it has acknowledged them,+ -- and before it goes on to what comes next: the answer to a PING sent+ -- after them.+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $+ PingFrame "12345678"+ awaitPingAck s+ let sid = 1+ einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/push")+ , (":method", "GET")+ ]+ sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ answer s sid+ where+ awaitPingAck s = do+ mf <- recvFrame s+ case mf of+ Just (FramePing, fh, _) | testAck (flags fh) -> return ()+ Just _ -> awaitPingAck s+ Nothing -> return ()+ answer s sid = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameHeaders, fh, _)+ | streamId fh == sid -> return $ Just "HEADERS"+ Just (FramePushPromise, _, _) -> return $ Just "PUSH_PROMISE"+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return $ Just $ "GOAWAY " ++ show err+ Just _ -> answer s sid++-- | Two requests that are answered for ever, then SETTINGS that are a+-- connection error. The last stream identifier and the error of the+-- server's GOAWAY.+goAwayLastStream :: IO (Maybe (StreamId, ErrorCode))+goAwayLastStream = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ forM_ [1, 3] $ \sid ->+ sendAll s $+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $+ HeadersFrame Nothing $+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/endless")+ , (":method", "GET")+ ]+ -- SETTINGS_ENABLE_PUSH can only be 0 or 1.+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $+ SettingsFrame [(SettingsEnablePush, 2)]+ answer s+ where+ answer s = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame sid err _) <- decodeGoAwayFrame fh p ->+ return $ Just (sid, err)+ Just _ -> answer s++-- | A request with an upper-case field name on stream 1, then a good one+-- on stream 3. What the server sends on them, up to the answer on 3.+malformedRequest :: IO [String]+malformedRequest = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let request sid extra =+ encodeFrame (EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing) $+ HeadersFrame Nothing $+ hpackEncode $+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]+ ++ extra+ sendAll s $ request 1 [("X-Upper", "1")]+ sendAll s $ request 3 []+ collect s+ where+ 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 ->+ (("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 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+-- back goes on.+shutWindow :: IO (Maybe String)+shutWindow = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ let 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 $ request 1 "/endless"+ used <- untilShut s 0+ if not used+ then return Nothing+ else do+ sendAll s $ request 3 "/not-modified"+ ma <- answer s+ case ma of+ Just "HEADERS 3" -> do+ forM_ [0, 1] $ \sid ->+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags sid Nothing) $+ WindowUpdateFrame 1000+ fmap ("HEADERS 3, then " ++) <$> resumed s+ _ -> return ma+ where+ resumed s = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameData, fh, _)+ | streamId fh == 1 -> return $ Just "DATA 1"+ Just _ -> resumed s+ untilShut s n+ | n >= defaultWindowSize = return True+ | otherwise = do+ mf <- recvFrame s+ case mf of+ Nothing -> return False+ Just (FrameData, fh, _) -> untilShut s (n + payloadLength fh)+ Just _ -> untilShut s n+ answer s = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameHeaders, fh, _)+ | streamId fh == 3 -> return $ Just "HEADERS 3"+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return $ Just $ "GOAWAY " ++ show err+ Just _ -> answer s++-- | PRIORITY frames for 100 streams that are never opened, then a request.+-- What the server answers the request with.+idlePriority :: IO (Maybe String)+idlePriority = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ forM_ [3, 5 .. 201] $ \sid ->+ sendAll s $+ encodeFrame (EncodeInfo defaultFlags sid Nothing) $+ PriorityFrame $+ Priority False 0 16+ let sid = 203+ einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]+ sendAll s $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ answer s sid+ where+ answer s sid = do+ mf <- recvFrame s+ case mf of+ Nothing -> return Nothing+ Just (FrameHeaders, fh, _)+ | streamId fh == sid -> return $ Just "HEADERS"+ Just (FrameRSTStream, fh, p)+ | streamId fh == sid+ , Right (RSTStreamFrame err) <- decodeRSTStreamFrame fh p ->+ return $ Just $ "RST_STREAM " ++ show err+ Just (FrameGoAway, fh, p)+ | Right (GoAwayFrame _ err _) <- decodeGoAwayFrame fh p ->+ return $ Just $ "GOAWAY " ++ show err+ Just _ -> answer s sid++-- | Exactly so many octets off a raw connection, or fewer once it is closed.+recvAll :: Socket -> Int -> IO ByteString+recvAll s n0 = go n0 []+ where+ go 0 acc = return $ B.concat $ reverse acc+ go k acc = do+ bs <- recv s k+ if B.null bs+ then return $ B.concat $ reverse acc+ else go (k - B.length bs) (bs : acc)++-- | One frame off a raw connection, or 'Nothing' once it is closed.+recvFrame :: Socket -> IO (Maybe (FrameType, FrameHeader, ByteString))+recvFrame s = do+ mh <- recvExactly frameHeaderLength+ case mh of+ Nothing -> return Nothing+ Just h -> do+ let (ftyp, fh) = decodeFrameHeader h+ fmap (\p -> (ftyp, fh, p)) <$> recvExactly (payloadLength fh)+ where+ recvExactly n = go n []+ where+ go 0 acc = return $ Just $ B.concat $ reverse acc+ go k acc = do+ bs <- recv s k+ if B.null bs+ then return Nothing+ else go (k - B.length bs) (bs : acc)++-- | Open a stream, reset it, then open two more. The server announced room+-- for one concurrent stream, so the third one here must be refused.+--+-- Closing a stream used to give its slot back twice -- a RST_STREAM carrying a+-- non-critical error code is closed by both 'stream' and 'processState' -- so+-- the count drifted down by one on every reset and this sequence went through+-- unchallenged.+-- | A HEADERS frame opening a stream and leaving it open, so that it goes on+-- holding a concurrency slot.+--+-- Stream identifiers are written out rather than taken from+-- 'C.cioCreateStream': the limit being overrun is the one the server+-- announced, and asking for a stream the proper way would block on that same+-- limit on this side.+openStreamFrame :: StreamId -> ByteString+openStreamFrame sid = encodeFrame einfo $ HeadersFrame Nothing hdr+ where+ einfo = EncodeInfo (setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]++-- | Speak raw frames to the server and collect what it says back.+rawExchange :: [ByteString] -> IO [(FrameType, StreamId, ByteString)]+rawExchange out = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ mapM_ (sendAll s) out+ splitFrames <$> collect mempty s+ where+ collect acc s = do+ mbs <- timeout 300000 $ recv s 4096+ case mbs of+ Just bs | not (B.null bs) -> collect (acc `B.append` bs) s+ _ -> return acc++splitFrames :: ByteString -> [(FrameType, StreamId, ByteString)]+splitFrames bs+ | B.length bs < frameHeaderLength = []+ | otherwise =+ let (h, rest) = B.splitAt frameHeaderLength bs+ (typ, FrameHeader{payloadLength, streamId}) = decodeFrameHeader h+ (body, rest') = B.splitAt payloadLength rest+ in (typ, streamId, body) : splitFrames rest'++-- | The RST_STREAM and GOAWAY frames among them, with their error codes.+resets+ :: [(FrameType, StreamId, ByteString)] -> [(FrameType, StreamId, ErrorCode)]+resets frames =+ [ (typ, sid, ec)+ | (typ, sid, body) <- frames+ , typ == FrameRSTStream || typ == FrameGoAway+ , Just ec <- [errorCodeOf typ sid body]+ ]+ where+ errorCodeOf FrameRSTStream sid body =+ case decodeRSTStreamFrame (FrameHeader (B.length body) defaultFlags sid) body of+ Right (RSTStreamFrame ec) -> Just ec+ _ -> Nothing+ errorCodeOf FrameGoAway sid body =+ case decodeGoAwayFrame (FrameHeader (B.length body) defaultFlags sid) body of+ Right (GoAwayFrame _ ec _) -> Just ec+ _ -> Nothing+ errorCodeOf _ _ _ = Nothing++-- | Open a stream and cancel it straight away, while the server is still+-- working on the response.+--+-- The sender skips a stream that is already half-closed, and used to return+-- without telling the thread that enqueued the output. That thread sat in+-- 'syncWithSender'' on an MVar nothing would fill, so 'sendResponse' never+-- returned and the worker was only reclaimed when the timeout manager killed+-- it, seconds later.+cancelInFlight :: C.ClientIO -> IO ()+cancelInFlight C.ClientIO{..} = do+ -- setEndStream for HalfClosedRemote, so that CANCEL is accepted as a+ -- stream error rather than taken down the connection.+ let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) 1 Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]+ cioWriteBytes $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ cioWriteBytes $+ encodeFrame (EncodeInfo defaultFlags 1 Nothing) $+ RSTStreamFrame Cancel++-- | Send a malformed request, then a good one down the same connection.+--+-- RFC 9113 section 8.1.1 makes a malformed request a stream error, so the+-- server must reset that one stream and keep serving: the second request is+-- the point of the test. The whole connection used to come down with the+-- first, taking every other stream on it along.+runStreamErrorClient :: IO ()+runStreamErrorClient = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cliconf conf $ \sendRequest _aux -> do+ -- "te" may only ever be "trailers" (section 8.2.2), and unlike+ -- "connection" it is not one of the headers the sender strips.+ let bad = C.requestNoBody methodGet "/" [("te", "gzip")]+ sendRequest bad (\_ -> return ()) `shouldThrow` streamWasReset+ let good = C.requestNoBody methodGet "/" []+ sendRequest good $ \rsp ->+ C.responseStatus rsp `shouldBe` Just ok200+ where+ cliconf = C.defaultClientConfig{C.authority = host}++-- | How many octets of '/drip' arrive.+runDripClient :: IO Int+runDripClient = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cliconf conf $ \sendRequest _aux -> do+ let req = C.requestNoBody methodGet "/drip" []+ count rsp n = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return n else count rsp (n + B.length bs)+ sendRequest req $ \rsp -> count rsp 0+ where+ cliconf = C.defaultClientConfig{C.authority = host}++runAsyncCancelClient :: IO ()+runAsyncCancelClient = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cliconf conf $ \sendRequest _aux -> do+ let req = C.requestNoBody methodGet "/cancel-async" []+ drain rsp = do+ bs <- C.getResponseBodyChunk rsp+ unless (B.null bs) $ drain rsp+ sendRequest req drain `shouldThrow` streamWasReset+ let good = C.requestNoBody methodGet "/" []+ sendRequest good $ \rsp ->+ 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