http2 5.4.5 → 5.4.6
raw patch · 19 files changed
+1154/−246 lines, 19 filesdep ~network-byte-orderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: network-byte-order
API changes (from Hackage documentation)
Files
- ChangeLog.md +58/−0
- Network/HPACK/HeaderBlock/Encode.hs +18/−44
- Network/HPACK/Table/Dynamic.hs +44/−20
- Network/HTTP2/Client/Run.hs +40/−5
- Network/HTTP2/H2/Context.hs +60/−9
- Network/HTTP2/H2/HPACK.hs +36/−1
- Network/HTTP2/H2/OutBodyIface.hs +1/−1
- Network/HTTP2/H2/Receiver.hs +212/−84
- Network/HTTP2/H2/Sender.hs +64/−22
- Network/HTTP2/H2/Settings.hs +3/−1
- Network/HTTP2/H2/Stream.hs +2/−0
- Network/HTTP2/H2/Sync.hs +39/−6
- Network/HTTP2/H2/Types.hs +21/−29
- Network/HTTP2/Server/Run.hs +16/−3
- Network/HTTP2/Server/Worker.hs +41/−20
- http2.cabal +2/−1
- test/HPACK/DecodeSpec.hs +53/−0
- test/HPACK/EncodeSpec.hs +28/−0
- test/HTTP2/ServerSpec.hs +416/−0
ChangeLog.md view
@@ -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
Network/HPACK/HeaderBlock/Encode.hs view
@@ -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)
Network/HPACK/Table/Dynamic.hs view
@@ -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) ----------------------------------------------------------------
Network/HTTP2/Client/Run.hs view
@@ -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
Network/HTTP2/H2/Context.hs view
@@ -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
Network/HTTP2/H2/HPACK.hs view
@@ -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.
Network/HTTP2/H2/OutBodyIface.hs view
@@ -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 =
Network/HTTP2/H2/Receiver.hs view
@@ -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
Network/HTTP2/H2/Sender.hs view
@@ -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
Network/HTTP2/H2/Settings.hs view
@@ -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)
Network/HTTP2/H2/Stream.hs view
@@ -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 ----------------------------------------------------------------
Network/HTTP2/H2/Sync.hs view
@@ -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 ()
Network/HTTP2/H2/Types.hs view
@@ -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
Network/HTTP2/Server/Run.hs view
@@ -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
Network/HTTP2/Server/Worker.hs view
@@ -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) ----------------------------------------------------------------
http2.cabal view
@@ -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 <kazu@iij.ad.jp>@@ -309,6 +309,7 @@ http-types, http2, network,+ network-byte-order, network-run >= 0.6 && <0.7, random, typed-process
test/HPACK/DecodeSpec.hs view
@@ -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 =
test/HPACK/EncodeSpec.hs view
@@ -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
test/HTTP2/ServerSpec.hs view
@@ -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", "</app.js>; rel=preload; as=script")] sendResponse responseHello [] Just "/stream" -> sendResponse responseInfinite []+ Just "/not-modified" -> sendResponse (responseNoBody notModified304 bigLength) []+ -- Says it has content, and has none: malformed.+ Just "/no-content" -> sendResponse (responseNoBody ok200 bigLength) []+ Just "/big" -> sendResponse responseBig [] Just "/push" -> do let pp = pushPromise "/push-pp" responsePP 0 sendResponse responseHello [pp] _ -> sendResponse response404 [] Just "POST" -> case requestPath req of Just "/echo" -> sendResponse (responseEcho req) []+ -- How many octets of body arrived.+ Just "/count" -> do+ let count n = do+ bs <- getRequestBodyChunk req+ if B.null bs then return n else count (n + B.length bs)+ n <- count (0 :: Int)+ sendResponse (responseBuilder ok200 [] (byteString (C8.pack (show n)))) []+ Just "/both" -> do+ -- Read the body on the side, so that the response does not+ -- wait for it.+ _ <-+ forkIO $+ let d = getRequestBodyChunk req >>= \bs -> unless (B.null bs) d+ in d+ sendResponse responseBoth [] _ -> sendResponse responseHello []+ Just "HEAD" -> case requestPath req of+ -- HEADERS, then an empty DATA frame with END_STREAM.+ Just "/data" -> sendResponse (responseBuilder ok200 bigLength mempty) []+ -- HEADERS with END_STREAM.+ _ -> sendResponse (responseNoBody ok200 bigLength) [] _ -> sendResponse response405 [] +-- | Larger than the default frame size and than the server's 32K buffer.+bigVal :: ByteString+bigVal = C8.replicate 40000 'x'++responseBig :: Response+responseBig = setResponseTrailersMaker rsp maker+ where+ rsp = responseBuilder ok200 [("x-big", bigVal)] "hello"+ maker Nothing = return $ Trailers [("x-big-trailer", bigVal)]+ maker (Just _) = return $ NextTrailersMaker maker++-- | The stream error a client raises for a malformed response, as+-- 'sendRequest' hands it on.+malformedResponse :: C.HTTP2Error -> Bool+malformedResponse (C.StreamErrorIsSent C.ProtocolError _ _) = True+malformedResponse (C.BadThingHappen se) =+ maybe False malformedResponse $ E.fromException se+malformedResponse _ = False++-- | The content-length of content that is not there.+bigLength :: ResponseHeaders+bigLength = [("content-length", "1234")]+ responseHello :: Response responseHello = responseBuilder ok200 header body where@@ -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.