diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Network/HPACK.hs b/Network/HPACK.hs --- a/Network/HPACK.hs +++ b/Network/HPACK.hs @@ -22,6 +22,8 @@ withDynamicTableForEncoding, withDynamicTableForDecoding, setLimitForEncoding, + setHeaderListSizeLimit, + getHeaderListSizeLimit, -- * Strategy for encoding CompressionAlgo (..), diff --git a/Network/HPACK/HeaderBlock/Decode.hs b/Network/HPACK/HeaderBlock/Decode.hs --- a/Network/HPACK/HeaderBlock/Decode.hs +++ b/Network/HPACK/HeaderBlock/Decode.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HPACK/Huffman/Decode.hs b/Network/HPACK/Huffman/Decode.hs --- a/Network/HPACK/Huffman/Decode.hs +++ b/Network/HPACK/Huffman/Decode.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HPACK/Table.hs b/Network/HPACK/Table.hs --- a/Network/HPACK/Table.hs +++ b/Network/HPACK/Table.hs @@ -16,6 +16,8 @@ needChangeTableSize, setLimitForEncoding, resetLimitForEncoding, + setHeaderListSizeLimit, + getHeaderListSizeLimit, -- * Insertion insertEntry, diff --git a/Network/HPACK/Table/Dynamic.hs b/Network/HPACK/Table/Dynamic.hs --- a/Network/HPACK/Table/Dynamic.hs +++ b/Network/HPACK/Table/Dynamic.hs @@ -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 = diff --git a/Network/HPACK/Types.hs b/Network/HPACK/Types.hs --- a/Network/HPACK/Types.hs +++ b/Network/HPACK/Types.hs @@ -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 diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -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) diff --git a/Network/HTTP2/H2/Config.hs b/Network/HTTP2/H2/Config.hs --- a/Network/HTTP2/H2/Config.hs +++ b/Network/HTTP2/H2/Config.hs @@ -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 diff --git a/Network/HTTP2/H2/Context.hs b/Network/HTTP2/H2/Context.hs --- a/Network/HTTP2/H2/Context.hs +++ b/Network/HTTP2/H2/Context.hs @@ -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 diff --git a/Network/HTTP2/H2/HPACK.hs b/Network/HTTP2/H2/HPACK.hs --- a/Network/HTTP2/H2/HPACK.hs +++ b/Network/HTTP2/H2/HPACK.hs @@ -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 diff --git a/Network/HTTP2/H2/OutBodyIface.hs b/Network/HTTP2/H2/OutBodyIface.hs --- a/Network/HTTP2/H2/OutBodyIface.hs +++ b/Network/HTTP2/H2/OutBodyIface.hs @@ -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 diff --git a/Network/HTTP2/H2/Queue.hs b/Network/HTTP2/H2/Queue.hs --- a/Network/HTTP2/H2/Queue.hs +++ b/Network/HTTP2/H2/Queue.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HTTP2/H2/Receiver.hs b/Network/HTTP2/H2/Receiver.hs --- a/Network/HTTP2/H2/Receiver.hs +++ b/Network/HTTP2/H2/Receiver.hs @@ -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 diff --git a/Network/HTTP2/H2/Sender.hs b/Network/HTTP2/H2/Sender.hs --- a/Network/HTTP2/H2/Sender.hs +++ b/Network/HTTP2/H2/Sender.hs @@ -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) = diff --git a/Network/HTTP2/H2/Settings.hs b/Network/HTTP2/H2/Settings.hs --- a/Network/HTTP2/H2/Settings.hs +++ b/Network/HTTP2/H2/Settings.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HTTP2/H2/Stream.hs b/Network/HTTP2/H2/Stream.hs --- a/Network/HTTP2/H2/Stream.hs +++ b/Network/HTTP2/H2/Stream.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HTTP2/H2/Sync.hs b/Network/HTTP2/H2/Sync.hs --- a/Network/HTTP2/H2/Sync.hs +++ b/Network/HTTP2/H2/Sync.hs @@ -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 diff --git a/Network/HTTP2/H2/Types.hs b/Network/HTTP2/H2/Types.hs --- a/Network/HTTP2/H2/Types.hs +++ b/Network/HTTP2/H2/Types.hs @@ -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) ---------------------------------------------------------------- diff --git a/Network/HTTP2/H2/Window.hs b/Network/HTTP2/H2/Window.hs --- a/Network/HTTP2/H2/Window.hs +++ b/Network/HTTP2/H2/Window.hs @@ -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 diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs --- a/Network/HTTP2/Server/Run.hs +++ b/Network/HTTP2/Server/Run.hs @@ -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 diff --git a/Network/HTTP2/Server/Worker.hs b/Network/HTTP2/Server/Worker.hs --- a/Network/HTTP2/Server/Worker.hs +++ b/Network/HTTP2/Server/Worker.hs @@ -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 ---------------------------------------------------------------- diff --git a/bench-hpack/Main.hs b/bench-hpack/Main.hs --- a/bench-hpack/Main.hs +++ b/bench-hpack/Main.hs @@ -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" diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: http2 -version: 5.4.6 +version: 5.4.9 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -122,7 +122,7 @@ network-byte-order >=0.1.7 && <0.2, network-control >=0.1 && <0.2, stm >=2.5 && <2.6, - time-manager >=0.3.0 && <0.4, + time-manager >=0.3.0 && <0.5, unix-time >=0.4.11 && <0.6, utf8-string >=1.0 && <1.1 diff --git a/test/HPACK/DecodeSpec.hs b/test/HPACK/DecodeSpec.hs --- a/test/HPACK/DecodeSpec.hs +++ b/test/HPACK/DecodeSpec.hs @@ -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. diff --git a/test/HPACK/HuffmanSpec.hs b/test/HPACK/HuffmanSpec.hs --- a/test/HPACK/HuffmanSpec.hs +++ b/test/HPACK/HuffmanSpec.hs @@ -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 diff --git a/test/HTTP2/FrameSpec.hs b/test/HTTP2/FrameSpec.hs --- a/test/HTTP2/FrameSpec.hs +++ b/test/HTTP2/FrameSpec.hs @@ -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 diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -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", "; rel=preload; as=style")] - auxSendInformational - aux - earlyHints103 - [("link", "; 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", "; rel=preload; as=style")] + auxSendInformational + aux + earlyHints103 + [("link", "; 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