diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,63 @@ # ChangeLog for http2 +## 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. + [#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. + [#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. + [#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. + [#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. + [#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. + [#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. + [#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. + [#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. + [#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. + [#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. + [#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. + [#197](https://github.com/kazu-yamamoto/http2/pull/197) + ## 5.4.5 * Security: frame payload decoders read their fixed-size fields without diff --git a/Network/HPACK/HeaderBlock/Encode.hs b/Network/HPACK/HeaderBlock/Encode.hs --- a/Network/HPACK/HeaderBlock/Encode.hs +++ b/Network/HPACK/HeaderBlock/Encode.hs @@ -297,49 +297,23 @@ -> IO ByteString encodeString h bs = withWriteBuffer 4096 $ \wbuf -> encStr wbuf h bs -{- -N+ 1 2 3 <- bytes -8 254 382 16638 -7 126 254 16510 -6 62 190 16446 -5 30 158 16414 -4 14 142 16398 -3 6 134 16390 -2 2 130 16386 -1 0 128 16384 --} - +-- | The number of octets 'encodeI' produces for @l@ with an N-bit prefix. +-- +-- 'encodeS' reserves this much before it knows the Huffman-coded length, and +-- moves the code if the guess was wrong, so it has to be exact. It used to +-- stop at three octets, which is enough only up to 2^N - 1 + 2^14 - 1: +-- a Huffman-coded string of 16K or more needs four, and 'encodeI' then wrote +-- the last of them over the first octet of the code. +-- +-- >>> map (integerLength 7) [126, 127, 254, 255, 16510, 16511] +-- [1,2,2,3,3,4] {-# INLINE integerLength #-} integerLength :: Int -> Int -> Int -integerLength 8 l - | l <= 254 = 1 - | l <= 382 = 2 - | otherwise = 3 -integerLength 7 l - | l <= 126 = 1 - | l <= 254 = 2 - | otherwise = 3 -integerLength 6 l - | l <= 62 = 1 - | l <= 190 = 2 - | otherwise = 3 -integerLength 5 l - | l <= 30 = 1 - | l <= 158 = 2 - | otherwise = 3 -integerLength 4 l - | l <= 14 = 1 - | l <= 142 = 2 - | otherwise = 3 -integerLength 3 l - | l <= 6 = 1 - | l <= 134 = 2 - | otherwise = 3 -integerLength 2 l - | l <= 2 = 1 - | l <= 130 = 2 - | otherwise = 3 -integerLength _ l - | l <= 0 = 1 - | l <= 128 = 2 - | otherwise = 3 +integerLength n l + | l < p = 1 + | otherwise = go 2 (l - p) + where + p = (1 `shiftL` n) - 1 + go k r + | r < 128 = k + | otherwise = go (k + 1) (r `shiftR` 7) 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 @@ -55,7 +55,13 @@ maxN <- readIORef maxNumOfEntries off <- readIORef offset x <- adj maxN (didx - off) - return $ x + staticTableSize + -- Entries sit at off+1 .. off+n, so the relative position is 1 .. n. + -- When the ring is full, n is maxN and the oldest entry is at off+maxN, + -- which is off itself: the modulus makes that 0 rather than maxN, and 0 + -- is index 61 of the static table. 'toDynamicEntry', going the other + -- way, lands on the right slot either way. + let x' = if x == 0 then maxN else x + return $ x' + staticTableSize ---------------------------------------------------------------- @@ -312,18 +318,49 @@ ---------------------------------------------------------------- -- | Inserting 'Entry' to 'DynamicTable'. +-- +-- Entries are evicted first and the new one added after, as RFC 7541 +-- section 4.4 has it: "Before a new entry is added to the dynamic table, +-- entries are evicted from the end of the dynamic table until the size of +-- the dynamic table is less than or equal to (maximum size - new entry +-- size) or until the table is empty." An entry larger than the table +-- empties it and is not added. +-- +-- The order matters to the ring. It has room for maxNumbers entries, and +-- the table holds that many whenever they are all close to the 32-octet +-- minimum -- at a size of 40 or 100, say. Added first, the new entry +-- landed on the oldest one's slot, and the eviction that followed read that +-- slot back and took out the new entry instead, leaving a dummy. After +-- evicting there is always a free slot: every entry is 32 octets or more, +-- so the entries left and the new one come to at most maxNumbers. insertEntry :: Entry -> DynamicTable -> IO () insertEntry e dyntbl@DynamicTable{..} = do - -- Theoretically speaking, dropping entries by adjustTableSize - -- should be first. However, non-used slots always exist since the - -- size of dynamic table calculated via the minimum entry size (32 - -- bytes). To simply adjustTableSize, insertFront is called first. - insertFront e dyntbl - es <- adjustTableSize dyntbl + es <- evictFor (entrySize e) dyntbl + -- Before the new entry goes in: the reverse index is keyed by name and + -- value, so an evicted entry equal to the new one would take its + -- mapping out with it. case codeInfo of CIE (EncodeInfo rev _) -> deleteRevIndexList es rev _ -> return () + maxdsize <- readIORef maxDynamicTableSize + when (entrySize e <= maxdsize) $ insertFront e dyntbl +-- | Evicting entries until one of the given size fits, or the table is +-- empty. +evictFor :: Size -> DynamicTable -> IO [Entry] +evictFor siz dyntbl@DynamicTable{..} = evict [] + where + evict :: [Entry] -> IO [Entry] + evict es = do + n <- readIORef numOfEntries + dsize <- readIORef dynamicTableSize + maxdsize <- readIORef maxDynamicTableSize + if n == 0 || dsize + siz <= maxdsize + then return es + else do + e <- removeEnd dyntbl + evict (e : es) + insertFront :: Entry -> DynamicTable -> IO () insertFront e DynamicTable{..} = do maxN <- readIORef maxNumOfEntries @@ -344,19 +381,6 @@ case codeInfo of CIE (EncodeInfo rev _) -> insertRevIndex e (DIndex i) rev _ -> return () - -adjustTableSize :: DynamicTable -> IO [Entry] -adjustTableSize dyntbl@DynamicTable{..} = adjust [] - where - adjust :: [Entry] -> IO [Entry] - adjust es = do - dsize <- readIORef dynamicTableSize - maxdsize <- readIORef maxDynamicTableSize - if dsize <= maxdsize - then return es - else do - e <- removeEnd dyntbl - adjust (e : es) ---------------------------------------------------------------- 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 @@ -161,7 +161,25 @@ -- If the client terminated successfully, we ignore any other errors in the -- sender (indeed, any exception here might simply be that the background -- threads were cancelled /because/ the client terminated). - runAll = snd <$> concurrently runSender runClientReceiver + -- + -- If the sender terminates first, it failed, and no request can go out + -- any more: the client is stopped and the sender's error reported, rather + -- than the client left waiting on a connection nothing sends on. + runAll = + withAsync runSender $ \as -> + withAsync runClientReceiver $ \ac -> do + r <- waitEither as ac + case r of + Right x -> wait as >> return x + Left e -> do + -- The sender also finishes, normally, as soon as the + -- receiver is done and the queues are empty, and may + -- get there before the client side is seen to. Only + -- with the receiver still running did it fail. + done <- readTVarIO $ receiverDone ctx + case done of + Just _ -> wait ac + Nothing -> E.throwIO e makeStream :: Context @@ -198,12 +216,13 @@ req' = req{outObjHeaders = hdr2} -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit (_sid, newstrm) <- openOddStreamWait ctx + writeIORef (streamRequestMethod newstrm) $ Just method return (newstrm, Just req') sendRequest :: Config -> Context -> Stream -> OutObj -> Bool -> IO () sendRequest Config{..} ctx@Context{..} strm OutObj{..} io = do let sid = streamNumber strm - (mnext, mtbq) <- case outObjBody of + (mnext, mtbq) <- (`E.onException` abandon sid) $ case outObjBody of OutBodyNone -> return (Nothing, Nothing) OutBodyFile (FileSpec path fileoff bytecount) -> do (pread, sentinel) <- confPositionReadMaker path @@ -224,11 +243,11 @@ let ot = OHeader outObjHeaders mnext outObjTrailers if io then do - let out = makeOutputIO ctx strm ot - pushOutput sid out + let out = makeOutputIO ctx strm mtbq ot + pushOutput sid out `E.onException` abandon sid else do (pop, out) <- makeOutput strm ot - pushOutput sid out + pushOutput sid out `E.onException` abandon sid lc <- newLoopCheck strm mtbq T.forkManaged threadManager label $ syncWithSender' ctx pop lc where @@ -238,6 +257,22 @@ check (sidOK == sid) writeTVar outputQStreamID (sid + 2) enqueueOutputSTM outputQ out + -- The request failed before it was queued -- the file of a + -- 'requestFile' could not be opened, say, or the thread was killed while + -- waiting for its turn. Its stream id was taken but nothing went out on + -- it, and requests go out in stream id order: 'pushOutput' waits for + -- 'outputQStreamID' to reach its own id. Left as it was, that turn never + -- came, so every later request waited for ever, and the stream held its + -- concurrency slot. So the stream is taken out of the table, and a + -- thread passes its turn on once it arrives; the id goes unused, which a + -- later, higher one closes implicitly (RFC 9113, section 5.1.1). + abandon sid = do + closed ctx strm Killed + T.forkManaged threadManager ("H2 skipping stream " ++ show sid) $ + atomically $ do + sidOK <- readTVar outputQStreamID + check (sidOK == sid) + writeTVar outputQStreamID (sid + 2) sendStreaming :: Context 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 @@ -63,11 +63,7 @@ , peerSettings :: IORef Settings , oddStreamTable :: TVar OddStreamTable , evenStreamTable :: TVar EvenStreamTable - , continued :: IORef (Maybe StreamId) - -- ^ RFC 9113 says "Other frames (from any stream) MUST NOT - -- occur between the HEADERS frame and any CONTINUATION - -- frames that might follow". This field is used to implement - -- this requirement. + , continued :: IORef (Maybe HeaderContinuation) , myStreamId :: TVar StreamId , peerStreamId :: IORef StreamId , peerLastStreamId :: IORef StreamId @@ -98,6 +94,22 @@ } {- FOURMOLU_ENABLE -} +-- | Header/trailer continuation +-- +-- RFC 9113 says "Other frames (from any stream) MUST NOT occur between the +-- HEADERS frame and any CONTINUATION frames that might follow". This is used to +-- implement this requirement. +-- +-- It also accumulates the fragments of the block. These are connection-level +-- state: the block must be decoded even if its stream is reset before the +-- block is complete, since it may modify the dynamic table. +data HeaderContinuation = HeaderContinuation + { hcStreamId :: StreamId + , hcBlock :: PartialHeaderBlock + , hcEndOfStream :: Bool + -- ^ END_STREAM, from the HEADERS frame that started the block + } + ---------------------------------------------------------------- {- FOURMOLU_DISABLE -} @@ -195,8 +207,37 @@ setStreamState :: Context -> Stream -> StreamState -> IO () setStreamState _ Stream{streamNumber, streamState} newState = atomically $ do oldState <- readTVar streamState + informReplaced streamNumber oldState newState + writeTVar streamState newState - -- Inform consumers of any streams that we close +-- | Replacing the open state of a stream as the receiver moves it on, from +-- headers to body. +-- +-- The receiver reads a stream's state, works out the next one from the +-- frame, and writes it back -- in a transaction of its own. In between, the +-- sender may have half-closed the stream on our side ('halfClosedLocal', +-- which records it as @Open (Just cc) _@) or closed it. Writing the whole +-- state back undid that: the half-close was lost, the peer's END_STREAM then +-- took the stream to half-closed (remote) rather than closed, and it stayed +-- in the stream table, holding its concurrency slot for good. With both ends +-- streaming at once -- gRPC-style -- a client ran out of streams and a +-- server refused every new one. +-- +-- So only the open state is replaced, keeping whatever the sender recorded +-- about our side, and a stream that is no longer open is left alone. +setOpenState :: Context -> Stream -> OpenState -> IO () +setOpenState _ Stream{streamNumber, streamState} o = atomically $ do + oldState <- readTVar streamState + case oldState of + Open hcl _ -> do + let newState = Open hcl o + informReplaced streamNumber oldState newState + writeTVar streamState newState + _otherwise -> return () + +-- | Inform consumers of any streams that we close +informReplaced :: StreamId -> StreamState -> StreamState -> STM () +informReplaced streamNumber oldState newState = case (oldState, newState) of (Open _ (Body q _ _ _), Open _ (Body q' _ _ _)) | q == q' -> @@ -211,10 +252,20 @@ -- The stream wasn't open to start with; nothing to do return () - writeTVar streamState newState - +-- | Opening an idle stream. +-- +-- Only an idle one: the receiver checks that the stream is idle and then +-- opens it, and a client's request stream stays idle while the request is +-- being sent -- so by the time it opens the stream for the response's +-- HEADERS, the sender may already have half-closed it ('halfClosedLocal' +-- turns an idle stream into @Open (Just cc) JustOpened@). Opening it over +-- that lost the half-close, with the same result as described at +-- 'setOpenState'. opened :: Context -> Stream -> IO () -opened ctx strm = setStreamState ctx strm (Open Nothing JustOpened) +opened _ Stream{streamState} = atomically $ modifyTVar' streamState open + where + open Idle = Open Nothing JustOpened + open st = st halfClosedRemote :: Context -> Stream -> IO () halfClosedRemote ctx stream@Stream{streamState} = do 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 @@ -3,14 +3,20 @@ module Network.HTTP2.H2.HPACK ( hpackEncodeHeader, - hpackEncodeHeaderLoop, + hpackEncodeHeaderRest, hpackDecodeHeader, hpackDecodeTrailer, + hpackDiscardHeader, just, fixHeaders, ) where import qualified Control.Exception as E +import qualified Data.ByteString as BS +import Data.ByteString.Internal (create) +import qualified Data.ByteString.Lazy as BS.Lazy +import Foreign.Marshal.Alloc (free, mallocBytes) +import Foreign.Marshal.Utils (copyBytes) import Network.ByteOrder import Network.HTTP.Semantics import Network.HTTP.Types @@ -68,6 +74,29 @@ hpackEncodeHeaderLoop Context{..} buf siz hs = encodeTokenHeader buf siz strategy False encodeDynamicTable hs +-- | Encode the rest of a header block whose start 'hpackEncodeHeader' wrote +-- +-- For a block that did not fit where it was being written. Grows the buffer +-- as needed: a header that does not fit is retried with a larger buffer (the +-- encoder does not modify the dynamic table for a header it could not write). +hpackEncodeHeaderRest + :: Context + -> BufferSize + -- ^ Initial buffer size + -> TokenHeaderList + -> IO BS.Lazy.ByteString +hpackEncodeHeaderRest ctx = go [] + where + go acc _ [] = return $ BS.Lazy.fromChunks (reverse acc) + go acc siz ths = do + (chunk, ths') <- E.bracket (mallocBytes siz) free $ \buf -> do + (ths', len) <- hpackEncodeHeaderLoop ctx buf siz ths + chunk <- create len $ \p -> copyBytes p buf len + return (chunk, ths') + if BS.null chunk + then go acc (siz * 2) ths -- no progress: grow + else go (chunk : acc) siz ths' + ---------------------------------------------------------------- hpackDecodeHeader @@ -81,6 +110,12 @@ hpackDecodeTrailer :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable hpackDecodeTrailer = hpackDecode "illegal trailer" + +-- | Decode a field block for a stream we no longer have, and discard the result +-- +-- 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 -- | Decode a field block, reporting a block we could not get through as a -- connection error. 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 @@ -71,7 +71,7 @@ cancelAfterFinish :: Maybe SomeException -> STM () cancelAfterFinish mErr = - writeTQueue outputQ $ makeOutputIO ctx strm (OReset mErr) + writeTQueue outputQ $ makeOutputIO ctx strm Nothing (OReset mErr) iface :: OutBodyIface iface = 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 @@ -139,7 +139,7 @@ return bs controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO () -controlOrStream ctx@Context{..} conf ftyp header@FrameHeader{streamId, payloadLength} +controlOrStream ctx@Context{..} conf ftyp header@FrameHeader{flags, streamId, payloadLength} | isControl streamId = do bs <- readPayload conf payloadLength control ftyp header bs ctx @@ -152,27 +152,32 @@ -- before one was made -- so this resets by identifier alone. push header bs ctx `E.catch` resetPromised | otherwise = do - checkContinued + mcont <- checkContinued mstrm <- getStream ctx ftyp streamId bs <- readPayload conf payloadLength - case mstrm of - Just strm -> resettable strm $ do - state0 <- readStreamState strm - state <- stream ftyp header bs ctx state0 strm - resetContinued - set <- processState state ctx strm streamId - when set setContinued - Nothing - | ftyp == FramePriority -> do - -- for h2spec only - PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs - checkPriority newpri streamId - | ftyp == FrameData -> - -- Dropped, but still paid for. - informIgnoredData ctx streamId payloadLength - | otherwise -> return () + case mcont of + Just hc -> continuation hc bs mstrm + Nothing -> + case mstrm of + Just strm -> resettable strm $ do + state0 <- readStreamState strm + state <- stream ftyp header bs ctx state0 strm + processState state ctx strm streamId + Nothing + | ftyp == FramePriority -> do + -- for h2spec only + PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs + checkPriority newpri streamId + | ftyp == FrameData -> + -- Dropped, but still paid for. + informIgnoredData ctx streamId payloadLength + | ftyp == FrameHeaders -> do + HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs + if testEndHeader flags + then hpackDiscardHeader frag streamId ctx + else startHeaderBlock ctx streamId (testEndStream flags) frag + | otherwise -> return () where - setContinued = writeIORef continued $ Just streamId resetContinued = writeIORef continued Nothing resetPromised (StreamErrorIsSent err sid _msg) = enqueueControl controlQ $ CFrames Nothing [resetFrame err sid] @@ -190,31 +195,113 @@ resettable strm act = act `E.catch` reset where reset e@(StreamErrorIsSent err sid _msg) = do + -- MadeYouReset: CVE-2025-8671. A reset we send because of + -- what the peer sent frees the stream's concurrency slot just as + -- one the peer sends does, while a handler already launched for + -- the stream runs on. Counted with the peer's own resets, or a + -- peer that never sends RST_STREAM -- a PRIORITY on the stream + -- depending on itself is enough -- could keep any number of + -- handlers running past SETTINGS_MAX_CONCURRENT_STREAMS. + -- + -- REFUSED_STREAM is left out: it launches nothing, and it is the + -- answer section 8.7 means a peer to be able to retry. + when (err /= RefusedStream) $ do + rate <- getRate rstRate + when (rate > rstRateLimit mySettings) $ + E.throwIO $ + ConnectionErrorIsSent EnhanceYourCalm sid "too many stream errors" resetContinued -- 'closed' hands the exception to whoever is reading the stream -- and takes it out of the stream table. closed ctx strm $ ResetByMe $ E.toException e enqueueControl controlQ $ CFrames Nothing [resetFrame err sid] reset e = E.throwIO e + + checkContinued :: IO (Maybe HeaderContinuation) checkContinued = do mx <- readIORef continued case mx of Nothing -> return () - Just sid - | sid == streamId && ftyp == FrameContinuation -> return () + Just hc + | hcStreamId hc == streamId && ftyp == FrameContinuation -> return () | otherwise -> E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "continuation frame must follow" + return mx + continuation + :: HeaderContinuation -> HeaderBlockFragment -> Maybe Stream -> IO () + continuation hc frag mstrm + | frag == "" && not (testEndHeader flags) = do + -- Empty Frame Flooding - CVE-2019-9518 + rate <- getRate emptyFrameRate + when (rate > emptyFrameRateLimit mySettings) $ + E.throwIO $ + ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty continuation" + | otherwise = do + phb' <- addFragment streamId frag (hcBlock hc) + if testEndHeader flags + then completeBlock hc (completeHeaderBlock phb') mstrm + else writeIORef continued $ Just hc{hcBlock = phb'} + + completeBlock + :: HeaderContinuation -> HeaderBlockFragment -> Maybe Stream -> IO () + completeBlock hc blk mstrm = do + resetContinued + case mstrm of + Just strm -> resettable strm $ do + state0 <- readStreamState strm + case state0 of + Open hcl JustOpened -> do + 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 + processState state ctx strm streamId + _otherwise -> + -- The block began on a stream that was open for + -- headers or trailers, and the sender has since + -- closed it -- a reset crossing the block. There is + -- nothing to deliver, but the block still has to go + -- through the decoder, since it may have changed the + -- dynamic table. Handing it to 'stream' as a + -- CONTINUATION would get it refused as one that + -- cannot come here, closing the connection. + hpackDiscardHeader blk streamId ctx + Nothing -> + hpackDiscardHeader blk streamId ctx + +-- | Is this a response that is defined to have no content? +-- +-- RFC 9113, section 8.1.1: "A response that is defined to have no content, +-- as described in Section 6.4.1 of [HTTP], can have a non-zero +-- content-length header field, even though no content is included in DATA +-- frames." Those are the responses to HEAD, 204 and 304, and 2xx to +-- CONNECT; the content-length of one to HEAD, in particular, is that of the +-- content a GET would have had. Checking it against the content that +-- arrived made every such response to HEAD a stream error. +hasNoContent :: Context -> Stream -> ValueTable -> IO Bool +hasNoContent ctx Stream{streamRequestMethod} vt + | isServer ctx = return False + | otherwise = do + mmethod <- readIORef streamRequestMethod + let status = getFieldValue tokenStatus vt + return $ + mmethod == Just "HEAD" + || status `elem` [Just "204", Just "304"] + || (mmethod == Just "CONNECT" && maybe False ("2" `BS.isPrefixOf`) status) + ---------------------------------------------------------------- -processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool +processState :: StreamState -> Context -> Stream -> StreamId -> IO () -- Transition (process1) processState (Open _ (NoBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do -- My SETTINGS_MAX_CONCURRENT_STREAMS when (isServer ctx) $ checkOddConcurrency ctx streamId + noContent <- hasNoContent ctx strm reqvt let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) - when (just mcl (/= (0 :: Int))) $ + when (not noContent && just mcl (/= (0 :: Int))) $ E.throwIO $ StreamErrorIsSent ProtocolError @@ -228,18 +315,21 @@ launch ctx strm inpObj else putMVar streamInput $ Right inpObj halfClosedRemote ctx strm - return False -- Transition (process2) -processState (Open hcl (HasBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput, streamRxQ} _streamId = do +processState (Open _ (HasBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput, streamRxQ} _streamId = do -- My SETTINGS_MAX_CONCURRENT_STREAMS when (isServer ctx) $ checkOddConcurrency ctx _streamId - let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) + noContent <- hasNoContent ctx strm reqvt + let mcl + -- Its content-length describes content it does not have. + | noContent = Just 0 + | otherwise = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) bodyLength <- newIORef 0 tlr <- newIORef Nothing q <- newTQueueIO writeIORef streamRxQ $ Just q - setStreamState ctx strm $ Open hcl (Body q mcl bodyLength tlr) + setOpenState ctx strm $ Body q mcl bodyLength tlr -- FLOW CONTROL: WINDOW_UPDATE 0: recv: announcing my limit properly -- FLOW CONTROL: WINDOW_UPDATE: recv: announcing my limit properly bodySource <- mkSource q $ informWindowUpdate ctx strm @@ -249,28 +339,22 @@ let ServerInfo{..} = toServerInfo roleInfo launch ctx strm inpObj else putMVar streamInput $ Right inpObj - return False --- Transition (process3) -processState s@(Open _ Continued{}) ctx strm _streamId = do - setStreamState ctx strm s - return True - -- Transition (process4) processState HalfClosedRemote ctx strm _streamId = do halfClosedRemote ctx strm - return False -- Transition (process5) processState (Closed cc) ctx strm _streamId = do closed ctx strm cc - return False -- Transition (process6) +processState (Open _ o) ctx strm _streamId = + -- Open JustOpened, Open Body. Not the whole state: see 'setOpenState'. + setOpenState ctx strm o processState s ctx strm _streamId = do - -- Idle, Open Body, Closed + -- Idle setStreamState ctx strm s - return False ---------------------------------------------------------------- @@ -334,9 +418,21 @@ `BS.append` C8.pack (show ftyp) ) E.throwIO $ ConnectionErrorIsSent ProtocolError streamId errmsg - when (ftyp == FrameHeaders) $ setPeerStreamID ctx streamId - -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit - Just <$> openOddStreamCheck ctx streamId ftyp + if ftyp == FramePriority + then + -- PRIORITY does not open a stream (RFC 9113, section + -- 5.1): it is checked and dropped like one for a + -- stream we do not have. It used to create the + -- stream, taking a concurrency slot that nothing ever + -- gave back, since no HEADERS need follow: a peer + -- could fill SETTINGS_MAX_CONCURRENT_STREAMS with + -- PRIORITY frames alone and have every request after + -- them refused. + return Nothing + else do + setPeerStreamID ctx streamId + -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit + Just <$> openOddStreamCheck ctx streamId ftyp | otherwise = -- We received a frame from the server on an unknown stream -- (likely a previously created and then subsequently reset stream). @@ -495,26 +591,27 @@ tbl <- hpackDecodeHeader frag streamId ctx onResponseHeaders ctx streamId hcl endOfStream tbl else do - let siz = BS.length frag - return $ Open hcl $ Continued [frag] siz 1 endOfStream + startHeaderBlock ctx streamId endOfStream frag + return s -- Transition (stream2) -stream FrameHeaders header@FrameHeader{flags, streamId} bs ctx (Open _ (Body q _ _ tlr)) _ = do +stream FrameHeaders header@FrameHeader{flags, streamId} bs ctx s@(Open _ (Body q _ _ tlr)) _ = do HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs let endOfStream = testEndStream flags -- checking frag == "" is not necessary if endOfStream then do - tbl <- hpackDecodeTrailer frag streamId ctx - writeIORef tlr (Just tbl) - atomically $ writeTQueue q $ Right (mempty, True) - return HalfClosedRemote - else -- we don't support continuation here. + if testEndHeader flags + then onTrailers ctx streamId frag q tlr + else do + startHeaderBlock ctx streamId endOfStream frag + return s + else E.throwIO $ ConnectionErrorIsSent ProtocolError streamId - "continuation in trailer is not supported" + "trailers without END_STREAM" -- Transition (stream4) stream @@ -569,35 +666,6 @@ return HalfClosedRemote else return s --- Transition (stream5) -stream FrameContinuation FrameHeader{flags, streamId} frag ctx s@(Open hcl (Continued rfrags siz n endOfStream)) _ = do - let endOfHeader = testEndHeader flags - if frag == "" && not endOfHeader - then do - -- Empty Frame Flooding - CVE-2019-9518 - rate <- getRate $ emptyFrameRate ctx - if rate > emptyFrameRateLimit (mySettings ctx) - then - E.throwIO $ - ConnectionErrorIsSent EnhanceYourCalm streamId "too many empty continuation" - else return s - else do - let rfrags' = frag : rfrags - siz' = siz + BS.length frag - n' = n + 1 - when (siz' > headerFragmentLimit) $ - E.throwIO $ - ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too big" - when (n' > continuationLimit) $ - E.throwIO $ - ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too fragmented" - if endOfHeader - then do - let hdrblk = BS.concat $ reverse rfrags' - tbl <- hpackDecodeHeader hdrblk streamId ctx - onResponseHeaders ctx streamId hcl endOfStream tbl - else return $ Open hcl $ Continued rfrags' siz' n' endOfStream - -- (No state transition) stream FrameWindowUpdate header bs _ s strm = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs @@ -675,12 +743,6 @@ stream FrameContinuation FrameHeader{streamId} _ _ _ _ = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "continue frame cannot come here" -stream _ FrameHeader{streamId} _ _ (Open _ Continued{}) _ = - E.throwIO $ - ConnectionErrorIsSent - ProtocolError - streamId - "an illegal frame follows header/continuation frames" -- Ignore frames to streams we have just reset, per section 5.1. stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st stream FrameData FrameHeader{streamId} _ _ _ _ = @@ -774,3 +836,69 @@ sendPing Context{..} ack bs = enqueueControl controlQ $ CFrames Nothing [frame] where frame = pingFrame ack bs + +---------------------------------------------------------------- + +-- | Deliver a complete trailer block: the body ends with it. +onTrailers + :: Context + -> StreamId + -> HeaderBlockFragment + -> TQueue (Either E.SomeException (ByteString, Bool)) + -> IORef (Maybe TokenHeaderTable) + -> IO StreamState +onTrailers ctx streamId blk q tlr = do + tbl <- hpackDecodeTrailer blk streamId ctx + writeIORef tlr (Just tbl) + atomically $ writeTQueue q $ Right (mempty, True) + return HalfClosedRemote + +-- | Start accumulating a header block that does not fit in a single frame +startHeaderBlock + :: Context + -> StreamId + -> Bool + -- ^ END_STREAM, from the HEADERS frame + -> HeaderBlockFragment + -- ^ The fragment in the HEADERS frame + -> IO () +startHeaderBlock Context{continued} streamId endOfStream frag = + writeIORef continued . Just $ + HeaderContinuation + { hcStreamId = streamId + , hcBlock = newPartialHeaderBlock frag + , hcEndOfStream = endOfStream + } + +newPartialHeaderBlock :: HeaderBlockFragment -> PartialHeaderBlock +newPartialHeaderBlock frag = + PartialHeaderBlock + { phbFragments = [frag] + , phbTotalSize = BS.length frag + , phbNumFrames = 1 + } + +addFragment + :: StreamId + -- ^ Used for error messages only + -> HeaderBlockFragment + -> PartialHeaderBlock + -> IO PartialHeaderBlock +addFragment streamId frag phb = do + when (phbTotalSize phb' > headerFragmentLimit) $ + E.throwIO $ + ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too big" + when (phbNumFrames phb' > continuationLimit) $ + E.throwIO $ + ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too fragmented" + return phb' + where + phb' = + PartialHeaderBlock + { phbFragments = frag : phbFragments phb + , phbTotalSize = phbTotalSize phb + BS.length frag + , phbNumFrames = phbNumFrames phb + 1 + } + +completeHeaderBlock :: PartialHeaderBlock -> HeaderBlockFragment +completeHeaderBlock = BS.concat . reverse . phbFragments 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 @@ -10,9 +10,11 @@ import Control.Concurrent.STM import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.Lazy import Data.IORef (modifyIORef', readIORef, writeIORef) import Data.IntMap.Strict (IntMap) -import Foreign.Ptr (minusPtr, plusPtr) +import Foreign.Ptr (castPtr, minusPtr, plusPtr) import Network.ByteOrder import Network.HTTP.Semantics.Client import Network.HTTP.Semantics.IO @@ -56,7 +58,15 @@ where updateAllStreamTxFlow :: WindowSize -> IntMap Stream -> IO () updateAllStreamTxFlow siz strms = - forM_ strms $ \strm -> increaseStreamWindowSize strm siz + forM_ strms $ \strm -> increaseStreamWindowSize strm siz `E.catch` connectionError + -- RFC 9113, section 6.9.2: "An endpoint MUST treat a change to + -- SETTINGS_INITIAL_WINDOW_SIZE that causes any flow-control window to + -- exceed the maximum size as a connection error of type + -- FLOW_CONTROL_ERROR." The same overflow from a WINDOW_UPDATE is a stream + -- error, which is what 'increaseStreamWindowSize' raises. + connectionError (StreamErrorIsSent err sid msg) = + E.throwIO $ ConnectionErrorIsSent err sid msg + connectionError e = E.throwIO e checkDone :: Context -> Int -> IO (Maybe E.SomeException) checkDone Context{..} 0 = atomically $ do @@ -191,13 +201,31 @@ off' <- outputInformational strm hdr off sync Nothing return off' + OReset mErr -> do + resetStreamWith strm mErr + sync Nothing + return off _ -> do sws <- getStreamWindowSize strm cws <- getConnectionWindowSize ctx -- not 0 let lim = min cws sws - (off', mout') <- output out off lim - sync mout' - return off' + case otyp of + ONext{} + | lim <= 0 -> do + -- No room for any of the body: the + -- window was shut after this was queued + -- (a SETTINGS_INITIAL_WINDOW_SIZE + -- decrease, say). Filling a DATA frame + -- into no room reads 0 octets of a file, + -- which is taken for its end; handed back + -- instead, it is queued again once the + -- window opens. + sync $ Just out + return off + _ -> do + (off', mout') <- output out off lim + sync mout' + return off' ---------------------------------------------------------------- handler strm off e = do @@ -311,22 +339,31 @@ let offkv = off0 + frameHeaderLength bufkv = confWriteBuffer `plusPtr` offkv limkv = buflim - offkv - (ths, kvlen) <- hpackEncodeHeader ctx bufkv limkv ths0 - if kvlen == 0 - then continue off0 ths FrameHeaders + -- Most blocks fit where they are going: encode in place, which + -- is one HEADERS frame and no copying. + (rest, kvlen) <- hpackEncodeHeader ctx bufkv limkv ths0 + if null rest + then do + let buf = confWriteBuffer `plusPtr` off0 + fillFrameHeader FrameHeaders kvlen sid (getFlag FrameHeaders BS.Lazy.empty) buf + return $ offkv + kvlen else do - let flag = getFlag ths - buf = confWriteBuffer `plusPtr` off0 - off = offkv + kvlen - fillFrameHeader FrameHeaders kvlen sid flag buf - continue off ths FrameContinuation + -- It did not fit. What was written is the start of the + -- block, and the dynamic table has taken it into + -- account, so it is kept; the rest is encoded after it, + -- and the whole block then starts in a fresh buffer to + -- avoid emitting a tiny HEADERS frame. + start <- BS.packCStringLen (castPtr bufkv, kvlen) + ths1 <- hpackEncodeHeaderRest ctx (buflim - frameHeaderLength) rest + continue off0 (BS.Lazy.fromStrict start <> ths1) FrameHeaders where eos = if endOfStream then setEndStream else id - getFlag [] = eos $ setEndHeader defaultFlags - getFlag _ = eos defaultFlags + getFlag ft ths = + (if ft == FrameHeaders then eos else id) $ + if BS.Lazy.null ths then setEndHeader defaultFlags else defaultFlags - continue :: Offset -> TokenHeaderList -> FrameType -> IO Offset - continue off [] _ = return off + continue :: Offset -> BS.Lazy.ByteString -> FrameType -> IO Offset + continue off ths _ | BS.Lazy.null ths = return off continue off ths ft = do flushN off -- Now off is 0 @@ -335,14 +372,19 @@ headerPayloadLim = buflim - frameHeaderLength (ths', kvlen') <- - hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths - when (ths == ths') $ - E.throwIO $ - ConnectionErrorIsSent CompressionError sid "cannot compress the header" - let flag = getFlag ths' + copyFragment bufHeaderPayload headerPayloadLim ths + let flag = getFlag ft ths' off' = frameHeaderLength + kvlen' fillFrameHeader ft kvlen' sid flag confWriteBuffer continue off' ths' FrameContinuation + + -- Copy as much of the block as fits; return the rest and the number of bytes copied + copyFragment + :: Buffer -> Int -> BS.Lazy.ByteString -> IO (BS.Lazy.ByteString, Int) + copyFragment buf lim ths = do + let (frag, rest) = BS.Lazy.splitAt (fromIntegral (max 0 lim)) ths + _ <- foldM copy buf (BS.Lazy.toChunks frag) + return (rest, fromIntegral (BS.Lazy.length frag)) ---------------------------------------------------------------- fillDataHeader 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 @@ -29,7 +29,9 @@ , settingsRateLimit :: Int -- ^ Maximum number of settings frames allowed per second (CVE-2019-9515) , rstRateLimit :: Int - -- ^ Maximum number of reset frames allowed per second (CVE-2023-44487) + -- ^ Maximum number of streams reset per second, whether by the peer's + -- RST_STREAM (CVE-2023-44487) or by ours in answer to a stream error + -- the peer caused (CVE-2025-8671) } deriving (Eq, Show) 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 @@ -53,6 +53,7 @@ <*> newTVarIO (newTxFlow txwin) <*> newIORef (newRxFlow rxwin) <*> newIORef Nothing + <*> newIORef Nothing newEvenStream :: StreamId -> WindowSize -> WindowSize -> IO Stream newEvenStream sid txwin rxwin = @@ -61,6 +62,7 @@ <*> newEmptyMVar <*> newTVarIO (newTxFlow txwin) <*> newIORef (newRxFlow rxwin) + <*> newIORef Nothing <*> newIORef Nothing ---------------------------------------------------------------- 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 @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.H2.Sync ( @@ -16,6 +17,7 @@ import Control.Monad import Network.Control import Network.HTTP.Semantics.IO +import qualified System.ThreadManager as T import Network.HTTP2.H2.Context import Network.HTTP2.H2.Queue @@ -47,14 +49,32 @@ } return (pop, out) -makeOutputIO :: Context -> Stream -> OutputType -> Output -makeOutputIO Context{..} strm otyp = out +-- | An output for the 'runIO' interfaces, which have no thread waiting to +-- put the rest of a body back on the queue. +-- +-- The rest used to go back at once, whatever the stream's window. With +-- none left, the sender filled a DATA frame into no room; a file read into +-- no room reads 0 octets, which is the end of the file, so a body larger than +-- the window went out cut short with END_STREAM. A streaming body with +-- nothing queued made the sender spin instead. So the rest goes back once +-- it can go on, the way 'syncWithSender'' does it for the other interfaces; +-- only when it has to wait is a thread used for it. +makeOutputIO + :: Context -> Stream -> Maybe (TBQueue StreamingChunk) -> OutputType -> Output +makeOutputIO Context{..} strm mtbq otyp = out where push mout = case mout of Nothing -> return () - -- Sender enqueues output again ignoring - -- the stream TX window. - Just ot -> enqueueOutput outputQ ot + Just ot -> do + now <- atomically $ (Just <$> ready) `orElse` return Nothing + case now of + Just True -> enqueueOutput outputQ ot + Just False -> return () + Nothing -> + T.forkManaged threadManager "H2 output waiting for its window" $ do + ok <- atomically ready + when ok $ enqueueOutput outputQ ot + ready = readyToContinue strm mtbq out = Output { outputStream = strm @@ -62,9 +82,22 @@ , outputSync = push } +-- | Whether the rest of a stream's body can go on: waiting while the +-- stream's window is shut or a streaming body has nothing queued, and 'False' +-- once the stream is closed. +readyToContinue :: Stream -> Maybe (TBQueue StreamingChunk) -> STM Bool +readyToContinue Stream{streamState, streamTxFlow} mtbq = do + state <- readTVar streamState + case state of + Closed{} -> return False + _ -> do + waitStreaming' mtbq + waitStreamWindowSizeSTM streamTxFlow + return True + enqueueOutputSIO :: Context -> Stream -> OutputType -> IO () enqueueOutputSIO ctx@Context{..} strm otyp = do - let out = makeOutputIO ctx strm otyp + let out = makeOutputIO ctx strm Nothing otyp enqueueOutput outputQ out syncWithSender' :: Context -> IO Sync -> LoopCheck -> IO () 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 @@ -45,30 +45,15 @@ is labelled with the relevant case in either the function 'stream' or the function 'processState'. -> [Open JustOpened] -> | -> | -> HEADERS -> | -> | (stream1) -> | -> END_HEADERS? -> | -> ______/ \______ -> / yes no \ -> | | -> | [Open Continued] <--\ -> | | | -> | CONTINUATION | -> | | | -> | | (stream5) | -> | | | -> | END_HEADERS? | -> | | | -> v yes / \ no | -> END_STREAM? <-------/ \-----------/ -> | (process3) +> [Open JustOpened] > | +> | +> HEADERS CONTINUATION* +> | +> | (stream1) +> | +> END_STREAM? +> | > _________/ \_________ > / yes no \ > | | @@ -80,7 +65,7 @@ > | | | | > | | +---------------\ | > RST_STREAM | | | | -> | | HEADERS DATA | +> | | HEADERS CONT* DATA | > | (stream6) | | | | > | | | (stream2) | (stream4) | > | (process5) | | | | @@ -101,11 +86,6 @@ data OpenState = JustOpened - | Continued - [HeaderBlockFragment] - Int -- Total size - Int -- The number of continuation frames - Bool -- End of stream | NoBody TokenHeaderTable | HasBody TokenHeaderTable | Body @@ -115,6 +95,15 @@ (IORef Int) -- actual body length (IORef (Maybe TokenHeaderTable)) -- trailers +-- | Header block fragments accumulated so far. +-- +-- Fragments are stored in reverse order (newest first). +data PartialHeaderBlock = PartialHeaderBlock + { phbFragments :: [HeaderBlockFragment] + , phbTotalSize :: Int + , phbNumFrames :: Int + } + data ClosedCode = Finished | Killed @@ -163,6 +152,9 @@ , streamTxFlow :: TVar TxFlow , streamRxFlow :: IORef RxFlow , streamRxQ :: IORef (Maybe RxQ) + , 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) } instance Show Stream where 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 @@ -126,9 +126,22 @@ let mgr = threadManager ctx runReceiver = frameReceiver ctx conf runSender = frameSender ctx conf - runBackgroundThreads = do - e <- snd <$> concurrently runReceiver runSender - closureServer conf ctx e + runBackgroundThreads = + withAsync runReceiver $ \ar -> + withAsync runSender $ \as -> do + r <- waitEither ar as + e <- case r of + -- The receiver is done; the sender finishes once it + -- has flushed what is queued. + Left _ -> wait as + -- The sender finished first. Either the receiver is + -- done too and not yet seen to be, and this is its + -- error, or the sender failed: nothing more would go + -- out, and leaving the receiver to run on left the + -- connection open and silent, with no GOAWAY. Both + -- are closed with it. + Right e -> return e + closureServer conf ctx e T.stopAfter mgr runBackgroundThreads $ \res -> closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res 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 @@ -7,6 +7,7 @@ ) where import Control.Concurrent.STM +import qualified Control.Exception as E import Data.IORef import Network.HTTP.Semantics import Network.HTTP.Semantics.IO @@ -125,28 +126,48 @@ push _ [] n = return (n :: Int) push tvar (pp : pps) n = do T.forkManaged threadManager "H2 server push" $ do - (pid, newstrm) <- makePushStream ctx pstrm - let scheme = fromJust $ getFieldValue tokenScheme reqvt - -- fixme: this value can be Nothing - auth = - fromJust - ( getFieldValue tokenAuthority reqvt - <|> getFieldValue tokenHost reqvt - ) - path = promiseRequestPath pp - promiseRequest = - [ (tokenMethod, methodGet) - , (tokenScheme, scheme) - , (tokenAuthority, auth) - , (tokenPath, path) - ] - ot = OPush promiseRequest pid - Response rsp = promiseResponse pp - increment tvar - lc <- newLoopCheck newstrm Nothing - syncWithSender ctx newstrm ot lc + (newstrm, lc) <- promise pp `E.finally` increment tvar + 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 + -- counted. The PUSH_PROMISE has to go out before the parent's frames + -- (RFC 9113, section 8.4.1) -- before its END_STREAM above all, after + -- which a PUSH_PROMISE on it is a connection error. Counted before it + -- 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. + promise pp = do + (pid, newstrm) <- makePushStream ctx pstrm + let scheme = fromJust $ getFieldValue tokenScheme reqvt + -- fixme: this value can be Nothing + auth = + fromJust + ( getFieldValue tokenAuthority reqvt + <|> getFieldValue tokenHost reqvt + ) + path = promiseRequestPath pp + promiseRequest = + [ (tokenMethod, methodGet) + , (tokenScheme, scheme) + , (tokenAuthority, auth) + , (tokenPath, path) + ] + ot = OPush promiseRequest pid + lc <- newLoopCheck newstrm 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: + -- "half-closed (remote)" once the HEADERS go out), and the END_STREAM + -- of the pushed response closes the stream. Left reserved, that + -- END_STREAM only half-closed it: the stream stayed in the table + -- holding a slot of the peer's SETTINGS_MAX_CONCURRENT_STREAMS, and + -- once that many pushes had been made, the next waited for a slot + -- for ever, and so did the response it belonged to. + halfClosedRemote ctx newstrm + return (newstrm, lc) ---------------------------------------------------------------- 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.5 +version: 5.4.6 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -309,6 +309,7 @@ http-types, http2, network, + network-byte-order, network-run >= 0.6 && <0.7, random, typed-process diff --git a/test/HPACK/DecodeSpec.hs b/test/HPACK/DecodeSpec.hs --- a/test/HPACK/DecodeSpec.hs +++ b/test/HPACK/DecodeSpec.hs @@ -2,6 +2,9 @@ module HPACK.DecodeSpec where +import Control.Monad (forM_) +import qualified Data.ByteString as BS +import Data.String (fromString) import Network.HPACK import Network.HPACK.Table import Test.Hspec @@ -39,6 +42,56 @@ h1 `shouldBe` hl1 isDynamicTableEmpty etbl `shouldReturn` True isDynamicTableEmpty dtbl `shouldReturn` True + it "keeps the newest entry when a full table evicts" $ + -- A size update to 40 leaves room for one entry. Two literals + -- with incremental indexing, then index 62: the newest entry, + -- "b". Inserting before evicting used to write "b" over "a", + -- then evict the slot it had just written, so 62 came back as + -- a dummy entry. + withDynamicTableForDecoding 4096 4096 $ \dtbl -> do + let blk = + BS.pack + [ 0x3f + , 0x09 -- size update: 31 + 9 + , 0x40 + , 0x01 + , 0x61 + , 0x00 -- a: (incremental) + , 0x40 + , 0x01 + , 0x62 + , 0x00 -- b: (incremental) + , 0xbe -- indexed 62 + ] + decodeHeader dtbl blk `shouldReturn` [("a", ""), ("b", ""), ("b", "")] + 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 + -- SETTINGS_HEADER_TABLE_SIZE, so any of them can be asked for; + -- the encoder used to send index 61 of the static table + -- (www-authenticate) for an entry it had lost. + forM_ [33, 40, 63, 64, 100, 127, 1023] $ \siz -> + forM_ [False, True] $ \huff -> + withDynamicTableForEncoding siz $ \etbl -> + withDynamicTableForDecoding siz 4096 $ \dtbl -> + forM_ smallBlocks $ \hs -> do + let stgy = defaultEncodeStrategy{useHuffman = huff} + blk <- encodeHeader stgy 4096 etbl hs + decodeHeader dtbl blk `shouldReturn` hs + +-- | 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. +smallBlocks :: [[Header]] +smallBlocks = + concat $ + replicate 3 $ + [ [("aa", "x")] + , [("bb", "y")] + , [("aa", "x")] + , [("cc", ""), ("aa", "x")] + , [("dd", "z"), ("bb", "y"), ("cc", "")] + ] + ++ [[(fromString ('k' : show i), "v")] | i <- [0 .. 40 :: Int]] hl1 :: [Header] hl1 = diff --git a/test/HPACK/EncodeSpec.hs b/test/HPACK/EncodeSpec.hs --- a/test/HPACK/EncodeSpec.hs +++ b/test/HPACK/EncodeSpec.hs @@ -8,8 +8,12 @@ import qualified Control.Exception as E import Data.Bits import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 import Data.Maybe (fromMaybe) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +import Network.ByteOrder (withReadBuffer, withWriteBuffer) import Network.HPACK +import Network.HPACK.Internal (decodeH, decodeS, encodeS) import Test.Hspec spec :: Spec @@ -32,6 +36,17 @@ run (Just 0) EncodeStrategy{compressionAlgo = Linear, useHuffman = False} [] it "does not use indexed fields" $ do runNotIndexed EncodeStrategy{compressionAlgo = Linear, useHuffman = False} + describe "encodeS" $ do + it "round-trips a Huffman-coded string whose length needs four octets" $ do + -- 'a' is a five-bit code, so these come to 5/8 of their length + -- when Huffman-coded: 26416 is the first to need a four-octet + -- length with a 7-bit prefix. The fourth octet used to overwrite + -- the first octet of the code. + sequence_ + [ roundTripS n len + | n <- [3, 5, 7] + , len <- [100, 20000, 26415, 26416, 30000, 100000] + ] run :: Maybe Int -> EncodeStrategy -> [Int] -> Expectation run msz stgy lens0 = do @@ -101,3 +116,16 @@ linearLens :: [Int] linearLens = [250,312,26,390,288,204,224,204,200,202,204,204,206,206,228,100,204,204,218,208,228,434,208,608,232,208,208,208,98,202,208,256,168,208,208,224,208,208,382,84,242,208,208,232,208,208,208,210,210,210,210,208,210,222,208,210,400,224,238,206,206,230,252,222,202,202,198,138,250,204,216,204,204,108,96,306,250,242,208,94,226,206,264,222,40,224,810,204,38,266,144,158,254,100,206,110,132,38,254,144,102,132,102,102,102,102,102,210,230,208,204,464,224,142,198,198,410,156,250,218,130,18,26,338,284,238,222,36,142,208,92,34,552,152,206,1020,288,42,490,98,40,1884,434,300,240,206,278,278,268,252,460,632,178,220,298,144,430,746,724,202,330,144,204,206,782,146,206,206,146,240,228,204,206,208,300,144,160,146,146,38,280,220,144,146,100,144,418,206,204,294,144,300,228,204,204,146,144,240,204,244,218,230,286,102,256,202,208,206,144,146,206,836,204,842,300,220,326,182,300,148,150,204,144,144,98,146,204,206,146,100,204,222,202,202,166,268,146,40,38,142,38,206,418,318,226,174,256,246,274,208,208,208,208,208,544,254,146,146,144,268,160,572,362,178,224,590,362,3150,1034,316,402,204,228,206,206,40,146,142,266,158,142,354,380,264,702,74,424,674,410,688,322,250,300,204,188,60,298,204,206,468,230,200,232,222,208,210,272,282,252,218,724,144,238,206,208,210,100,254,146,144,124,38,112,204,204,216,168,208,276,100,206,116,100,326,892,194,102,210,102,210,206,40,126,102,100,208,98,242,206,218,278,282,292,234,144,40,144,202,288,206,98,40,146,148,40,116,850,242,38,40,40,148,204,110,290,162,662,212,218,230,100,100,134,100,1026,100,2442,100,100,100,208,100,100,112,100,164,144,100,100,100,110,100,518,202,232,342,728,46,384,204,230,100,398,100,208,114,102,290,208,246,324,782,296,280,796,636,268,84,74,246,34,38,284,612,1090,332,602,378,84,24,256,204,234,26,226,654,60,206,28,160,220,238,38,204,484,206,440,308,206,246,392,314,814,714,200,244,290,258,50,94,252,572,38,284,1050,286,24,252,24,728,46,400,390,330,214,740,368,244,38,252,32,244,252,246,36,94,22,638,296,206,304,32,34,246,240,20,306,340,28,276,226,814,638,278,40,226,50,38,34,42,630,552,252,84,244,252,240,20,198,346,284,290,202,240,300,206,102,214,204,210,430,210,208,144,252,210,240,208,304,224,208,100,354,102,210,764,102,240,210,208,208,102,208,102,208,208,100,102,208,210,100,100,154,268,222,286,256,260,92,642,232,208,262,204,146,100,260,226,146,72,206,38,98,394,1090,348,2602,112,102,490,526,312,486,366,368,368,368,368,674,46,462,202,220,210,516,906,154,384,300,280,206,102,102,102,102,102,102,102,626,102,160,88,226,50,248,34,36,632,308,1124,684,450,254,252,714,60] -} + +roundTripS :: Int -> Int -> Expectation +roundTripS n len = do + let bs = C8.replicate len 'a' + bufsiz = len * 4 + 64 + enc <- withWriteBuffer bufsiz $ \wbuf -> encodeS wbuf True id (`setBit` n) n bs + gcbuf <- mallocPlainForeignPtrBytes bufsiz + dec <- + withReadBuffer enc $ + decodeS (.&. mask) (`testBit` n) n (decodeH gcbuf bufsiz) + dec `shouldBe` bs + where + mask = (1 `shiftL` n) - 1 diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -3,6 +3,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +-- GHC 9.12 and later (still on master), with -O, compile 'responseInfinite' +-- to a response with no body: 'OutBodyNone' instead of 'OutBodyStreaming'. +-- Full laziness floats the constructor application to a top-level thunk, +-- and that thunk reaches code that switches on the pointer tag without +-- evaluating it: https://gitlab.haskell.org/ghc/ghc/-/work_items/27857 +-- The "infinite" stream then ends with its HEADERS, and the MadeYouReset +-- test sometimes sees a stream closed before its PRIORITY arrives (#191). +-- 9.10 and earlier are not affected. +{-# OPTIONS_GHC -fno-full-laziness #-} module HTTP2.ServerSpec (spec) where @@ -17,6 +26,7 @@ import Data.ByteString.Builder (Builder, byteString) import qualified Data.ByteString.Char8 as C8 import Data.IORef +import Data.Maybe (isJust, isNothing) import Network.HTTP.Semantics import Network.HTTP.Types import Network.Run.TCP @@ -46,6 +56,31 @@ spec :: Spec spec = do describe "server" $ do + it "sends a header block and trailers larger than a frame" $ + -- Both have to go out as HEADERS and CONTINUATION frames and be + -- put back together on receipt; the requests after them check + -- that the two ends' HPACK tables still agree. + 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 + sendRequest (C.requestNoBody methodGet "/big" []) $ \rsp -> do + getFieldValue (toToken "x-big") (snd (C.responseHeaders rsp)) + `shouldBe` Just bigVal + let drain = do + bs <- C.getResponseBodyChunk rsp + unless (B.null bs) drain + drain + mt <- C.getResponseTrailers rsp + (mt >>= getFieldValue (toToken "x-big-trailer") . snd) + `shouldBe` Just bigVal + -- Same connection: the HPACK state must still agree. + forM_ [1 :: Int, 2] $ \_ -> + sendRequest (C.requestNoBody methodGet "/" []) $ \rsp -> + C.responseStatus rsp `shouldBe` Just ok200 + r `shouldBe` Just () + it "handles normal cases" $ E.bracket (forkIO runServer) killThread $ \_ -> do threadDelay 10000 @@ -112,6 +147,157 @@ 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 @@ -135,6 +321,53 @@ (\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 @@ -200,15 +433,62 @@ [("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 @@ -227,6 +507,12 @@ ] 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 @@ -525,6 +811,136 @@ -- 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.