http3 0.1.7 → 0.1.8
raw patch · 18 files changed
+844/−126 lines, 18 filesdep ~time-managerPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: time-manager
API changes (from Hackage documentation)
+ Network.HTTP3.Internal: StreamResetIsReceived :: ApplicationProtocolError -> StreamResetIsReceived
+ Network.HTTP3.Internal: newtype StreamResetIsReceived
+ Network.QPACK.Internal: encoderInstructionLength :: ByteString -> Maybe Int
Files
- ChangeLog.md +91/−64
- Network/HTTP3/Client.hs +74/−3
- Network/HTTP3/Error.hs +11/−0
- Network/HTTP3/Recv.hs +31/−6
- Network/HTTP3/Server.hs +24/−3
- Network/QPACK.hs +35/−8
- Network/QPACK/Instruction.hs +46/−0
- Network/QPACK/Table/Dynamic.hs +60/−11
- http3.cabal +5/−2
- test/HTTP3/Error.hs +37/−19
- test/HTTP3/ErrorSpec.hs +3/−1
- test/HTTP3/HandlerSpec.hs +37/−0
- test/HTTP3/InformationalSpec.hs +70/−0
- test/HTTP3/Server.hs +51/−0
- test/HTTP3/ServerSpec.hs +108/−3
- test/QPACK/HeaderBlockSpec.hs +88/−5
- test/QPACK/InstructionSpec.hs +25/−1
- test/QPACK/TableSpec.hs +48/−0
ChangeLog.md view
@@ -1,77 +1,104 @@ # Revision history for http3 +## 0.1.8++* Allow time-manager 0.4.+* Keep the encoder's dynamic table in step when Huffman makes a field longer.+ [#43](https://github.com/kazu-yamamoto/http3/pull/43)+* Decode an encoder instruction once it has all arrived.+ [#44](https://github.com/kazu-yamamoto/http3/pull/44)+* Do not take a body cut short for a whole one.+ [#45](https://github.com/kazu-yamamoto/http3/pull/45)+* Reset a client request cut short instead of ending it.+ [#46](https://github.com/kazu-yamamoto/http3/pull/46)+* Take the final response past informational ones.+ [#47](https://github.com/kazu-yamamoto/http3/pull/47)+* Accept a content-length on a response with no content.+ [#48](https://github.com/kazu-yamamoto/http3/pull/48)+* Reset the stream of a failed handler with H3_INTERNAL_ERROR.+ [#49](https://github.com/kazu-yamamoto/http3/pull/49)+* Evict from the decoder's table by size, and refuse an entry too large.+ [#50](https://github.com/kazu-yamamoto/http3/pull/50)+* Tests: keep the cases that need /drain out of h3ErrorSpec.+ [#42](https://github.com/kazu-yamamoto/http3/pull/42)+ ## 0.1.7 -* Requiring quic v0.3.10, which hands the application a stream only once- the frame that opened it has been checked. A server used to answer on- a stream whose first frame was past the flow control limit, just before- the connection was closed over it.-* Closing the connection with H3_CLOSED_CRITICAL_STREAM when a write on- one of our QPACK streams finds it closed, which the peer's STOP_SENDING- does. It used to throw `StreamIsClosed` into whichever thread wrote.-* QPACK: sending Set Dynamic Table Capacity only when the capacity- changes. `getMaxTableCapacity` is new.-* h3-server: allowing more unidirectional streams than the three a client- needs.-* Tests: `h3ErrorSpec` takes how to read the number of requests served,- so that h3spec can run it against a server elsewhere.+* Require quic 0.3.10.+ [#41](https://github.com/kazu-yamamoto/http3/pull/41)+* Close the connection with H3_CLOSED_CRITICAL_STREAM when one of our+ QPACK streams is closed.+ [#40](https://github.com/kazu-yamamoto/http3/pull/40)+* QPACK: send Set Dynamic Table Capacity only when the capacity changes.+ `getMaxTableCapacity` is new.+ [#40](https://github.com/kazu-yamamoto/http3/pull/40)+* h3-server: allow more unidirectional streams.+ [#39](https://github.com/kazu-yamamoto/http3/pull/39)+* Tests: `h3ErrorSpec` can run against a server elsewhere.+ [#38](https://github.com/kazu-yamamoto/http3/pull/38) ## 0.1.6 -* Requiring quic v0.3.9 and http2 v5.4.6. quic v0.3.7 stops opening a- closed stream again for a late copy of its data, which closed the- connection with FLOW_CONTROL_ERROR now and then (#15); v0.3.8 tells a- stream that was reset from one that ended; v0.3.9 keeps the peer's open- streams within initial_max_streams, closes the sending part on- STOP_SENDING, and opens a stream for a RESET_STREAM that comes before- its data.-* QPACK: fixing the dynamic table where the two ends disagreed: the- maximum number of entries, when a section is blocked, the blocked- streams, more than one outstanding section on a stream, and a change of- capacity. Encoding a field larger than the encoder's buffers.-* QPACK: stopping counting a blocked stream however its wait ends.-* QPACK: evicting an entry nothing refers to once its insertion is- acknowledged.-* QPACK: sending Stream Cancellation for a stream not read to its end or- reset by the peer, and acting on one received.-* QPACK: inserting with a reference to a name not yet acknowledged.-* Holding a field section to our SETTINGS_MAX_FIELD_SECTION_SIZE as it- decodes, not only the frame carrying it; a server answers a request- over it with 431. The new `FieldSectionTooLarge` is thrown otherwise.-* Keeping to the peer's SETTINGS_MAX_FIELD_SECTION_SIZE when sending. The- new `FieldSectionTooLargeForPeer` is thrown by `sendRequest` and- `sendResponse` for a header section over it.-* Reading on past a DATA frame that is empty.-* Treating a message with a connection-specific field as malformed. The- new `ConnectionSpecificField` is thrown for a response or trailers- carrying one.-* Refusing a second control or QPACK stream, and noticing a QPACK stream- closing. Refusing a push stream.-* Stopping reading a unidirectional stream of an unknown type, and- refusing a server-initiated bidirectional stream.-* A client whose request the server stops with STOP_SENDING no longer- resets the stream, so that a response sent after it is still read.-* Closing a unidirectional stream we stop reading, so that it is given- back to the peer's limit.-* This is a patch release, but `TableOperation` in `Network.QPACK` has a- new field, `getHeaderSize`.+* Require quic 0.3.9 and http2 5.4.6.+ [#21](https://github.com/kazu-yamamoto/http3/pull/21)+ [#30](https://github.com/kazu-yamamoto/http3/pull/30)+ [#37](https://github.com/kazu-yamamoto/http3/pull/37)+* QPACK: fix the dynamic table where the two ends disagreed.+ [#21](https://github.com/kazu-yamamoto/http3/pull/21)+* QPACK: stop counting a blocked stream however its wait ends.+ [#23](https://github.com/kazu-yamamoto/http3/pull/23)+* QPACK: evict an unreferenced entry once its insertion is acknowledged.+ [#24](https://github.com/kazu-yamamoto/http3/pull/24)+* QPACK: send and act on Stream Cancellation.+ [#26](https://github.com/kazu-yamamoto/http3/pull/26)+ [#35](https://github.com/kazu-yamamoto/http3/pull/35)+* QPACK: insert with a reference to a name not yet acknowledged.+ [#32](https://github.com/kazu-yamamoto/http3/pull/32)+* Hold a field section to our SETTINGS_MAX_FIELD_SECTION_SIZE while+ decoding. `FieldSectionTooLarge` is new.+ [#28](https://github.com/kazu-yamamoto/http3/pull/28)+* Keep to the peer's SETTINGS_MAX_FIELD_SECTION_SIZE when sending.+ `FieldSectionTooLargeForPeer` is new.+ [#33](https://github.com/kazu-yamamoto/http3/pull/33)+* Read on past an empty DATA frame.+ [#22](https://github.com/kazu-yamamoto/http3/pull/22)+* Treat a message with a connection-specific field as malformed.+ `ConnectionSpecificField` is new.+ [#29](https://github.com/kazu-yamamoto/http3/pull/29)+* Refuse a second control or QPACK stream, and a push stream.+ [#25](https://github.com/kazu-yamamoto/http3/pull/25)+* Stop reading a unidirectional stream of an unknown type, and refuse a+ server-initiated bidirectional stream.+ [#31](https://github.com/kazu-yamamoto/http3/pull/31)+* Client: do not reset a stream the server stops with STOP_SENDING.+ [#36](https://github.com/kazu-yamamoto/http3/pull/36)+* Close a unidirectional stream we stop reading.+ [#37](https://github.com/kazu-yamamoto/http3/pull/37)+* `TableOperation` in `Network.QPACK` has a new field, `getHeaderSize`.+ [#33](https://github.com/kazu-yamamoto/http3/pull/33) ## 0.1.5 -* Security fixes. Requiring http2 v5.4.5, whose HPACK integer decoder is- bounded; QPACK decodes its integers with it.-* Refusing a QPACK index that names nothing, at both ends of both tables.-* Putting a ceiling on the frame payload we will hold.-* Sizing the Huffman scratch buffer to what it has to hold.-* Reading a unidirectional stream type as the variable-length integer it is.-* Not handing the application a request we have already rejected.-* Checking a message against the content-length it declared.-* Reading the whole SETTINGS frame, noticing a repeated identifier, and- refusing one that stops mid-parameter.-* Giving the application the peer's address, not our own.-* This is a patch release, but `Network.HTTP3.Internal` and- `Network.QPACK.Internal` changed: `parseH3Frame` takes the payload limit,- `IFrame` has `ITooLong`, and `DecodeError` has `IllegalDynamicIndex`.+* Security fixes. Require http2 5.4.5.+* Refuse a QPACK index that names nothing.+ [#12](https://github.com/kazu-yamamoto/http3/pull/12)+ [#20](https://github.com/kazu-yamamoto/http3/pull/20)+* Limit the frame payload we hold.+ [#13](https://github.com/kazu-yamamoto/http3/pull/13)+* Size the Huffman scratch buffer to what it has to hold.+ [#14](https://github.com/kazu-yamamoto/http3/pull/14)+* Read a unidirectional stream type as a variable-length integer.+ [#16](https://github.com/kazu-yamamoto/http3/pull/16)+* Do not hand the application a request already rejected.+ [#17](https://github.com/kazu-yamamoto/http3/pull/17)+* Check a message against its content-length.+ [#18](https://github.com/kazu-yamamoto/http3/pull/18)+* Read the whole SETTINGS frame and refuse a repeated or truncated one.+ [#19](https://github.com/kazu-yamamoto/http3/pull/19)+ [#20](https://github.com/kazu-yamamoto/http3/pull/20)+* Give the application the peer's address, not our own.+ [#10](https://github.com/kazu-yamamoto/http3/pull/10)+* `Network.HTTP3.Internal` and `Network.QPACK.Internal` changed. ## 0.1.4
Network/HTTP3/Client.hs view
@@ -34,7 +34,9 @@ import Control.Concurrent import qualified Control.Exception as E+import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.UTF8 as UTF8+import Data.IORef import Data.IP (IPv6) import Network.HTTP.Semantics.Client import Network.HTTP.Semantics.Client.Internal@@ -97,6 +99,48 @@ where sid = QUIC.streamId strm +-- | The header section of the final response, past any informational (1xx)+-- ones before it.+--+-- RFC 9114, section 4.1: a response may begin with any number of+-- informational responses, each a header section of its own, before the+-- final one. The first header section was taken for the response: after a+-- 103 (Early Hints) or a 100 (Continue), the client saw that, and the body+-- reader took the final response's HEADERS for trailers and ended the body+-- there, the final response lost. They are skipped now, as the application+-- has no way here to be handed them.+--+-- RFC 9114 sets no limit on how many there may be, and a server could go on+-- sending them for as long as it liked, the request never answered. More+-- than 'maxInformational' reset the stream with H3_EXCESSIVE_LOAD: a server+-- has no use for more than a couple -- a 100 and a 103, say.+recvFinalHeader+ :: Context -> QUIC.Stream -> Source -> IO (Maybe TokenHeaderTable)+recvFinalHeader ctx strm src = loop (0 :: Int)+ where+ sid = QUIC.streamId strm+ loop n = do+ mvt <- recvHeader ctx sid src+ case mvt of+ Just (_, vt)+ | Just status <- getFieldValue tokenStatus vt+ , informational status ->+ if n < maxInformational+ then loop (n + 1)+ else do+ QUIC.resetStream strm H3ExcessiveLoad+ E.throwIO $+ QUIC.ApplicationProtocolErrorIsSent+ H3ExcessiveLoad+ "too many informational responses"+ _ -> return mvt+ informational status = C8.length status == 3 && C8.head status == '1'++-- | How many informational responses 'recvFinalHeader' takes before the+-- final one.+maxInformational :: Int+maxInformational = 10+ sendRequest :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a sendRequest ctx scm auth (Request outobj) processResponse = do@@ -104,12 +148,14 @@ -- header that exceeds the indicated size". Here, so that the caller is -- the one told. checkHeaderSize ctx hdr'- E.bracket (newStream ctx) closeStream $ \strm -> do+ sent <- newIORef False+ E.bracket (newStream ctx) (done sent) $ \strm -> do forkManagedTimeout ctx "H3 client: sendRequest" $ \th -> ( do sendHeader ctx strm th hdr' sendBody ctx strm th outobj QUIC.shutdownStream strm+ writeIORef sent True ) -- What goes wrong here is thrown away with the thread, and -- the request would be left half sent, with the response@@ -129,7 +175,7 @@ src <- newSource strm let sid = QUIC.streamId strm (`E.finally` cancelUnlessReadToEnd ctx sid src) $ do- mvt <- recvHeader ctx sid src+ mvt <- recvFinalHeader ctx strm src case mvt of Nothing -> do QUIC.resetStream strm H3MessageError@@ -142,10 +188,35 @@ QUIC.resetStream strm H3MessageError E.throwIO $ ConnectionSpecificField name Just vt@(_, valtbl) -> do- (readB, refH) <- newBodyReader ctx sid src valtbl+ (readB, refH) <-+ newBodyReader ctx sid src valtbl $ noContent valtbl let rsp = Response $ InpObj vt Nothing readB refH processResponse rsp where+ -- A response defined to have no content: to HEAD, a 204 or a 304, or a+ -- 2xx to CONNECT (RFC 9110, section 6.4.1). Its content-length, which it+ -- may carry, describes content it does not have; it was checked against+ -- the empty body all the same, and the client refused such a response+ -- with ContentLengthMismatch.+ noContent valtbl =+ method == Just "HEAD"+ || status `elem` [Just "204", Just "304"]+ || (method == Just "CONNECT" && maybe False ("2" `C8.isPrefixOf`) status)+ where+ status = getFieldValue tokenStatus valtbl+ method = snd <$> find ((== ":method") . fst) hdr+ -- Done with the stream: the response has been processed, or waiting for+ -- it was given up -- 'timeout', say. A request sent in full has had its+ -- FIN, and closing the stream only tidies up. One that has not is cut+ -- short, and is reset (H3_REQUEST_CANCELLED). 'closeStream' used to be+ -- called either way, and it ends the sending part with a FIN: the server+ -- took a request body cut short for a whole one. The sender, if it is+ -- still at it, finds the stream closed and stops.+ done sent strm = do+ complete <- readIORef sent+ if complete+ then closeStream strm+ else QUIC.resetStream strm H3RequestCancelled hdr = outObjHeaders outobj isIPv6 = isJust (readMaybe auth :: Maybe IPv6) auth'
Network/HTTP3/Error.hs view
@@ -3,6 +3,7 @@ module Network.HTTP3.Error ( ContentLengthMismatch (..), ConnectionSpecificField (..),+ StreamResetIsReceived (..), ApplicationProtocolError ( H3NoError, H3GeneralProtocolError,@@ -50,6 +51,16 @@ deriving (Eq, Show) instance E.Exception ConnectionSpecificField++-- | The peer reset the stream, with this error code, before the body came to+-- its end: what has been read of the body is not the whole of it.+--+-- quic tells a reset to the reader as the end of the stream, and the body+-- reader used to take it for the end of the body.+newtype StreamResetIsReceived = StreamResetIsReceived ApplicationProtocolError+ deriving (Eq, Show)++instance E.Exception StreamResetIsReceived {- FOURMOLU_DISABLE -} pattern H3NoError :: ApplicationProtocolError
Network/HTTP3/Recv.hs view
@@ -128,17 +128,26 @@ -- Only what is actually read is counted, so a body the application never asks -- for is never checked. Answering that would mean draining it on the -- application's behalf, which is a different design from the one here.+--+-- A message defined to have no content -- a response to HEAD, a 204 or a+-- 304, say -- can carry a content-length that describes content it does not+-- have (RFC 9114, section 4.1.2). For one of those the content is taken to+-- be empty, whatever its content-length says: DATA on it is malformed. newBodyReader :: Context -> StreamId -> Source -> ValueTable+ -> Bool+ -- ^ Whether the message is defined to have no content -> IO (IO (ByteString, Bool), IORef (Maybe TokenHeaderTable))-newBodyReader ctx sid src vt = do+newBodyReader ctx sid src vt noContent = do refI <- newIORef IInit refH <- newIORef Nothing refL <- newIORef 0- let mcl = fst <$> (getFieldValue tokenContentLength vt >>= C8.readInt)+ let mcl+ | noContent = Just 0+ | otherwise = fst <$> (getFieldValue tokenContentLength vt >>= C8.readInt) return (recvBody ctx sid src refI refH mcl refL, refH) recvBody@@ -167,10 +176,26 @@ bs <- readSource src if bs == "" then do- -- Not in the middle of a frame, which would mean it was cut- -- off.- when (st == IInit) $ writeIORef (sourceReadToEnd src) True- endOfBody+ -- The end of the stream, but not always of the body. quic+ -- tells a reset of the peer's as an end too, and a stream+ -- that ends in the middle of a frame was cut off: RFC 9114,+ -- section 7.1, makes that a connection error. Both used to+ -- be taken for the end of the body, so that a body cut+ -- short was delivered as a whole one if it had no+ -- content-length to check.+ mreset <- resetReceived $ sourceStream src+ case mreset of+ Just aerr -> E.throwIO $ StreamResetIsReceived aerr+ Nothing+ | st /= IInit -> do+ abort ctx H3FrameError+ E.throwIO $+ ApplicationProtocolErrorIsSent+ H3FrameError+ "a frame cut off by the end of the stream"+ | otherwise -> do+ writeIORef (sourceReadToEnd src) True+ endOfBody else case parseH3Frame lim st bs of ITooLong _ _ -> do abort ctx H3ExcessiveLoad
Network/HTTP3/Server.hs view
@@ -124,14 +124,35 @@ where sid = QUIC.streamId strm reset se- | isAsyncException se = E.throwIO se+ -- Killed: by the timeout, or with the connection. Whatever was+ -- sent of the response is not the whole of it, and is reset here.+ -- It used to be passed on as it was, and the finalizer+ -- ('closeStream') ended the stream with a FIN: the client took a+ -- response cut short for a whole one. A response that has gone out+ -- in full has had its FIN already, and 'resetStream' does nothing.+ | isAsyncException se = do+ QUIC.resetStream strm H3InternalError+ E.throwIO se | Just (_ :: DecodeError) <- E.fromException se = abort ctx QpackDecompressionFailed -- The response was more than the client will take, and the -- application did nothing about it. Our failure, not the client's. | Just (_ :: FieldSectionTooLargeForPeer) <- E.fromException se = QUIC.resetStream strm H3InternalError- | otherwise = QUIC.resetStream strm H3MessageError+ -- The request is malformed (RFC 9114, section 4.1.2): the body+ -- reader says so, and the handler passes it on.+ | malformed se = QUIC.resetStream strm H3MessageError+ -- The client reset the stream, and the handler gave up on it.+ | Just (_ :: StreamResetIsReceived) <- E.fromException se =+ QUIC.resetStream strm H3RequestCancelled+ -- Anything else is the handler's own failure. H3_MESSAGE_ERROR+ -- was sent for it, which says the request was malformed.+ | otherwise = QUIC.resetStream strm H3InternalError+ malformed se+ | Just (_ :: ContentLengthMismatch) <- E.fromException se = True+ | Just (_ :: ConnectionSpecificField) <- E.fromException se = True+ | Just FieldSectionTooLarge <- E.fromException se = True+ | otherwise = False processRequestIO :: Context -> ((Stream, Request) -> IO ()) -> Stream -> IO () processRequestIO ctx put strm = E.handle reset $ do@@ -198,7 +219,7 @@ where build = do let sid = QUIC.streamId strm- (readB, refH) <- newBodyReader ctx sid src vt+ (readB, refH) <- newBodyReader ctx sid src vt False return $ Request $ InpObj ht Nothing readB refH sendResponse
Network/QPACK.hs view
@@ -188,8 +188,19 @@ } return (enc, handler, ctl) +-- | The most a field can take in either buffer, as a field line or as an+-- insertion on the encoder stream.+--+-- Huffman coding is tried in place before it is known to be the shorter, and+-- a code is at most 30 bits: under four octets per octet. To that come the+-- first octet and the integers -- an index and two lengths, a few octets+-- each. The raw length plus 8 was taken for this, and a field of octets+-- above 0x7f, three to four times longer in Huffman, overran the shared+-- buffers part-way through a chunk: after an earlier field had gone into the+-- dynamic table, and before its insertion was sent, so that the table was+-- out of step with the peer's from there on. tokenHeaderSize :: TokenHeader -> Int-tokenHeaderSize (t, v) = BS.length (CI.original (tokenKey t)) + BS.length v + 8 -- adhoc overhead+tokenHeaderSize (t, v) = 4 * (BS.length (CI.original (tokenKey t)) + BS.length v) + 32 -- | Taking as many fields as fit in @lim@, but always at least one. --@@ -220,9 +231,8 @@ -- | Encoding a chunk from 'splitThrough', in the shared buffers when it fits. ----- One that does not is a single large field, and gets buffers of its own.--- Their size allows for Huffman coding being tried in place before it is known--- to be the shorter: a code is at most 30 bits, so under four octets per octet.+-- One that does not is a single large field, and gets buffers of its own, of+-- the size 'tokenHeaderSize' allows for it. encodeChunk :: Buffer -> BufferSize@@ -236,7 +246,7 @@ | siz <= min bufsiz1 bufsiz2 = qpackEncodeHeader buf1 bufsiz1 buf2 bufsiz2 huff dyntbl ts | otherwise = do- let bufsiz = siz * 4 + 64+ let bufsiz = siz gcbuf1 <- mallocPlainForeignPtrBytes bufsiz gcbuf2 <- mallocPlainForeignPtrBytes bufsiz withForeignPtr gcbuf1 $ \b1 ->@@ -532,9 +542,26 @@ let bs | bs0 == "" = bs1 | otherwise = bs0 <> bs1- when (bs1 /= "") $ do- leftover <- encoderInstructionHandlerS decCapLim dyntbl bs- loop leftover+ when (bs1 /= "") $ case encoderInstructionLength bs of+ Just len+ | len > maxInstructionLength -> E.throwIO EncoderInstructionError+ -- Not all there yet: wait for the rest before decoding.+ | len > BS.length bs -> loop bs+ _ -> do+ leftover <- encoderInstructionHandlerS decCapLim dyntbl bs+ loop leftover+ -- An instruction inserts an entry, which may not be larger than the+ -- capacity, and the capacity not larger than we said (RFC 9204, sections+ -- 4.3.1 to 4.3.3). Its strings come to no more than four octets each+ -- coded in Huffman, a code being at most 30 bits; 32 more allows for the+ -- integers. A longer one cannot be valid.+ --+ -- An instruction that had not all arrived used to be decoded from its+ -- beginning again with each piece of it that did, and kept for as long as+ -- the peer went on: one of a megabyte, never finished, cost seconds of CPU+ -- and gigabytes of allocation. Now it is decoded once it is all there,+ -- and refused as soon as its length says it cannot be valid.+ maxInstructionLength = 4 * decCapLim + 32 -- Note: dyntbl for decoder encoderInstructionHandlerS :: Int -> DynamicTable -> EncoderInstructionHandlerS
Network/QPACK/Instruction.hs view
@@ -9,6 +9,7 @@ encodeEncoderInstructions, decodeEncoderInstructions, decodeEncoderInstructions',+ encoderInstructionLength, encodeEI, decodeEI, @@ -21,6 +22,7 @@ ) where import qualified Control.Exception as E+import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.CaseInsensitive import Network.ByteOrder@@ -123,6 +125,50 @@ left <- extractByteString rbuf rn let eis = build [] return (eis, left)++-- | The length in octets of the first encoder instruction, once enough of it+-- has arrived to tell: its first octet and the integers that give the lengths+-- of its strings (RFC 9204, section 4.3). 'Nothing' until then.+--+-- So that an instruction arriving a piece at a time is decoded once it is+-- all there, rather than tried again from its beginning with each piece.+encoderInstructionLength :: ByteString -> Maybe Int+encoderInstructionLength bs = case BS.uncons bs of+ Nothing -> Nothing+ Just (w0, _)+ -- Insert with name reference: an index, then the value+ | w0 `testBit` 7 -> int 6 0 >>= str . snd+ -- Insert with literal name: the name, then the value+ | w0 `testBit` 6 -> do+ (len, off) <- int 5 0+ str (off + len)+ -- Set dynamic table capacity, or duplicate: an integer+ | otherwise -> snd <$> int 5 0+ where+ -- A string at the offset: its length, with a 7-bit prefix after the+ -- Huffman bit, then the string itself.+ str off = do+ (len, off') <- int 7 off+ return $ off' + len+ -- An integer with an n-bit prefix at the offset: its value, and the+ -- offset after it. One too long to be a length here is taken as one+ -- longer than any instruction can be.+ int :: Int -> Int -> Maybe (Int, Int)+ int n off = do+ w <- at off+ let mask = (1 `shiftL` n) - 1+ v = fromIntegral w .&. mask+ if v < mask then Just (v, off + 1) else go (off + 1) v 0+ where+ go i acc m+ | m > 28 = Just (maxBound `div` 2, i)+ | otherwise = do+ b <- at i+ let acc' = acc + ((fromIntegral b .&. 0x7f) `shiftL` m)+ if b < 0x80 then Just (acc', i + 1) else go (i + 1) acc' (m + 7)+ at i+ | i < BS.length bs = Just $ BS.index bs i+ | otherwise = Nothing decodeEI :: HuffmanDecoder -> ReadBuffer -> IO EncoderInstruction decodeEI hufdec rbuf = do
Network/QPACK/Table/Dynamic.hs view
@@ -151,6 +151,7 @@ | DecodeInfo { huffmanDecoder :: HuffmanDecoder -- only for encoder instruction handler , blockedStreamsD :: IORef Int+ , evictedD :: TVar AbsoluteIndex -- the oldest entry not evicted } {- FOURMOLU_ENABLE -} @@ -166,7 +167,7 @@ , debugQPACK :: IORef Bool , capaReady :: IORef Bool , tableSize :: TVar Size- , maxTableSize :: IORef Size+ , maxTableSize :: TVar Size , sendIns :: ByteString -> IO () , maxHeaderSize :: IORef Int , maxBlockedStreams :: IORef Int@@ -207,6 +208,7 @@ gcbuf <- mallocPlainForeignPtrBytes huftmpsiz let huffmanDecoder = decodeH gcbuf huftmpsiz blockedStreamsD <- newIORef 0+ evictedD <- newTVarIO 0 newDynamicTable DecodeInfo{..} sendDI newDynamicTable :: CodeInfo -> (ByteString -> IO ()) -> IO DynamicTable@@ -221,7 +223,7 @@ debugQPACK <- newIORef False capaReady <- newIORef False tableSize <- newTVarIO 0- maxTableSize <- newIORef 0+ maxTableSize <- newTVarIO 0 let sendIns = send maxHeaderSize <- newIORef maxBound maxBlockedStreams <- newIORef 0@@ -238,13 +240,13 @@ -- | The capacity, as last set. 'getTableCapacity' is how much of it the -- entries take, whatever its name says. getMaxTableCapacity :: DynamicTable -> IO Int-getMaxTableCapacity DynamicTable{..} = readIORef maxTableSize+getMaxTableCapacity DynamicTable{..} = readTVarIO maxTableSize setTableCapacity :: DynamicTable -> Int -> IO () setTableCapacity dyntbl@DynamicTable{..} maxsiz = do qpackDebug dyntbl $ putStrLn $ "setTableCapacity " ++ show maxsiz when (maxN >= 1) $ do- writeIORef maxTableSize maxsiz+ atomically $ writeTVar maxTableSize maxsiz tbl <- atomically $ newArray (0, end) dummyEntry atomically $ do writeTVar maxNumOfEntries maxN@@ -279,7 +281,10 @@ atomically $ do writeTVar maxNumOfEntries maxN writeTVar circularTable tbl- writeIORef maxTableSize cap+ atomically $ writeTVar maxTableSize cap+ -- Lowering the capacity evicts what no longer fits (RFC 9204, section+ -- 3.2.2).+ atomically $ evictDecoder cap dyntbl -- No entry is smaller than 32, so below that nothing can be inserted. writeIORef capaReady (maxN >= 1 && maxNumbers cap >= 1) @@ -321,17 +326,57 @@ resetReference dyntbl ai return ai +-- | Inserting an entry into the decoder's table, within the capacity the+-- encoder set.+--+-- RFC 9204, section 3.2.2: before an entry is added, the oldest entries are+-- evicted until it fits, and an entry larger than the capacity is an error+-- (section 4.3.2, QPACK_ENCODER_STREAM_ERROR). Neither was done: an entry+-- of any size went into the next slot of the ring, which has a slot for each+-- 32 octets of the capacity we announced, so that a peer could have us keep+-- that many entries of a megabyte each -- 128 MB for a capacity of 4096 --+-- and refer to entries a conforming decoder would have evicted.+--+-- No entry is smaller than 32 octets and the capacity is no more than we+-- announced, so the entries left after eviction never fill the ring: the+-- slot an entry goes into holds nothing still in use.+--+-- The capacity is read here, in the same transaction, rather than passed:+-- this is exported from "Network.QPACK.Internal", and its type stays as it+-- was. insertEntryToDecoder :: Entry -> DynamicTable -> STM AbsoluteIndex-insertEntryToDecoder ent DynamicTable{..} = do+insertEntryToDecoder ent dyntbl@DynamicTable{..} = do+ cap <- readTVar maxTableSize+ let siz = entrySize ent+ when (siz > cap) $ throwSTM EncoderInstructionError+ evictDecoder (cap - siz) dyntbl x@(InsertionPoint insp) <- readTVar insertionPoint writeTVar insertionPoint (x + 1) maxN <- readTVar maxNumOfEntries let i = insp `mod` maxN table <- readTVar circularTable unsafeWrite table i ent- modifyTVar' tableSize (+ entrySize ent)+ modifyTVar' tableSize (+ siz) return $ AbsoluteIndex insp +-- | Evicting the oldest entries of the decoder's table until the entries+-- left take no more than the given size.+evictDecoder :: Size -> DynamicTable -> STM ()+evictDecoder target DynamicTable{..} = case codeInfo of+ DecodeInfo{..} -> loop evictedD+ _ -> return ()+ where+ loop evicted = do+ siz <- readTVar tableSize+ when (siz > target) $ do+ AbsoluteIndex ai <- readTVar evicted+ maxN <- readTVar maxNumOfEntries+ table <- readTVar circularTable+ ent <- unsafeRead table (ai `mod` maxN)+ writeTVar tableSize (siz - entrySize ent)+ writeTVar evicted $ AbsoluteIndex (ai + 1)+ loop evicted+ -- | Look up an entry of the dynamic table by absolute index. -- -- The live window is the most recent 'maxNumOfEntries' insertions. An index@@ -352,7 +397,11 @@ -- @ip - maxN@ is negative, which would let a negative index through; the -- index conversions produce those readily, since a pre-base index larger -- than the base gives one.- let lo = max 0 (ip - maxN)+ -- An entry the decoder has evicted is gone too.+ evicted <- case codeInfo of+ DecodeInfo{..} -> (\(AbsoluteIndex ai) -> ai) <$> readTVar evictedD+ _ -> return 0+ let lo = maximum [0, ip - maxN, evicted] when (maxN == 0 || idx < lo || idx >= ip) $ throwSTM $ IllegalDynamicIndex idx@@ -673,7 +722,7 @@ canInsertEntry DynamicTable{..} ent mai = do let siz = entrySize ent tblsiz <- readTVarIO tableSize- maxtblsiz <- readIORef maxTableSize+ maxtblsiz <- readTVarIO maxTableSize if tblsiz + siz <= maxtblsiz then return True@@ -711,7 +760,7 @@ where loop = do tblsize <- readTVarIO tableSize- maxtblsize <- readIORef maxTableSize+ maxtblsize <- readTVarIO maxTableSize unless (tblsize <= maxtblsize) $ do dropped <- tryDrop dyntbl if dropped then loop else error "dropIfNecessary"@@ -845,7 +894,7 @@ size <- calcSize end 0 size0 <- readTVarIO tableSize when (size /= size0) $ error $ "checkAbsoluteIndex: size /= size0) " ++ tag- lim <- readIORef maxTableSize+ lim <- readTVarIO maxTableSize when (size > lim) $ error $ "checkAbsoluteIndex: size > lim " ++ tag putStrLn $ " check: tblsiz: " ++ show size ++ " " ++ show ai ++ " " ++ tag else
http3.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: http3-version: 0.1.7+version: 0.1.8 license: BSD-3-Clause license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -92,7 +92,7 @@ quic >= 0.3.10 && < 0.4, sockaddr, stm,- time-manager >= 0.2.3 && <0.4,+ time-manager >= 0.2.3 && <0.5, utf8-string >=1.0 && <1.1 executable h3-server@@ -208,6 +208,8 @@ HTTP3.Error HTTP3.ErrorSpec HTTP3.FrameSpec+ HTTP3.HandlerSpec+ HTTP3.InformationalSpec HTTP3.LimitSpec HTTP3.Server HTTP3.ServerSpec@@ -242,4 +244,5 @@ network, quic, stm,+ time-manager, tls
test/HTTP3/Error.hs view
@@ -3,6 +3,7 @@ module HTTP3.Error ( h3ErrorSpec,+ h3DrainSpec, ) where import Control.Concurrent@@ -121,16 +122,6 @@ qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "") runC qcc' cconf conf ms `shouldThrow` applicationProtocolErrorsIn [H3MessageError]- it- "MUST treat content that does not match content-length as malformed [HTTP/3 4.1.2]"- $ \_ -> do- -- content-length says five octets and the request carries- -- none. /drain reads the body, which is where the count is- -- checked; a body nobody reads is never counted.- let req = H3.requestNoBody methodPost "/drain" [("content-length", "5")]- qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")- runCReq req qcc' cconf conf0 ms- `shouldThrow` applicationProtocolErrorsIn [H3MessageError] forM_ connectionSpecific $ \field@(name, _) -> it ( "MUST treat a request with "@@ -143,15 +134,6 @@ refusedNotServed (served x) $ runCReq req qcc' cconf conf0 ms `shouldThrow` applicationProtocolErrorsIn [H3MessageError]- it- "MUST treat a request whose trailers carry connection as malformed [HTTP/3 4.2]"- $ \_ -> do- -- /drain reads the body, and so the trailers after it.- let req0 = H3.requestBuilder methodPost "/drain" [] "hello"- req = H3.setRequestTrailersMaker req0 connectionTrailer- qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")- runCReq req qcc' cconf conf0 ms- `shouldThrow` applicationProtocolErrorsIn [H3MessageError] it "MUST accept TE with trailers [HTTP/3 4.2]" $ \_ -> do let req = H3.requestNoBody methodGet "/" [("te", "trailers")] runCReq req qcc cconf conf0 ms `shouldReturn` Just ()@@ -334,6 +316,42 @@ { H3.confQDecoderConfig = (H3.confQDecoderConfig conf){dcMaxTableCapacity = 0} }++-- | The error cases that need the server to read a request's body.+--+-- A server checks content-length, and the fields of trailers, only as its+-- application reads the body; an application that answers without reading+-- it never gets to either, and nothing tells from outside which paths read+-- one. These go to /drain, where our test server reads the body, and so+-- are not part of 'h3ErrorSpec': run against a server elsewhere, as h3spec+-- does, they would fail whatever that server does.+h3DrainSpec+ :: ClientConfig+ -> H3.ClientConfig+ -> Millisecond+ -> SpecWith a+h3DrainSpec qcc cconf ms = do+ conf0 <- runIO H3.allocSimpleConfig+ describe "HTTP/3 servers reading a request's body" $ do+ it+ "MUST treat content that does not match content-length as malformed [HTTP/3 4.1.2]"+ $ \_ -> do+ -- content-length says five octets and the request carries+ -- none. /drain reads the body, which is where the count is+ -- checked; a body nobody reads is never counted.+ let req = H3.requestNoBody methodPost "/drain" [("content-length", "5")]+ qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")+ runCReq req qcc' cconf conf0 ms+ `shouldThrow` applicationProtocolErrorsIn [H3MessageError]+ it+ "MUST treat a request whose trailers carry connection as malformed [HTTP/3 4.2]"+ $ \_ -> do+ -- /drain reads the body, and so the trailers after it.+ let req0 = H3.requestBuilder methodPost "/drain" [] "hello"+ req = H3.setRequestTrailersMaker req0 connectionTrailer+ qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")+ runCReq req qcc' cconf conf0 ms+ `shouldThrow` applicationProtocolErrorsIn [H3MessageError] addHook :: H3.Config -> (H3.Hooks -> H3.Hooks) -> H3.Config addHook conf modify = conf'
test/HTTP3/ErrorSpec.hs view
@@ -14,7 +14,9 @@ spec = beforeAll start $ afterAll (teardown . fst) $- h3ErrorSpec testClientConfig testH3ClientConfig 2000 served -- 2 seconds+ -- 2 seconds+ h3ErrorSpec testClientConfig testH3ClientConfig 2000 served+ >> h3DrainSpec testClientConfig testH3ClientConfig 2000 where served (_, ref) = Just $ readIORef ref start = do
+ test/HTTP3/HandlerSpec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTP3.HandlerSpec where++import qualified Control.Exception as E+import qualified Data.ByteString as B+import Network.HTTP.Types+import qualified Network.HTTP3.Client as C+import Network.HTTP3.Internal (+ ApplicationProtocolError (..),+ StreamResetIsReceived (..),+ )+import Network.HTTP3.Server+import qualified Network.QUIC.Client as QUIC+import System.Timeout (timeout)+import Test.Hspec++import HTTP3.Config+import HTTP3.Server++-- | A server whose handlers time out after a second of not sending.+spec :: Spec+spec = beforeAll (setupShortTimeout server) $ afterAll teardown $ do+ describe "H3 server with a short timeout" $ do+ it "resets a response its handler is killed part-way through" $ \_ -> do+ -- The handler sends some of the body and then nothing: the+ -- timeout kills it. The stream used to be ended with a FIN, and+ -- the client took what it had for the whole body.+ r <- timeout 5000000 $ QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+ E.try $ sendRequest (C.requestNoBody methodGet "/stall" []) $ \rsp -> do+ let drain acc = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return acc else drain (acc <> bs)+ drain ""+ r `shouldBe` Just (Left (StreamResetIsReceived H3InternalError))
+ test/HTTP3/InformationalSpec.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTP3.InformationalSpec where++import qualified Control.Exception as E+import qualified Data.ByteString as B+import Network.HTTP.Types+import qualified Network.HTTP3.Client as C+import Network.HTTP3.Internal (+ ApplicationProtocolError (..),+ H3Frame (..),+ H3FrameType (..),+ )+import Network.HTTP3.Server+import qualified Network.QUIC as Q+import qualified Network.QUIC.Client as QUIC+import System.Timeout (timeout)+import Test.Hspec++import HTTP3.Config+import HTTP3.Server++spec :: Spec+spec = do+ -- Two informational responses, 100 (Continue) and 103 (Early Hints),+ -- each a HEADERS frame of its own, before every response.+ describe "H3 client with informational responses" $+ beforeAll (setupWith (early [continue, earlyHints]) server 4096) $+ afterAll teardown $+ it "takes the final response past informational ones" $ \_ -> do+ -- The first header section was taken for the response,+ -- and the body reader took the next one for trailers: the+ -- client saw a 100 with no body, and the final response+ -- was lost.+ r <- get+ case r of+ Just (Right x) -> x `shouldBe` (Just ok200, "Hello, world!\n")+ _ -> expectationFailure $ "unexpected: " ++ show r+ -- Twenty of them before every response.+ describe "H3 client with too many informational responses" $+ beforeAll (setupWith (early (replicate 20 earlyHints)) server 4096) $+ afterAll teardown $+ it "resets a response with too many informational ones" $ \_ -> do+ -- RFC 9114 sets no limit, and a server could go on sending+ -- them for ever.+ r <- get+ case r of+ Just (Left (Q.ApplicationProtocolErrorIsSent H3ExcessiveLoad _)) ->+ return ()+ _ -> expectationFailure $ "unexpected: " ++ show r+ where+ get :: IO (Maybe (Either Q.QUICException (Maybe Status, B.ByteString)))+ get = timeout 3000000 $ E.try $ QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+ sendRequest (C.requestNoBody methodGet "/" []) $ \rsp -> do+ let drain acc = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return acc else drain (acc <> bs)+ body <- drain ""+ return (C.responseStatus rsp, body)+ early frames conf =+ conf+ { confHooks =+ (confHooks conf){onHeadersFrameCreated = (frames ++)}+ }+ -- Required Insert Count 0 and Base 0, then one field line referring to+ -- the static table: :status 100 is index 63, :status 103 index 24.+ continue = H3Frame H3FrameHeaders "\x00\x00\xff\x00"+ earlyHints = H3Frame H3FrameHeaders "\x00\x00\xd8"
test/HTTP3/Server.hs view
@@ -4,8 +4,10 @@ module HTTP3.Server ( setup, setupWith,+ setupShortTimeout, server, countingServer,+ recordedBody, teardown, trailersMaker, firstTrailerValue,@@ -31,6 +33,8 @@ import Network.HTTP3.Server import qualified Network.QUIC.Server as QUIC import Network.Socket ()+import System.IO.Unsafe (unsafePerformIO)+import qualified System.TimeManager as T import Test.Hspec import HTTP3.Config@@ -55,6 +59,18 @@ run conn (modify conf) svr +-- | 'setup', with handlers timing out after a second of not sending.+setupShortTimeout :: Server -> IO ThreadId+setupShortTimeout svr = do+ sc <- makeTestServerConfig+ tid <- forkIO $ QUIC.run sc loop+ threadDelay 500000 -- give enough time to the server+ return tid+ where+ loop conn = T.withManager 1000000 $ \mgr ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ run conn conf{confTimeoutManager = mgr} svr+ teardown :: ThreadId -> IO () teardown tid = killThread tid @@ -76,6 +92,15 @@ -- frames: the body throws, and the stream is reset. Just "/reset" -> sendResponse (responseStreaming ok200 [] resetAfterOne) []+ -- No content, and a content-length describing content it does not+ -- have: allowed for a 304 (RFC 9114, section 4.1.2).+ Just "/not-modified" ->+ sendResponse (responseNoBody notModified304 bigLength) []+ -- The same for a 200, which is meant to have content: malformed.+ Just "/no-content" -> sendResponse (responseNoBody ok200 bigLength) []+ -- Some of the body, then nothing for longer than the timeout of+ -- 'setupShortTimeout': the handler is killed part-way.+ Just "/stall" -> sendResponse (responseStreaming ok200 [] stall) [] -- A response whose header section is some 2K. Just "/bigheader" -> sendResponse (responseNoBody ok200 [("x-big", B.replicate 2000 0x61)]) []@@ -90,6 +115,15 @@ unless (B.null bs) loop loop sendResponse responseHello []+ -- What the handler made of the body: how long it was, or what it+ -- was told instead of its end ('recordedBody').+ Just "/record" -> do+ let loop n = do+ bs <- getRequestBodyChunk req+ if B.null bs then return n else loop (n + B.length bs)+ r <- E.try $ loop (0 :: Int)+ putMVar recordedBody $ either (\e -> Left (show (e :: E.SomeException))) Right r+ sendResponse responseHello [] -- Answers with the length of the body it read. Just "/length" -> do let loop n = do@@ -98,13 +132,30 @@ n <- loop (0 :: Int) sendResponse (responseLength n) [] _ -> sendResponse responseHello []+ -- No content, as a response to HEAD has, and the content-length of the+ -- GET.+ Just "HEAD" -> sendResponse (responseNoBody ok200 bigLength) [] _ -> sendResponse response405 [] +-- | What the handler of /record made of the body it was sent.+recordedBody :: MVar (Either String Int)+recordedBody = unsafePerformIO newEmptyMVar+{-# NOINLINE recordedBody #-}++bigLength :: ResponseHeaders+bigLength = [("content-length", "1000")]+ responseLength :: Int -> Response responseLength n = responseBuilder ok200 header body where header = [("Content-Type", "text/plain")] body = byteString $ C8.pack $ show n++stall :: (Builder -> IO ()) -> IO () -> IO ()+stall write flush = do+ write $ byteString "partial"+ flush+ threadDelay 10000000 resetAfterOne :: (Builder -> IO ()) -> IO () -> IO () resetAfterOne write flush = do
test/HTTP3/ServerSpec.hs view
@@ -1,20 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-} module HTTP3.ServerSpec where -import Control.Concurrent (threadDelay)+import Control.Concurrent (takeMVar, threadDelay, tryTakeMVar) import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad import qualified Data.ByteString as B import Data.IORef+import Data.List (isInfixOf) import Network.HTTP.Types import qualified Network.HTTP3.Client as C import Network.HTTP3.Internal ( ApplicationProtocolError (..),+ ContentLengthMismatch (..), H3Frame (..), H3FrameType (..),+ StreamResetIsReceived (..), ) import Network.HTTP3.Server import Network.QPACK (@@ -53,6 +57,14 @@ runCancelClient it "cancels a stream reset between two frames" $ \_ -> runResetCancelClient+ it "tells the handler of a request body cut short by a reset" $ \_ ->+ runResetRequestClient+ it "resets a request interrupted before its body is sent" $ \_ ->+ runInterruptedRequestClient+ it "accepts a content-length on a response with no content" $ \_ ->+ runNoContentClient+ it "closes the connection on a stream ending in the middle of a frame" $ \_ ->+ runTruncatedFrameClient it "stops reading a unidirectional stream of an unknown type" $ \_ -> runUnknownStreamClient it "gives back what a stream of an unknown type took of the limit" $ \_ ->@@ -277,15 +289,108 @@ E.bracket allocSimpleConfig freeSimpleConfig $ \conf -> C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do let req = C.requestNoBody methodGet "/reset" []- -- Stream 0, read to what looks like its end.- sendRequest req $ \rsp -> do+ -- Stream 0, read to its reset. That used to look like the+ -- end of the body; it is told as what it is now.+ r <- E.try $ sendRequest req $ \rsp -> do let drain = do bs <- C.getResponseBodyChunk rsp unless (B.null bs) drain drain+ case r of+ -- The body threw: the server's failure, not the+ -- client's. H3_MESSAGE_ERROR was sent for it.+ Left (StreamResetIsReceived e) -> e `shouldBe` H3InternalError+ Right () -> expectationFailure "the reset was taken for the end" threadDelay 100000 bs <- B.concat <$> readIORef sentOnDecoderStream B.elem 0x40 bs `shouldBe` True++-- | A request body that throws part-way, so that the client resets the+-- stream: the handler must not take what it read for the whole body.+runResetRequestClient :: IO ()+runResetRequestClient = do+ _ <- tryTakeMVar recordedBody+ QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+ let req = C.requestStreaming methodPost "/record" [] $ \write flush -> do+ write "partial"+ flush+ threadDelay 100000+ E.throwIO $ userError "body failed"+ _ <- timeout 1000000 $ E.try @E.SomeException $ sendRequest req $ \_ -> return ()+ r <- timeout 2000000 $ takeMVar recordedBody+ r `shouldSatisfy` \x -> case x of+ Just (Left e) -> "StreamResetIsReceived" `isInfixOf` e+ _ -> False++-- | A request interrupted by 'timeout' while its body is still being sent:+-- the server must not take the part of it that arrived for the whole body.+-- The stream used to be closed with a FIN; it is reset now, with+-- H3_REQUEST_CANCELLED.+runInterruptedRequestClient :: IO ()+runInterruptedRequestClient = do+ _ <- tryTakeMVar recordedBody+ QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+ let req = C.requestStreaming methodPost "/record" [] $ \write flush -> do+ write "partial"+ flush+ threadDelay 2000000+ timeout 300000 (sendRequest req $ \_ -> return ())+ `shouldReturn` Nothing+ r <- timeout 2000000 $ takeMVar recordedBody+ r+ `shouldBe` Just+ (Left (show (StreamResetIsReceived H3RequestCancelled)))++-- | Responses with no content and a content-length of 1000: to HEAD, and a+-- 304. The client checked the empty body against it and refused them with+-- ContentLengthMismatch. A 200 like that is malformed still.+runNoContentClient :: IO ()+runNoContentClient =+ QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+ let body rsp = do+ bs <- C.getResponseBodyChunk rsp+ if B.null bs then return "" else (bs <>) <$> body rsp+ get method path =+ sendRequest (C.requestNoBody method path []) $ \rsp ->+ (,) (C.responseStatus rsp) <$> body rsp+ get methodHead "/" `shouldReturn` (Just ok200, "")+ get methodGet "/not-modified" `shouldReturn` (Just notModified304, "")+ get methodGet "/no-content" `shouldThrow` \e -> case e of+ ContentLengthMismatch 1000 0 -> True+ _ -> False++-- | A POST whose DATA frame claims 100 octets and has 10 when the stream+-- ends (RFC 9114, section 7.1: a connection error of type H3_FRAME_ERROR).+-- Written by hand on a stream of its own, the HEADERS frame referring to the+-- static table only.+runTruncatedFrameClient :: IO ()+runTruncatedFrameClient = do+ r <- timeout 3000000 $ E.try $ QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \_sendRequest _aux -> do+ strm <- Q.stream conn+ Q.sendStream strm $ headersFrame <> dataPart+ Q.shutdownStream strm+ threadDelay 1000000+ case r of+ Just (Left (Q.ApplicationProtocolErrorIsReceived H3FrameError _)) -> return ()+ _ -> expectationFailure $ "unexpected: " ++ show r+ where+ -- Required Insert Count 0 and Base 0, then :method POST (static 20),+ -- :scheme https (23), :path with "/drain", :authority with "localhost".+ section =+ B.pack [0x00, 0x00, 0xd4, 0xd7, 0x51, 6]+ <> "/drain"+ <> B.pack [0x50, 9]+ <> "localhost"+ headersFrame = B.pack [0x01, fromIntegral (B.length section)] <> section+ dataPart = B.pack [0x00, 0x40, 100] <> B.replicate 10 0x61 -- | The client's QPACK decoder stream: its third unidirectional stream, after -- the control stream and the encoder stream.
test/QPACK/HeaderBlockSpec.hs view
@@ -5,6 +5,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async import Control.Concurrent.STM+import qualified Control.Exception as E import Control.Monad import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8@@ -15,6 +16,7 @@ import Network.QPACK.Internal ( DecoderInstruction (..), EncoderInstruction (..),+ EncoderInstructionError (..), encodeDecoderInstructions, encodeEncoderInstructions, )@@ -33,15 +35,66 @@ mapM_ roundTrip [1000, 2100, 8000, 20000] it "encodes a field larger than the encoder's buffers" $ do- -- With the default 4096-octet buffers. 4083 is the value that+ -- With the default 4096-octet buffers. 1011 is the value that -- makes the field come to exactly the buffer by the encoder's- -- estimate, which used to loop forever; anything larger was- -- refused with BufferOverrun. 100000 is also long enough for- -- its Huffman code to need a four-octet length.- forM_ [4083, 4084, 10000, 100000] $ \n -> do+ -- estimate ('tokenHeaderSize': four times the octets, plus 32);+ -- one like it used to loop forever, and anything larger was+ -- refused with BufferOverrun. 4083 was that value when the+ -- estimate was the raw length plus 8. 100000 is also long+ -- enough for its Huffman code to need a four-octet length.+ forM_ [1011, 1012, 4083, 4084, 10000, 100000] $ \n -> do r <- timeout 5000000 $ roundTripWith defaultQEncoderConfig n void r `shouldBe` Just () + it "keeps the tables in step when Huffman makes a value longer" $ do+ -- The encoder sized its chunks by the raw length of the fields,+ -- but Huffman coding, tried in place, makes octets above 0x7f+ -- three to four times longer. A value of 1500 of them overran+ -- the 4096-octet buffers after an entry earlier in the chunk had+ -- gone into the encoder's table, its insertion still unsent: the+ -- next section referred to an entry the decoder never got, and+ -- waited for it for ever.+ r <- timeout 5000000 $ withConnectedPair $ \enc dec -> do+ let small = [(toToken "x-a", "foo")]+ big n = small ++ [(toToken "x-b", BS.replicate n 0xff)]+ sections = [small, big 1500, small] ++ map big [500, 1000 .. 6000] ++ [small]+ forM_ (zip [0, 4 ..] sections) $ \(sid, hdr) -> do+ blk <- enc sid hdr+ (ths, _) <- dec sid blk+ ths `shouldBe` hdr+ r `shouldBe` Just ()++ it "refuses at once an encoder instruction too long to be valid" $ do+ -- Its length says it inserts an entry larger than any capacity+ -- the decoder allows. It used to be decoded again from its+ -- beginning with each piece of it that arrived, and kept for as+ -- long as the peer went on.+ -- Insert with literal name "x", not in Huffman, its value+ -- declared to be 1000000 octets: 127 and the rest in 7-bit+ -- groups.+ let ei =+ BS.pack ([0x41, 0x78, 0x7f] ++ varint (1000000 - 127 :: Int))+ <> BS.replicate 10000 0x61+ varint n+ | n < 128 = [fromIntegral n]+ | otherwise = fromIntegral (n `mod` 128 + 128) : varint (n `div` 128)+ ref <- newIORef $ BS.take 10000 ei+ let recv n = atomicModifyIORef' ref $ \bs -> let (a, b) = BS.splitAt n bs in (b, a)+ (_, handleEI) <- newQDecoder defaultQDecoderConfig (\_ -> return ())+ r <- timeout 1000000 $ E.try $ handleEI recv+ r `shouldBe` Just (Left EncoderInstructionError)++ it "takes encoder instructions arriving an octet at a time" $ do+ -- Each is decoded once it is all there. A value of 4000 octets is+ -- near what the default capacity of 4096 takes.+ r <- timeout 5000000 $ withConnectedPairBy 1 $ \enc dec ->+ forM_ (zip [0, 4 ..] [100, 100, 4000, 4000]) $ \(sid, n) -> do+ let hdr = [(toToken "x-big", C8.replicate n 'a')]+ blk <- enc sid hdr+ (ths, _) <- dec sid blk+ ths `shouldBe` hdr+ r `shouldBe` Just ()+ it "agrees with the decoder on MaxEntries when the encoder uses less" $ do -- The decoder offers 64K, the encoder settles for 4K. Required -- Insert Count is encoded against the 64K both ends know about;@@ -297,6 +350,36 @@ (ths, _) <- dec 0 blk lookup (toToken "x-big") ths `shouldBe` Just val return blk++-- | An encoder and a decoder with the default configurations, each one's+-- instructions carried to the other.+withConnectedPair :: (QEncoder -> QDecoder -> IO a) -> IO a+withConnectedPair = withConnectedPairBy maxBound++-- | Like 'withConnectedPair', the encoder's instructions reaching the+-- decoder no more than the given number of octets at a time.+withConnectedPairBy :: Int -> (QEncoder -> QDecoder -> IO a) -> IO a+withConnectedPairBy chunk body = do+ eiQ <- newTQueueIO+ diQ <- newTQueueIO+ (enc, handleDI, tblop) <-+ newQEncoder defaultQEncoderConfig (atomically . writeTQueue eiQ)+ (dec, handleEI) <-+ newQDecoder defaultQDecoderConfig (atomically . writeTQueue diQ)+ -- What the decoder's SETTINGS would carry.+ setCapacity tblop $ dcMaxTableCapacity defaultQDecoderConfig+ setBlockedStreams tblop 100+ pendingEI <- newIORef ""+ let recvFrom q _ = atomically $ readTQueue q+ recvEI n = do+ bs0 <- readIORef pendingEI+ bs <- if BS.null bs0 then atomically (readTQueue eiQ) else return bs0+ let (a, b) = BS.splitAt (min n chunk) bs+ writeIORef pendingEI b+ return a+ withAsync (handleEI recvEI) $ \_ ->+ withAsync (handleDI $ recvFrom diQ) $ \_ ->+ body enc dec roundTripMany :: Int -> Int -> Int -> IO () roundTripMany encCap decCap n = do
test/QPACK/InstructionSpec.hs view
@@ -2,7 +2,8 @@ module QPACK.InstructionSpec where -import Data.ByteString ()+import Control.Monad (forM_)+import qualified Data.ByteString as BS import Network.HTTP.Semantics import Network.QPACK.Internal import Test.Hspec@@ -23,6 +24,29 @@ bs2 <- encodeEncoderInstructions eis0 False (eis2, "") <- decodeEncoderInstructions' bs2 eis2 `shouldBe` eis0+ describe "encoderInstructionLength" $ do+ it "tells the length of the first instruction once it can" $ do+ let eis =+ [ SetDynamicTableCapacity 4096+ , SetDynamicTableCapacity 1000000+ , InsertWithNameReference (Left 92) "Warp/4.3.2.1"+ , InsertWithNameReference (Right 1000) (BS.replicate 300 0xff)+ , InsertWithLiteralName tokenContentType "text/plain"+ , InsertWithLiteralName tokenContentType (BS.replicate 3000 0x61)+ , Duplicate 40+ , Duplicate 100000+ ]+ forM_ [True, False] $ \huff ->+ forM_ eis $ \ei -> do+ e <- encodeEncoderInstructions [ei] huff+ next <- encodeEncoderInstructions [Duplicate 1] huff+ let len = BS.length e+ encoderInstructionLength e `shouldBe` Just len+ encoderInstructionLength (e <> next) `shouldBe` Just len+ -- Short of it: not yet known, or known right.+ forM_ [0 .. len - 1] $ \k ->+ encoderInstructionLength (BS.take k e)+ `shouldSatisfy` maybe True (== len) describe "encodeDecoderInstructions and decodeDecoderInstructions" $ do it "encode/decodes decode instructions properly" $ do let eis0 =
test/QPACK/TableSpec.hs view
@@ -1,7 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module QPACK.TableSpec where import Control.Concurrent.STM import qualified Control.Exception as E+import Control.Monad (forM_, replicateM_)+import qualified Data.ByteString as BS+import Network.HPACK.Internal (toEntryToken)+import Network.HPACK.Token (toToken) import Network.QPACK.Internal import Test.Hspec import Test.Hspec.QuickCheck@@ -24,6 +31,47 @@ look 1000 `shouldReturn` Left (IllegalStaticIndex 1000) look (-1) `shouldReturn` Left (IllegalStaticIndex (-1)) + describe "the decoder's table" $ do+ -- An entry is 32 octets more than its name and value: "x" and n+ -- octets of value come to n + 33.+ let entry n = toEntryToken (toToken "x") (BS.replicate n 0x61)+ -- MaxEntries from an announced capacity of 4096, and the+ -- capacity the encoder set.+ newTable cap = do+ dyntbl <- newDynamicTableForDecoding 2048 (\_ -> return ())+ setMaxEntries dyntbl 4096+ setDecoderTableCapacity dyntbl cap+ return dyntbl+ insert dyntbl n = atomically $ insertEntryToDecoder (entry n) dyntbl+ present dyntbl i = do+ r <- E.try $ atomically (toDynamicEntry dyntbl (AbsoluteIndex i)) >>= E.evaluate+ return $ either (\(_ :: E.SomeException) -> False) (const True) r+ it "refuses an entry larger than the capacity" $ do+ dyntbl <- newTable 100+ insert dyntbl 68 `shouldThrow` (== EncoderInstructionError)+ -- One that fits exactly is taken.+ _ <- insert dyntbl 67+ getTableCapacity dyntbl `shouldReturn` 100+ it "evicts the oldest entries to make room" $ do+ dyntbl <- newTable 100+ -- 60 octets each: only one fits.+ replicateM_ 2 $ insert dyntbl 27+ present dyntbl 0 `shouldReturn` False+ present dyntbl 1 `shouldReturn` True+ getTableCapacity dyntbl `shouldReturn` 60+ it "evicts what no longer fits when the capacity is lowered" $ do+ dyntbl <- newTable 4096+ replicateM_ 3 $ insert dyntbl 27+ setDecoderTableCapacity dyntbl 100+ mapM (present dyntbl) [0, 1, 2] `shouldReturn` [False, False, True]+ getTableCapacity dyntbl `shouldReturn` 60+ it "holds no more than the capacity whatever is inserted" $ do+ -- A slot for each 32 octets of 4096, and entries of 4000 octets:+ -- the ring took 128 of them, half a megabyte.+ dyntbl <- newTable 4096+ forM_ [1 .. 200 :: Int] $ \_ -> insert dyntbl 4000+ getTableCapacity dyntbl >>= (`shouldSatisfy` (<= 4096))+ mapM (present dyntbl) [198, 199] `shouldReturn` [False, True] describe "encodeRequiredInsertCount and decodeRequiredInsertCount" $ do prop "duality" $ \(Triple m ei di) -> do let ereq = encodeRequiredInsertCount m (RequiredInsertCount ei)