http2 5.4.4 → 5.4.5
raw patch · 16 files changed
+702/−108 lines, 16 filesdep ~network-runPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: network-run
API changes (from Hackage documentation)
+ Network.HPACK: TooLargeInteger :: DecodeError
+ Network.HPACK.Internal: integerLimit :: Int
Files
- ChangeLog.md +39/−0
- Network/HPACK/HeaderBlock/Integer.hs +36/−6
- Network/HPACK/Types.hs +3/−0
- Network/HTTP2/Frame/Decode.hs +101/−37
- Network/HTTP2/H2/Context.hs +24/−4
- Network/HTTP2/H2/HPACK.hs +29/−4
- Network/HTTP2/H2/Receiver.hs +87/−31
- Network/HTTP2/H2/Sender.hs +26/−9
- Network/HTTP2/H2/StreamTable.hs +22/−8
- Network/HTTP2/H2/Types.hs +6/−2
- Network/HTTP2/H2/Window.hs +23/−0
- http2.cabal +5/−5
- test/HPACK/IntegerSpec.hs +32/−0
- test/HTTP2/ClientSpec.hs +8/−2
- test/HTTP2/FrameSpec.hs +55/−0
- test/HTTP2/ServerSpec.hs +206/−0
ChangeLog.md view
@@ -1,5 +1,44 @@ # ChangeLog for http2 +## 5.4.5++* Security: frame payload decoders read their fixed-size fields without+ checking that the payload holds them, so a truncated frame, or padding+ covering a field, read past the end of the buffer -- and an empty payload+ is the shared empty `ByteString`, whose pointer is null. An+ unauthenticated peer could segfault the process with 33 bytes.+ [#182](https://github.com/kazu-yamamoto/http2/pull/182)+* Security: HPACK integer decoding overflowed `Int` silently, so a long+ enough encoding decoded to whatever value the sender aimed at and two+ different byte strings could decode to the same header. Integers are now+ bounded and over-long encodings are a decoding error, as RFC 7541+ section 5.1 requires.+ [#181](https://github.com/kazu-yamamoto/http2/pull/181)+* A RST_STREAM gave a stream's concurrency slot back twice, so a peer could+ walk `SETTINGS_MAX_CONCURRENT_STREAMS` upwards and hold open as many+ streams as it liked.+ [#178](https://github.com/kazu-yamamoto/http2/pull/178)+* A stream reset while its response was still being produced left the+ worker blocked until the timeout manager killed it, one thread per reset+ stream.+ [#179](https://github.com/kazu-yamamoto/http2/pull/179)+* Stream errors now reset the stream and the connection carries on, as+ RFC 9113 section 5.4.2 requires. A field block abandoned part-way is+ still a connection error, since the HPACK tables have diverged by then.+ [#183](https://github.com/kazu-yamamoto/http2/pull/183)+* A stream over `SETTINGS_MAX_CONCURRENT_STREAMS` is refused with+ RST_STREAM(REFUSED_STREAM) rather than ending the connection.+ [#184](https://github.com/kazu-yamamoto/http2/pull/184)+* `DecodeError` has a new constructor, `TooLargeInteger`. Strictly this is+ a breaking change -- an exhaustive match on `DecodeError` no longer+ compiles -- but it ships as a patch version on purpose: no package on+ Hackage names any constructor of that type, while a minor bump would+ shut out every dependant carrying a `< 5.5` bound, these security fixes+ along with it.+* A malformed request now reaches a client as `StreamResetIsReceived` on+ the stream it concerns, where it used to arrive as+ `ConnectionErrorIsReceived` on the connection.+ ## 5.4.4 * Improvements for dealing with RST_STREAM
Network/HPACK/HeaderBlock/Integer.hs view
@@ -3,13 +3,16 @@ encodeInteger, decodeI, decodeInteger,+ integerLimit, ) where +import qualified Control.Exception as E import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.ByteOrder import Imports+import Network.HPACK.Types (DecodeError (..)) -- $setup -- >>> import qualified Data.ByteString as BS@@ -127,9 +130,36 @@ p = powerArray `unsafeAt` (n - 1) i = fromIntegral w decode :: Int -> Int -> IO Int- decode m j = do- b <- fromIntegral <$> read8 rbuf- let j' = j + (b .&. 0x7f) * 2 ^ m- m' = m + 7- cont = b `testBit` 7- if cont then decode m' j' else return j'+ decode m j+ -- Checked before the shift rather than after: shifting an 'Int' by a+ -- word width or more is not defined to give zero, and the value would+ -- have wrapped long before there were anything to notice.+ | m > maxShift = E.throwIO TooLargeInteger+ | otherwise = do+ b <- fromIntegral <$> read8 rbuf+ let d = b .&. 0x7f+ -- d * 2^m > integerLimit - j, without evaluating the product.+ when (d > (integerLimit - j) `shiftR` m) $ E.throwIO TooLargeInteger+ let j' = j + (d `shiftL` m)+ if b `testBit` 7 then decode (m + 7) j' else return j'++-- | The largest integer 'decodeI' will return.+--+-- HPACK's integer encoding carries no bound of its own, so a decoder has to+-- impose one. RFC 7541, section 5.1: "Integer encodings that exceed+-- implementation limits -- in value or octet length -- MUST be treated as+-- decoding errors."+--+-- 2^30 - 1 is far above anything HTTP\/2 can ask for -- a frame payload is at+-- most 2^24 - 1 octets, so no length or index comes near it -- and it still+-- fits in an 'Int' on a platform where that is 32 bits wide.+--+-- >>> integerLimit+-- 1073741823+integerLimit :: Int+integerLimit = 1073741823++-- | The largest shift that can carry a continuation octet into+-- 'integerLimit'; past it every further octet is an overflow.+maxShift :: Int+maxShift = 28
Network/HPACK/Types.hs view
@@ -76,6 +76,9 @@ IllegalEos | -- | Eos of huffman string is more than 7 bits TooLongEos+ | -- | An integer is encoded above the limit this decoder accepts,+ -- or in more octets than reaching that limit can take+ TooLargeInteger | -- | A peer set the dynamic table size less than 32 TooSmallTableSize | -- | A peer tried to change the dynamic table size over the limit
Network/HTTP2/Frame/Decode.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -92,6 +93,10 @@ Left $ FrameDecodeError ProtocolError streamId "cannot used in non-zero stream" | otherwise = checkType typ where+ checkType FrameData+ | testPadded flags && payloadLength < 1 =+ Left $+ FrameDecodeError FrameSizeError streamId "insufficient payload for Pad Length" checkType FrameHeaders | testPadded flags && payloadLength < 1 = Left $@@ -142,6 +147,18 @@ ProtocolError streamId "push promise must be used with an odd stream identifier"+ | testPadded flags && payloadLength < 5 =+ Left $+ FrameDecodeError+ FrameSizeError+ streamId+ "insufficient payload for Pad Length and promised stream id"+ | not (testPadded flags) && payloadLength < 4 =+ Left $+ FrameDecodeError+ FrameSizeError+ streamId+ "insufficient payload for promised stream id" checkType FramePing | payloadLength /= 8 = Left $@@ -206,39 +223,52 @@ decodeFramePayload :: FrameType -> FramePayloadDecoder decodeFramePayload ftyp | ftyp > maxFrameType = checkFrameSize $ decodeUnknownFrame ftyp-decodeFramePayload ftyp = checkFrameSize decoder- where- decoder = payloadDecoders ! ftyp+decodeFramePayload ftyp = payloadDecoders ! ftyp -- each one checks its own size ---------------------------------------------------------------- -- | Frame payload decoder for DATA frame. decodeDataFrame :: FramePayloadDecoder-decodeDataFrame header _bs = decodeWithPadding header _bs DataFrame+decodeDataFrame = checkFrameSize $ \header bs ->+ decodeWithPadding header bs $ Right . DataFrame -- | Frame payload decoder for HEADERS frame. decodeHeadersFrame :: FramePayloadDecoder-decodeHeadersFrame header _bs = decodeWithPadding header _bs $ \bs' ->- if hasPriority- then- let (bs0, bs1) = BS.splitAt 5 bs'- p = priority bs0- in HeadersFrame (Just p) bs1- else HeadersFrame Nothing bs'- where- hasPriority = testPriority $ flags header+decodeHeadersFrame = checkFrameSize $ \header@FrameHeader{streamId} bs ->+ decodeWithPadding header bs $ \bs' ->+ if testPriority $ flags header+ then+ -- The header check knows the payload is long enough to hold+ -- the priority fields, but not that the padding leaves them+ -- there: Pad Length may cover the lot.+ if BS.length bs' < 5+ then+ Left $+ FrameDecodeError+ FrameSizeError+ streamId+ "no room for priority fields"+ else+ let (bs0, bs1) = BS.splitAt 5 bs'+ in Right $ HeadersFrame (Just (priority bs0)) bs1+ else Right $ HeadersFrame Nothing bs' -- | Frame payload decoder for PRIORITY frame. decodePriorityFrame :: FramePayloadDecoder-decodePriorityFrame _ bs = Right $ PriorityFrame $ priority bs+decodePriorityFrame = checkFrameSize $ requireBytes 5 $ \_ bs ->+ Right $ PriorityFrame $ priority bs -- | Frame payload decoder for RST_STREAM frame. decodeRSTStreamFrame :: FramePayloadDecoder-decodeRSTStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCode $ N.word32 bs+decodeRSTStreamFrame = checkFrameSize $ requireBytes 4 $ \_ bs ->+ Right $ RSTStreamFrame $ toErrorCode $ N.word32 bs -- | Frame payload decoder for SETTINGS frame. decodeSettingsFrame :: FramePayloadDecoder-decodeSettingsFrame FrameHeader{..} (PS fptr off _)+decodeSettingsFrame = checkFrameSize decodeSettingsFrame'++decodeSettingsFrame' :: FramePayloadDecoder+decodeSettingsFrame' FrameHeader{..} (PS fptr off _) | num > 10 = Left $ FrameDecodeError EnhanceYourCalm streamId "Settings is too large" | otherwise = Right $ SettingsFrame alist@@ -258,20 +288,31 @@ -- | Frame payload decoder for PUSH_PROMISE frame. decodePushPromiseFrame :: FramePayloadDecoder-decodePushPromiseFrame header _bs = decodeWithPadding header _bs $ \bs' ->- let (bs0, bs1) = BS.splitAt 4 bs'- sid = streamIdentifier (N.word32 bs0)- in PushPromiseFrame sid bs1+decodePushPromiseFrame = checkFrameSize $ \header@FrameHeader{streamId} bs ->+ decodeWithPadding header bs $ \bs' ->+ -- As in HEADERS: the padding may cover the promised stream id.+ if BS.length bs' < 4+ then+ Left $+ FrameDecodeError+ FrameSizeError+ streamId+ "no room for the promised stream id"+ else+ let (bs0, bs1) = BS.splitAt 4 bs'+ sid = streamIdentifier (N.word32 bs0)+ in Right $ PushPromiseFrame sid bs1 -- | Frame payload decoder for PING frame. decodePingFrame :: FramePayloadDecoder-decodePingFrame _ _bs = Right $ PingFrame bs- where- bs = BS.copy _bs+decodePingFrame = checkFrameSize $ \_ _bs -> Right $ PingFrame $ BS.copy _bs -- | Frame payload decoder for GOAWAY frame. decodeGoAwayFrame :: FramePayloadDecoder-decodeGoAwayFrame _ _bs = Right $ GoAwayFrame sid ecid bs2+decodeGoAwayFrame = checkFrameSize $ requireBytes 8 decodeGoAwayFrame'++decodeGoAwayFrame' :: FramePayloadDecoder+decodeGoAwayFrame' _ _bs = Right $ GoAwayFrame sid ecid bs2 where bs = BS.copy _bs (bs0, bs1') = BS.splitAt 4 bs@@ -281,7 +322,10 @@ -- | Frame payload decoder for WINDOW_UPDATE frame. decodeWindowUpdateFrame :: FramePayloadDecoder-decodeWindowUpdateFrame FrameHeader{..} bs+decodeWindowUpdateFrame = checkFrameSize $ requireBytes 4 decodeWindowUpdateFrame'++decodeWindowUpdateFrame' :: FramePayloadDecoder+decodeWindowUpdateFrame' FrameHeader{..} bs | wsi == 0 = Left $ FrameDecodeError ProtocolError streamId "window update must not be 0" | otherwise = Right $ WindowUpdateFrame wsi@@ -290,9 +334,7 @@ -- | Frame payload decoder for CONTINUATION frame. decodeContinuationFrame :: FramePayloadDecoder-decodeContinuationFrame _ _bs = Right $ ContinuationFrame bs- where- bs = BS.copy _bs+decodeContinuationFrame = checkFrameSize $ \_ _bs -> Right $ ContinuationFrame $ BS.copy _bs decodeUnknownFrame :: FrameType -> FramePayloadDecoder decodeUnknownFrame typ _ _bs = Right $ UnknownFrame typ bs@@ -307,6 +349,22 @@ Left $ FrameDecodeError FrameSizeError streamId "payload is too short" | otherwise = func header body +-- | Require the payload to actually hold the fixed fields about to be read+-- from it.+--+-- The reads below sit at fixed offsets and never consult the length of the+-- 'ByteString' they read from, so a payload shorter than the field runs off+-- the end of the buffer -- and an empty one is the shared empty+-- 'ByteString', whose pointer is null. 'checkFrameHeader' pins these lengths+-- down, but it is a separate function that a caller of the decoders is free+-- not to have used, and 'checkFrameSize' only compares the payload against+-- the length the frame header claims, which may itself be wrong.+requireBytes :: Int -> FramePayloadDecoder -> FramePayloadDecoder+requireBytes n func header@FrameHeader{streamId} body+ | BS.length body < n =+ Left $ FrameDecodeError FrameSizeError streamId "payload is too short"+ | otherwise = func header body+ -- | Helper function to pull off the padding if its there, and will -- eat up the trailing padding automatically. Calls the decoder func -- passed in with the length of the unpadded portion between the@@ -314,17 +372,23 @@ decodeWithPadding :: FrameHeader -> ByteString- -> (ByteString -> FramePayload)+ -> (ByteString -> Either FrameDecodeError FramePayload) -> Either FrameDecodeError FramePayload decodeWithPadding FrameHeader{..} bs body- | padded =- let (w8, rest) = fromMaybe (error "decodeWithPadding") $ BS.uncons bs'- padlen = intFromWord8 w8- bodylen = payloadLength - padlen - 1- in if bodylen < 0- then Left $ FrameDecodeError ProtocolError streamId "padding is not enough"- else Right . body $ BS.take bodylen rest- | otherwise = Right $ body bs'+ | padded = case BS.uncons bs' of+ -- The header checks rule this out for every frame type that can be+ -- padded, but the type does not, and the reply to a payload with no+ -- room for its Pad Length is an error, never a crash.+ Nothing ->+ Left $+ FrameDecodeError FrameSizeError streamId "insufficient payload for Pad Length"+ Just (w8, rest)+ | bodylen < 0 ->+ Left $ FrameDecodeError ProtocolError streamId "padding is not enough"+ | otherwise -> body $ BS.take bodylen rest+ where+ bodylen = payloadLength - intFromWord8 w8 - 1+ | otherwise = body bs' where bs' = BS.copy bs padded = testPadded flags
Network/HTTP2/H2/Context.hs view
@@ -252,12 +252,13 @@ -- From peer -- Server+--+-- Note that this does not apply SETTINGS_MAX_CONCURRENT_STREAMS. A stream+-- over the limit still has to be admitted this far, because its field block+-- has to be decoded before it can be refused; 'checkOddConcurrency' does the+-- refusing once that has happened. openOddStreamCheck :: Context -> StreamId -> FrameType -> IO Stream openOddStreamCheck ctx@Context{oddStreamTable, peerSettings, mySettings} sid ftyp = do- -- My SETTINGS_MAX_CONCURRENT_STREAMS- when (ftyp == FrameHeaders) $ do- conc <- getOddConcurrency oddStreamTable- checkMyConcurrency sid mySettings (conc + 1) txws <- initialWindowSize <$> readIORef peerSettings let rxws = initialWindowSize mySettings newstrm <- newOddStream sid txws rxws@@ -275,6 +276,25 @@ let rxws = initialWindowSize mySettings newstrm <- newEvenStream sid txws rxws insertEvenCache evenStreamTable method path newstrm++-- | Refuse a peer-initiated stream that puts us over the limit we advertised+-- in SETTINGS_MAX_CONCURRENT_STREAMS.+--+-- Checked once the stream's field block has been decoded, rather than when+-- its HEADERS frame arrived. A block has to be decoded whatever becomes of+-- its stream -- RFC 9113 section 10.5.1, "The field block MUST be processed+-- to ensure a consistent connection state" -- and refusing at arrival meant+-- throwing before the frame's payload had even been read, which left nothing+-- to do but drop the connection. From here the throw lands inside the+-- receiver's per-frame reset handler, so the answer is+-- RST_STREAM(REFUSED_STREAM) and the connection carries on, which is what+-- section 5.1.2 asks for and what section 8.7 lets the peer retry against.+--+-- The stream is in the table by the time we get here, so it counts itself.+checkOddConcurrency :: Context -> StreamId -> IO ()+checkOddConcurrency Context{oddStreamTable, mySettings} sid = do+ conc <- getOddConcurrency oddStreamTable+ checkMyConcurrency sid mySettings conc checkMyConcurrency :: StreamId -> Settings -> Int -> IO ()
Network/HTTP2/H2/HPACK.hs view
@@ -73,20 +73,45 @@ hpackDecodeHeader :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable hpackDecodeHeader hdrblk sid ctx = do- tbl@(_, vt) <- hpackDecodeTrailer hdrblk sid ctx+ tbl@(_, vt) <- hpackDecode "illegal header" hdrblk sid ctx if isClient ctx || checkRequestHeader vt then return tbl else E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal header" hpackDecodeTrailer :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable-hpackDecodeTrailer hdrblk sid Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl+hpackDecodeTrailer = hpackDecode "illegal trailer"++-- | Decode a field block, reporting a block we could not get through as a+-- connection error.+--+-- The first argument says which kind of block it was, since the peer reads+-- this in the GOAWAY and "illegal trailer" about a request's headers is a+-- confusing thing to be told.+hpackDecode+ :: ReasonPhrase+ -> HeaderBlockFragment+ -> StreamId+ -> Context+ -> IO TokenHeaderTable+hpackDecode illegal hdrblk sid Context{..} =+ decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl where+ -- Connection errors, both of them, even though a malformed message is a+ -- stream error by RFC 9113 section 8.1.1. Either way the field block was+ -- abandoned part-way through, so our dynamic table now holds the entries+ -- decoded before the throw and nothing after them -- no longer what the+ -- peer's encoder believes we have. Section 10.5.1: "The field block MUST+ -- be processed to ensure a consistent connection state, unless the+ -- connection is closed." We did not, so it must be.+ --+ -- A malformed message caught /after/ a complete decode is a different+ -- matter, and 'hpackDecodeHeader' reports those as stream errors. handl IllegalHeaderName =- E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal trailer"+ E.throwIO $ ConnectionErrorIsSent ProtocolError sid illegal handl e = do let msg = fromString $ show e- E.throwIO $ StreamErrorIsSent CompressionError sid msg+ E.throwIO $ ConnectionErrorIsSent CompressionError sid msg {-# INLINE checkRequestHeader #-} checkRequestHeader :: ValueTable -> Bool
Network/HTTP2/H2/Receiver.hs view
@@ -50,11 +50,12 @@ frameReceiver :: Context -> Config -> IO E.SomeException frameReceiver ctx@Context{receiverDone} conf@Config{..} = E.mask $ \unmask -> do+ -- This catches an asynchronous exception.+ -- It is re-thrown by "runH2" mErr <- E.try $ unmask switch case mErr of Left err -> do atomically $ writeTVar receiverDone $ Just err- -- err is re-thrown by "runH2" return err Right x -> do absurd x -- We only terminate due to exceptions@@ -99,13 +100,13 @@ | isServer ctx = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "push promise is not allowed"-processFrame Context{..} Config{..} (ftyp, FrameHeader{payloadLength, streamId})+processFrame Context{..} conf (ftyp, FrameHeader{payloadLength, streamId}) | ftyp > maxFrameType = do mx <- readIORef continued case mx of Nothing -> do -- ignoring unknown frame- void $ confReadN payloadLength+ void $ readPayload conf payloadLength Just _ -> E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "unknown frame" processFrame ctx@Context{..} conf typhdr@(ftyp, header) = do -- My SETTINGS_MAX_FRAME_SIZE@@ -125,20 +126,37 @@ ---------------------------------------------------------------- +-- | Read a frame payload in full.+--+-- 'confReadN' answers with an empty string at end of input, so a payload that+-- comes back short means the peer hung up in the middle of the frame. Saying+-- so here keeps every decoder below from being handed fewer bytes than the+-- frame header promised it.+readPayload :: Config -> Int -> IO ByteString+readPayload Config{..} len = do+ bs <- confReadN len+ when (BS.length bs /= len) $ E.throwIO ConnectionIsClosed+ return bs+ controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO ()-controlOrStream ctx@Context{..} Config{..} ftyp header@FrameHeader{streamId, payloadLength}+controlOrStream ctx@Context{..} conf ftyp header@FrameHeader{streamId, payloadLength} | isControl streamId = do- bs <- confReadN payloadLength+ bs <- readPayload conf payloadLength control ftyp header bs ctx | ftyp == FramePushPromise = do- bs <- confReadN payloadLength- push header bs ctx+ bs <- readPayload conf payloadLength+ -- A promised stream can be refused over concurrency too, and by the+ -- time 'push' gets that far it has decoded the field block, so the+ -- same reasoning as 'resettable' applies: reset the promised stream+ -- and read on. There is no 'Stream' to close -- it was refused+ -- before one was made -- so this resets by identifier alone.+ push header bs ctx `E.catch` resetPromised | otherwise = do checkContinued mstrm <- getStream ctx ftyp streamId- bs <- confReadN payloadLength+ bs <- readPayload conf payloadLength case mstrm of- Just strm -> do+ Just strm -> resettable strm $ do state0 <- readStreamState strm state <- stream ftyp header bs ctx state0 strm resetContinued@@ -149,10 +167,35 @@ -- 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 () where setContinued = writeIORef continued $ Just streamId resetContinued = writeIORef continued Nothing+ resetPromised (StreamErrorIsSent err sid _msg) =+ enqueueControl controlQ $ CFrames Nothing [resetFrame err sid]+ resetPromised e = E.throwIO e+ -- Answer a stream error by resetting that stream and reading on, which is+ -- what RFC 9113 section 5.4.2 asks for: "an error related to a specific+ -- stream that does not affect processing of other streams".+ --+ -- Safe only here, after the payload has been read and any field block in+ -- it decoded, so that the connection sits at a frame boundary and the+ -- HPACK tables still agree with the peer's. Where neither holds -- a+ -- field block abandoned part-way, a stream refused before its payload was+ -- read -- the error is raised as a connection error where it is detected,+ -- and travels straight past this handler.+ resettable strm act = act `E.catch` reset+ where+ reset e@(StreamErrorIsSent err sid _msg) = do+ 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 = do mx <- readIORef continued case mx of@@ -168,6 +211,8 @@ processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool -- 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 let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) when (just mcl (/= (0 :: Int))) $ E.throwIO $@@ -187,6 +232,8 @@ -- Transition (process2) processState (Open hcl (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) bodyLength <- newIORef 0 tlr <- newIORef Nothing@@ -263,7 +310,14 @@ csid <- getPeerStreamID ctx if streamId <= csid -- consider the stream closed then- if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority]+ -- RFC 9113 section 5.1: "An endpoint MUST ignore frames that+ -- it receives on closed streams after it has sent a+ -- RST_STREAM frame." DATA is in that list because resetting a+ -- stream mid-body leaves whatever the peer already put on the+ -- wire still to arrive. HEADERS is not: that would be reuse+ -- of a stream identifier, which section 5.1.1 makes a+ -- connection error.+ if ftyp `elem` [FrameData, FrameWindowUpdate, FrameRSTStream, FramePriority] then return Nothing -- will be ignored else E.throwIO $@@ -583,19 +637,32 @@ -- > Either endpoint can send a RST_STREAM frame from this state, causing it -- > to transition immediately to "closed". --- -- This justifies the two non-error cases, below. (Section 8.1 of the spec+ -- This justifies the non-error cases, below. (Section 8.1 of the spec -- is also relevant, but it is less explicit about the /either endpoint/ -- part.)+ --+ -- The error code the peer sent does not enter into it. Receiving a+ -- RST_STREAM closes that stream and nothing else, whatever the reason+ -- given; the code is for whoever is reading the stream, and reaches them+ -- as 'StreamResetIsReceived' by way of 'closed' above. Ending the whole+ -- connection over it would punish every other stream on the connection+ -- for a peer's complaint about one. case s of- Open _ _- | isNonCritical err ->- -- Open /or/ half-closed (local)- return (Closed cc)- HalfClosedRemote- | isNonCritical err ->- return (Closed cc)- _otherwise -> do- E.throwIO $ StreamErrorIsReceived err streamId+ -- Open /or/ half-closed (local)+ Open _ _ -> return (Closed cc)+ HalfClosedRemote -> return (Closed cc)+ Reserved -> return (Closed cc)+ Closed _ -> return (Closed cc)+ -- Only an idle stream is left, which a PRIORITY frame can have+ -- created. Section 5.1 again, on "idle": "Receiving any frame other+ -- than HEADERS or PRIORITY on a stream in this state MUST be treated+ -- as a connection error (Section 5.4.1) of type PROTOCOL_ERROR."+ Idle ->+ E.throwIO $+ ConnectionErrorIsSent+ ProtocolError+ streamId+ "rst_stream on an idle stream" -- (No state transition) stream FramePriority header bs _ s Stream{streamNumber} = do -- ignore@@ -624,17 +691,6 @@ E.throwIO $ StreamErrorIsSent ProtocolError streamId $ fromString ("illegal frame " ++ show x ++ " for " ++ show streamId)--{- FOURMOLU_DISABLE -}--- Although some stream errors indicate misbehaving peers, such as--- FLOW_CONTROL_ERROR, not all errors do. We will close the connection only--- for critical errors.-isNonCritical :: ErrorCode -> Bool-isNonCritical NoError = True-isNonCritical Cancel = True-isNonCritical InternalError = True-isNonCritical _ = False-{- FOURMOLU_ENABLE -} ----------------------------------------------------------------
Network/HTTP2/H2/Sender.hs view
@@ -79,7 +79,8 @@ ctx@Context{outputQ, controlQ, encodeDynamicTable, outputBufferLimit} Config{..} = do labelMe "H2 sender"- -- err is re-thrown by "runH2"+ -- This catches an asynchronous exception.+ -- It is re-thrown by "runH2" loop 0 `E.catch` return where ----------------------------------------------------------------@@ -159,16 +160,28 @@ -- Both the stream window and the connection window are open. ---------------------------------------------------------------- outputAndSync :: Output -> Offset -> IO Offset- outputAndSync out@(Output strm otyp sync) off = E.handle (\e -> resetStream strm InternalError e >> return off) $ do+ -- "handler" catches an asynchronous exception and+ -- re-throws it.+ outputAndSync out@(Output strm otyp sync) off = E.handle (handler strm off) $ do state <- readStreamState strm if isHalfClosedLocal state- then case otyp of- OReset mErr | not (isClosed state) -> do- -- RST_STREAM is the only frame we can still send after half-closing- resetStreamWith strm mErr- return off- _otherwise ->- return off+ then do+ case otyp of+ OReset mErr+ | not (isClosed state) ->+ -- RST_STREAM is the only frame we can still send+ -- after half-closing+ resetStreamWith strm mErr+ _otherwise ->+ return ()+ -- Nothing more can go out on this stream, but whoever+ -- enqueued this output is waiting in 'syncWithSender'' to+ -- be told so. Dropping the notification parked that+ -- thread on an MVar nothing would ever fill, until the+ -- timeout manager killed it -- one stranded worker per+ -- stream the peer resets while a response is in flight.+ sync Nothing+ return off else case otyp of OHeader hdr mnext tlrmkr -> do (off', mout') <- outputHeader strm hdr mnext tlrmkr sync off@@ -187,6 +200,10 @@ return off' ----------------------------------------------------------------+ handler strm off e = do+ resetStream strm InternalError e+ return off+ resetStream :: Stream -> ErrorCode -> E.SomeException -> IO () resetStream strm err e | isAsyncException e = E.throwIO e
Network/HTTP2/H2/StreamTable.hs view
@@ -78,6 +78,12 @@ let oddTable' = IntMap.insert k v oddTable in OddStreamTable oddConc oddTable' +-- | Remove a stream and give its concurrency slot back.+--+-- 'closed' can be called more than once for the same stream -- a RST_STREAM+-- carrying a non-critical error code goes through both 'stream' and+-- 'processState', each of which closes it -- so the count must follow an+-- entry that was really there, not the number of calls. deleteOdd :: TVar OddStreamTable -> IntMap.Key -> E.SomeException -> IO () deleteOdd var k err = do mv <- atomically deleteStream@@ -88,10 +94,13 @@ deleteStream :: STM (Maybe Stream) deleteStream = do OddStreamTable{..} <- readTVar var- let oddConc' = oddConc - 1- oddTable' = IntMap.delete k oddTable- writeTVar var $ OddStreamTable oddConc' oddTable'- return $ IntMap.lookup k oddTable+ case IntMap.lookup k oddTable of+ Nothing -> return Nothing+ Just v -> do+ let oddConc' = oddConc - 1+ oddTable' = IntMap.delete k oddTable+ writeTVar var $ OddStreamTable oddConc' oddTable'+ return $ Just v lookupOdd :: TVar OddStreamTable -> IntMap.Key -> IO (Maybe Stream) lookupOdd var k = IntMap.lookup k . oddTable <$> readTVarIO var@@ -128,6 +137,8 @@ let evenTable' = IntMap.insert k v evenTable in EvenStreamTable evenConc evenTable' evenCache +-- | Remove a stream and give its concurrency slot back.+-- Idempotent, for the same reason as 'deleteOdd'. deleteEven :: TVar EvenStreamTable -> IntMap.Key -> E.SomeException -> IO () deleteEven var k err = do mv <- atomically deleteStream@@ -138,10 +149,13 @@ deleteStream :: STM (Maybe Stream) deleteStream = do EvenStreamTable{..} <- readTVar var- let evenConc' = evenConc - 1- evenTable' = IntMap.delete k evenTable- writeTVar var $ EvenStreamTable evenConc' evenTable' evenCache- return $ IntMap.lookup k evenTable+ case IntMap.lookup k evenTable of+ Nothing -> return Nothing+ Just v -> do+ let evenConc' = evenConc - 1+ evenTable' = IntMap.delete k evenTable+ writeTVar var $ EvenStreamTable evenConc' evenTable' evenCache+ return $ Just v lookupEven :: TVar EvenStreamTable -> IntMap.Key -> IO (Maybe Stream) lookupEven var k = IntMap.lookup k . evenTable <$> readTVarIO var
Network/HTTP2/H2/Types.hs view
@@ -199,8 +199,12 @@ type ReasonPhrase = ShortByteString -- | The connection error or the stream error.--- Stream errors are treated as connection errors since--- there are no good recovery ways.+-- A stream error resets that stream and the connection carries on, as+-- RFC 9113 section 5.4.2 asks. One kind of trouble is a connection error+-- even though the spec calls it a stream error, because this+-- implementation cannot carry on through it: a field block abandoned+-- part-way leaves the HPACK tables disagreeing with the peer's, and+-- nothing sent afterwards would decode. -- `ErrorCode` in connection errors should be the highest stream identifier -- but in this implementation it identifies the stream that -- caused this error.
Network/HTTP2/H2/Window.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} module Network.HTTP2.H2.Window where @@ -80,6 +81,28 @@ let frame = windowUpdateFrame streamNumber ws cframe = CFrames Nothing [frame] enqueueControl controlQ cframe++-- | Account for a DATA frame that is being dropped.+--+-- Its stream is gone -- reset, or closed and forgotten -- so there is no+-- stream window to adjust. The peer charged these octets against the+-- connection window before sending them, though, and if we say nothing its+-- view of that window shrinks for good; enough dropped frames and the+-- connection stalls with both sides believing the other is at fault. So+-- charge them and give them straight back.+informIgnoredData :: Context -> StreamId -> Int -> IO ()+informIgnoredData _ _ 0 = return ()+informIgnoredData Context{controlQ, rxFlow} sid len = do+ ok <- atomicModifyIORef' rxFlow $ checkRxLimit len+ unless ok $+ E.throwIO $+ ConnectionErrorIsSent+ EnhanceYourCalm+ sid+ "exceeds connection flow-control limit"+ mxc <- atomicModifyIORef rxFlow $ maybeOpenRxWindow len FCTWindowUpdate+ forM_ mxc $ \ws ->+ enqueueControl controlQ $ CFrames Nothing [windowUpdateFrame 0 ws] -- This must be called after an application is finished -- to adjust RX window.
http2.cabal view
@@ -1,6 +1,6 @@-cabal-version: >=1.10+cabal-version: 2.0 name: http2-version: 5.4.4+version: 5.4.5 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -140,7 +140,7 @@ http-types, http2, network,- network-run >= 0.5 && <0.6,+ network-run >= 0.6 && <0.7, unix-time if flag(devel)@@ -309,7 +309,7 @@ http-types, http2, network,- network-run >= 0.5 && <0.6,+ network-run >= 0.6 && <0.7, random, typed-process @@ -328,7 +328,7 @@ hspec >=1.3, http-types, http2,- network-run >= 0.5 && <0.6,+ network-run >= 0.6 && <0.7, typed-process if flag(h2spec)
test/HPACK/IntegerSpec.hs view
@@ -2,6 +2,8 @@ import qualified Data.ByteString as BS import Data.Maybe (fromMaybe)+import Data.Word (Word8)+import Network.HPACK (DecodeError (..)) import Network.HPACK.Internal import Test.Hspec import Test.Hspec.QuickCheck@@ -14,8 +16,38 @@ x' <- decodeInteger n w ws x `shouldBe` x' +roundtrip7 :: BS.ByteString -> IO Int+roundtrip7 bs = do+ let (w, ws) = fromMaybe (error "roundtrip7") $ BS.uncons bs+ decodeInteger 7 w ws++-- | Decode with a 7-bit prefix that is all ones, so that the continuation+-- octets in 'ws' are what decides the value.+decode7 :: [Word8] -> IO Int+decode7 ws = decodeInteger 7 127 (BS.pack ws)+ spec :: Spec spec = do+ describe "decodeInteger" $ do+ it "rejects an encoding that runs past the limit" $ do+ r <- encodeInteger 7 integerLimit >>= roundtrip7+ r `shouldBe` integerLimit+ ws <- BS.unpack . BS.tail <$> encodeInteger 7 (integerLimit + 1)+ decode7 ws `shouldThrow` (== TooLargeInteger)++ it "rejects an encoding in more octets than the limit can take" $+ -- Continuation octets that each add nothing, so only their number+ -- is objectionable.+ decode7 (replicate 8 0x80 ++ [0x00]) `shouldThrow` (== TooLargeInteger)++ it "rejects an encoding that would wrap around" $+ -- This used to come back as 2, by overflowing 'Int' until it+ -- landed there: the same as the single octet 0x82, ":method: GET".+ -- Two byte strings decoding alike is exactly what RFC 7541+ -- section 5.1 asks a decoder to refuse.+ decode7 [0x83, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01]+ `shouldThrow` (== TooLargeInteger)+ describe "encode and decode" $ do prop "duality" $ dual 1 prop "duality" $ dual 2
test/HTTP2/ClientSpec.hs view
@@ -136,7 +136,13 @@ putMVar resultVar result threadDelay 10000 +-- | A malformed request is a stream error (RFC 9113 section 8.1.1), so the+-- server resets that stream and the connection carries on. The client learns+-- of it through the stream it was waiting on, as 'StreamResetIsReceived'.+--+-- This used to also admit 'ConnectionErrorIsReceived', from back when the+-- server escalated every stream error to the connection and answered one bad+-- request by hanging up on all of them. streamError :: Selector HTTP2Error-streamError StreamErrorIsReceived{} = True-streamError ConnectionErrorIsReceived{} = True+streamError StreamResetIsReceived{} = True streamError _ = False
test/HTTP2/FrameSpec.hs view
@@ -4,12 +4,67 @@ import Test.Hspec +import qualified Data.ByteString as BS import Data.ByteString.Char8 () import Data.Either import Network.HTTP2.Frame +-- | The error a decoder reports, or Nothing when it accepted the payload.+decodeError :: FrameType -> FrameHeader -> BS.ByteString -> Maybe ErrorCode+decodeError typ header body = case decodeFramePayload typ header body of+ Left (FrameDecodeError ec _ _) -> Just ec+ Right _ -> Nothing+ spec :: Spec spec = do+ describe "decodeFramePayload" $ do+ -- Each of these used to reach a peek at a fixed offset that never+ -- consulted the length of the ByteString it was reading from. An+ -- empty one is the shared empty ByteString, whose pointer is null, so+ -- the result was a segfault rather than an exception -- which is why+ -- none of this could be written as a failing assertion before.+ it "rejects a padded frame with no room for Pad Length" $ do+ let padded = FrameHeader 0 (setPadded defaultFlags) 1+ decodeError FrameData padded "" `shouldBe` Just FrameSizeError+ decodeError FramePushPromise padded "" `shouldBe` Just FrameSizeError++ it "rejects a padded HEADERS whose padding covers the priority fields" $ do+ -- Six octets is the smallest payload the header check accepts for+ -- PADDED and PRIORITY together, and a Pad Length of five leaves+ -- none of the five priority octets behind.+ let flags = setPadded $ setPriority defaultFlags+ header = FrameHeader 6 flags 1+ decodeError FrameHeaders header (BS.pack [5, 0, 0, 0, 0, 0])+ `shouldBe` Just FrameSizeError++ it "rejects a padded PUSH_PROMISE whose padding covers the promised id" $ do+ let flags = setPadded defaultFlags+ header = FrameHeader 5 flags 1+ decodeError FramePushPromise header (BS.pack [4, 0, 0, 0, 0])+ `shouldBe` Just FrameSizeError++ it "rejects a payload shorter than the frame header promised" $ do+ -- What a peer that hangs up mid-frame leaves behind.+ decodeError FramePriority (FrameHeader 5 defaultFlags 1) ""+ `shouldBe` Just FrameSizeError+ decodeError FrameRSTStream (FrameHeader 4 defaultFlags 1) ""+ `shouldBe` Just FrameSizeError+ decodeError FrameWindowUpdate (FrameHeader 4 defaultFlags 1) ""+ `shouldBe` Just FrameSizeError+ decodeError FrameSettings (FrameHeader 6 defaultFlags 0) ""+ `shouldBe` Just FrameSizeError++ it "rejects a payload too short for the fields it holds" $ do+ -- A payloadLength of zero satisfies checkFrameSize against an+ -- empty payload, but each of these still has a fixed-size field+ -- to read. GOAWAY was a segfault; the other three quietly+ -- returned whatever lay past the end of the buffer.+ let lying = FrameHeader 0 defaultFlags 1+ decodeError FrameRSTStream lying "" `shouldBe` Just FrameSizeError+ decodeError FrameWindowUpdate lying "" `shouldBe` Just FrameSizeError+ decodeError FramePriority lying "" `shouldBe` Just FrameSizeError+ decodeError FrameGoAway lying "" `shouldBe` Just FrameSizeError+ describe "encodeFrameHeader & decodeFrameHeader" $ do it "encode/decodes frames properly" $ do let header =
test/HTTP2/ServerSpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -24,6 +25,7 @@ import System.IO import System.IO.Unsafe import System.Random+import System.Timeout (timeout) import Test.Hspec import Network.HPACK@@ -69,6 +71,47 @@ preface <- takeMVar prefaceVar preface `shouldBe` connectionPreface + it "refuses one stream over the limit and keeps the connection" $+ E.bracket (forkIO runServerMaxConc1) killThread $ \_ -> do+ threadDelay 10000+ -- The server announced room for one concurrent stream. Open+ -- one, reset it, then open two more: the second of those is+ -- the one over the limit.+ --+ -- Two things are on trial. That the reset gives the slot back+ -- exactly once -- decrementing the count twice, as it used to,+ -- would leave room for both. And that being over the limit+ -- costs you that stream and not the connection: no GOAWAY.+ frames <-+ rawExchange+ [ openStreamFrame 1+ , encodeFrame (EncodeInfo defaultFlags 1 Nothing) $+ RSTStreamFrame Cancel+ , openStreamFrame 3+ , openStreamFrame 5+ ]+ [(sid, ec) | (FrameRSTStream, sid, ec) <- resets frames]+ `shouldBe` [(5, RefusedStream)]+ [() | (FrameGoAway, _, _) <- resets frames] `shouldBe` []++ it "releases a worker whose stream the peer reset" $ do+ doneVar <- newEmptyMVar+ E.bracket (forkIO (runServerCancel doneVar)) killThread $ \_ -> do+ threadDelay 10000+ runAttack cancelInFlight+ timeout 1000000 (takeMVar doneVar) `shouldReturn` Just ()++ it "survives a padded HEADERS whose padding covers the priority fields" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runAttack paddingOverPriority+ `shouldThrow` connectionError "no room for priority fields"++ it "resets one stream and goes on serving the connection" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runStreamErrorClient+ it "prevents attacks" $ E.bracket (forkIO runServer) killThread $ \_ -> do threadDelay 10000@@ -91,6 +134,35 @@ freeSimpleConfig (\conf -> run defaultServerConfig conf server) +-- | Like 'runServer', but announcing room for a single concurrent stream.+runServerMaxConc1 :: IO ()+runServerMaxConc1 = runTCPServer (Just host) port runHTTP2Server+ where+ sconf =+ defaultServerConfig+ { settings = (settings defaultServerConfig){maxConcurrentStreams = Just 1}+ }+ runHTTP2Server s =+ E.bracket+ (allocSimpleConfig s 32768)+ freeSimpleConfig+ (\conf -> run sconf conf server)++-- | A server whose handler waits long enough for a RST_STREAM to arrive+-- before it responds, and then signals that 'sendResponse' returned.+runServerCancel :: MVar () -> IO ()+runServerCancel doneVar = runTCPServer (Just host) port runHTTP2Server+ where+ runHTTP2Server s =+ E.bracket+ (allocSimpleConfig s 32768)+ freeSimpleConfig+ (\conf -> run defaultServerConfig conf cancelServer)+ cancelServer _req _aux sendResponse = do+ threadDelay 200000+ sendResponse responseHello []+ putMVar doneVar ()+ runFakeServer :: MVar ByteString -> IO () runFakeServer prefaceVar = do runTCPServer (Just host) port $ \s -> do@@ -453,6 +525,140 @@ -- Otherwise, a stream error terminates the connection. bsR = encodeFrame einfoR $ RSTStreamFrame NoError cioWriteBytes bsR++-- | Open a stream, reset it, then open two more. The server announced room+-- for one concurrent stream, so the third one here must be refused.+--+-- Closing a stream used to give its slot back twice -- a RST_STREAM carrying a+-- non-critical error code is closed by both 'stream' and 'processState' -- so+-- the count drifted down by one on every reset and this sequence went through+-- unchallenged.+-- | A HEADERS frame opening a stream and leaving it open, so that it goes on+-- holding a concurrency slot.+--+-- Stream identifiers are written out rather than taken from+-- 'C.cioCreateStream': the limit being overrun is the one the server+-- announced, and asking for a stream the proper way would block on that same+-- limit on this side.+openStreamFrame :: StreamId -> ByteString+openStreamFrame sid = encodeFrame einfo $ HeadersFrame Nothing hdr+ where+ einfo = EncodeInfo (setEndHeader defaultFlags) sid Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]++-- | Speak raw frames to the server and collect what it says back.+rawExchange :: [ByteString] -> IO [(FrameType, StreamId, ByteString)]+rawExchange out = runTCPClient host port $ \s -> do+ sendAll s connectionPreface+ sendAll s $ encodeFrame (EncodeInfo defaultFlags 0 Nothing) $ SettingsFrame []+ mapM_ (sendAll s) out+ splitFrames <$> collect mempty s+ where+ collect acc s = do+ mbs <- timeout 300000 $ recv s 4096+ case mbs of+ Just bs | not (B.null bs) -> collect (acc `B.append` bs) s+ _ -> return acc++splitFrames :: ByteString -> [(FrameType, StreamId, ByteString)]+splitFrames bs+ | B.length bs < frameHeaderLength = []+ | otherwise =+ let (h, rest) = B.splitAt frameHeaderLength bs+ (typ, FrameHeader{payloadLength, streamId}) = decodeFrameHeader h+ (body, rest') = B.splitAt payloadLength rest+ in (typ, streamId, body) : splitFrames rest'++-- | The RST_STREAM and GOAWAY frames among them, with their error codes.+resets+ :: [(FrameType, StreamId, ByteString)] -> [(FrameType, StreamId, ErrorCode)]+resets frames =+ [ (typ, sid, ec)+ | (typ, sid, body) <- frames+ , typ == FrameRSTStream || typ == FrameGoAway+ , Just ec <- [errorCodeOf typ sid body]+ ]+ where+ errorCodeOf FrameRSTStream sid body =+ case decodeRSTStreamFrame (FrameHeader (B.length body) defaultFlags sid) body of+ Right (RSTStreamFrame ec) -> Just ec+ _ -> Nothing+ errorCodeOf FrameGoAway sid body =+ case decodeGoAwayFrame (FrameHeader (B.length body) defaultFlags sid) body of+ Right (GoAwayFrame _ ec _) -> Just ec+ _ -> Nothing+ errorCodeOf _ _ _ = Nothing++-- | Open a stream and cancel it straight away, while the server is still+-- working on the response.+--+-- The sender skips a stream that is already half-closed, and used to return+-- without telling the thread that enqueued the output. That thread sat in+-- 'syncWithSender'' on an MVar nothing would fill, so 'sendResponse' never+-- returned and the worker was only reclaimed when the timeout manager killed+-- it, seconds later.+cancelInFlight :: C.ClientIO -> IO ()+cancelInFlight C.ClientIO{..} = do+ -- setEndStream for HalfClosedRemote, so that CANCEL is accepted as a+ -- stream error rather than taken down the connection.+ let einfoH = EncodeInfo (setEndStream $ setEndHeader defaultFlags) 1 Nothing+ hdr =+ hpackEncode+ [ (":scheme", "http")+ , (":authority", "127.0.0.1")+ , (":path", "/")+ , (":method", "GET")+ ]+ cioWriteBytes $ encodeFrame einfoH $ HeadersFrame Nothing hdr+ cioWriteBytes $+ encodeFrame (EncodeInfo defaultFlags 1 Nothing) $+ RSTStreamFrame Cancel++-- | Send a malformed request, then a good one down the same connection.+--+-- RFC 9113 section 8.1.1 makes a malformed request a stream error, so the+-- server must reset that one stream and keep serving: the second request is+-- the point of the test. The whole connection used to come down with the+-- first, taking every other stream on it along.+runStreamErrorClient :: IO ()+runStreamErrorClient = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf ->+ C.run cliconf conf $ \sendRequest _aux -> do+ -- "te" may only ever be "trailers" (section 8.2.2), and unlike+ -- "connection" it is not one of the headers the sender strips.+ let bad = C.requestNoBody methodGet "/" [("te", "gzip")]+ sendRequest bad (\_ -> return ()) `shouldThrow` streamWasReset+ let good = C.requestNoBody methodGet "/" []+ sendRequest good $ \rsp ->+ C.responseStatus rsp `shouldBe` Just ok200+ where+ cliconf = C.defaultClientConfig{C.authority = host}++streamWasReset :: Selector C.HTTP2Error+streamWasReset C.StreamResetIsReceived{} = True+streamWasReset _ = False++-- | A HEADERS frame with PADDED and PRIORITY set, six octets of payload and a+-- Pad Length of five, so that the padding covers the whole of the priority+-- fields the flag promises.+--+-- Six octets is the smallest payload the frame header check accepts for those+-- two flags together, so this gets through it; the decoder then took the five+-- priority octets out of what padding had left empty, reading off the end of+-- the buffer. The empty ByteString is the shared one, whose pointer is null,+-- so what died was the process rather than the connection.+paddingOverPriority :: C.ClientIO -> IO ()+paddingOverPriority C.ClientIO{..} = do+ let flags = setPadded $ setPriority $ setEndHeader defaultFlags+ header = encodeFrameHeader FrameHeaders $ FrameHeader 6 flags 1+ payload = B.pack [5, 0, 0, 0, 0, 0] -- Pad Length 5, then the padding+ cioWriteBytes $ header `B.append` payload connectionError :: C.ReasonPhrase -> C.HTTP2Error -> Bool connectionError phrase (C.ConnectionErrorIsReceived _ _ p)