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