http3 0.1.5 → 0.1.6

raw patch · 21 files changed

+1397/−122 lines, 21 filesdep ~http2dep ~quicPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: http2, quic

API changes (from Hackage documentation)

Files

• ChangeLog.md +40/−0
• Network/HTTP3/Client.hs +48/−18
• Network/HTTP3/Context.hs +83/−9
• Network/HTTP3/Control.hs +6/−1
• Network/HTTP3/Error.hs +10/−0
• Network/HTTP3/Recv.hs +53/−4
• Network/HTTP3/Send.hs +14/−1
• Network/HTTP3/Server.hs +46/−25
• Network/QPACK.hs +114/−22
• Network/QPACK/Error.hs +23/−0
• Network/QPACK/HeaderBlock/Decode.hs +41/−5
• Network/QPACK/HeaderBlock/Encode.hs +12/−4
• Network/QPACK/HeaderBlock/Prefix.hs +5/−3
• Network/QPACK/Table/Dynamic.hs +124/−17
• http3.cabal +4/−3
• test/HTTP3/Config.hs +17/−0
• test/HTTP3/Error.hs +99/−0
• test/HTTP3/LimitSpec.hs +58/−0
• test/HTTP3/Server.hs +37/−3
• test/HTTP3/ServerSpec.hs +241/−0
• test/QPACK/HeaderBlockSpec.hs +322/−7

@@ -1,5 +1,45 @@ # Revision history for http3 +## 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`.+ ## 0.1.5  * Security fixes.  Requiring http2 v5.4.5, whose HPACK integer decoder is

@@ -35,7 +35,6 @@ import Control.Concurrent import qualified Control.Exception as E 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@@ -90,31 +89,62 @@         | QUIC.isServerInitiatedUnidirectional sid =             forkManaged ctx "H3 client: unidirectional handler" $                 unidirectional ctx strm-        | otherwise = return () -- push?+        -- Server-initiated bidirectional.  RFC 9114, section 6.1: "Clients+        -- MUST treat receipt of a server-initiated bidirectional stream as a+        -- connection error of type H3_STREAM_CREATION_ERROR unless such an+        -- extension has been negotiated."+        | otherwise = abort ctx H3StreamCreationError       where         sid = QUIC.streamId strm  sendRequest     :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a-sendRequest ctx scm auth (Request outobj) processResponse =+sendRequest ctx scm auth (Request outobj) processResponse = do+    -- RFC 9114, section 4.2.2: an endpoint "SHOULD NOT send an HTTP message+    -- 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-        forkManagedTimeout ctx "H3 client: sendRequest" $ \th -> do-            sendHeader ctx strm th hdr'-            sendBody ctx strm th outobj-            QUIC.shutdownStream strm+        forkManagedTimeout ctx "H3 client: sendRequest" $ \th ->+            ( do+                sendHeader ctx strm th hdr'+                sendBody ctx strm th outobj+                QUIC.shutdownStream strm+            )+                -- What goes wrong here is thrown away with the thread, and+                -- the request would be left half sent, with the response+                -- awaited for good.  Trailers too large for the peer are one+                -- such thing.+                `E.catch` \se -> case E.fromException se of+                    _ | isAsyncException se -> E.throwIO se+                    -- The sending part is closed: the server asked us with+                    -- STOP_SENDING to stop, and it has had its RESET_STREAM+                    -- for that already, or we are done with the stream.+                    -- The response may be on its way yet, and resetting+                    -- here takes the stream out of the table, after which+                    -- whatever arrives for it is thrown away: the response+                    -- would be awaited for good.+                    Just QUIC.StreamIsClosed -> return ()+                    _ -> QUIC.resetStream strm H3RequestCancelled         src <- newSource strm         let sid = QUIC.streamId strm-        mvt <- recvHeader ctx sid src-        case mvt of-            Nothing -> do-                QUIC.resetStream strm H3MessageError-                threadDelay 100000-                -- just for type inference-                E.throwIO $ QUIC.ApplicationProtocolErrorIsSent H3MessageError ""-            Just vt@(_, valtbl) -> do-                (readB, refH) <- newBodyReader ctx sid src valtbl-                let rsp = Response $ InpObj vt Nothing readB refH-                processResponse rsp+        (`E.finally` cancelUnlessReadToEnd ctx sid src) $ do+            mvt <- recvHeader ctx sid src+            case mvt of+                Nothing -> do+                    QUIC.resetStream strm H3MessageError+                    threadDelay 100000+                    -- just for type inference+                    E.throwIO $ QUIC.ApplicationProtocolErrorIsSent H3MessageError ""+                Just vt+                    -- Malformed (RFC 9114, section 4.2).+                    | Just name <- connectionSpecificField vt -> do+                        QUIC.resetStream strm H3MessageError+                        E.throwIO $ ConnectionSpecificField name+                Just vt@(_, valtbl) -> do+                    (readB, refH) <- newBodyReader ctx sid src valtbl+                    let rsp = Response $ InpObj vt Nothing readB refH+                    processResponse rsp   where     hdr = outObjHeaders outobj     isIPv6 = isJust (readMaybe auth :: Maybe IPv6)

@@ -5,6 +5,7 @@     Context,     withContext,     unidirectional,+    cancelStream,     isH3Server,     isH3Client,     accept,@@ -20,6 +21,7 @@     getMySockAddr,     getPeerSockAddr,     getMaxFieldSectionSize,+    getPeerMaxFieldSectionSize,     forkManaged,     forkManagedTimeout,     forkManagedTimeoutFinally,@@ -31,12 +33,13 @@ import Data.IORef import Network.HTTP.Semantics.Client import Network.QUIC-import Network.QUIC.Internal (connDebugLog, isClient, isServer)+import Network.QUIC.Internal (isClient, isServer) import Network.Socket (SockAddr) import qualified System.ThreadManager as T  import Network.HTTP3.Config import Network.HTTP3.Control+import Network.HTTP3.Error import Network.HTTP3.Frame import Network.HTTP3.Stream import Network.QPACK@@ -55,6 +58,11 @@     , ctxMaxFieldSectionSize :: Int     -- ^ What we told the peer we would accept, and so the most of any one     -- frame we are willing to hold in memory while it arrives.+    , ctxCancelStream :: StreamId -> IO ()+    , ctxPeerMaxFieldSectionSize :: IO Int+    -- ^ The peer's SETTINGS_MAX_FIELD_SECTION_SIZE, or 'maxBound' until its+    -- SETTINGS have arrived+    -- ^ Sending a Stream Cancellation on our QPACK decoder stream     }  withContext :: Connection -> Config -> (Context -> IO a) -> IO a@@ -70,18 +78,34 @@     (ctxQDecoder, handleEI) <- newQDecoder (confQDecoderConfig conf) sendDI     let ctxMaxFieldSectionSize = dcMaxFieldSectionSize $ confQDecoderConfig conf     ctl <- controlStream conn ctxMaxFieldSectionSize dyntblE <$> newIORef IInit+    let ctxPeerMaxFieldSectionSize = getHeaderSize dyntblE+    seen <- newIORef []     info <- getConnectionInfo conn     let handleDI' recv = handleDI recv `E.catch` abortWith QpackDecoderStreamError         handleEI' recv = handleEI recv `E.catch` abortWith QpackEncoderStreamError-        ctxUniSwitch = switch conn ctl handleEI' handleDI'+        ctxUniSwitch = switch conn seen ctl handleEI' handleDI'         ctxPReadMaker = confPositionReadMaker conf         ctxHooks = confHooks conf         ctxMySockAddr = localSockAddr info         ctxPeerSockAddr = remoteSockAddr info+    let ctxCancelStream sid+            -- RFC 9204, section 4.4.2: "A decoder with a maximum dynamic table+            -- capacity equal to zero MAY omit sending Stream Cancellations",+            -- since the encoder then has nothing to release.+            | dcMaxTableCapacity (confQDecoderConfig conf) == 0 = return ()+            | otherwise =+                -- The stream is being given up on, and so, quite possibly, is+                -- the connection; there is nobody to report a failure to.+                (encodeDecoderInstructions [StreamCancellation sid] >>= sendDI)+                    `E.catch` ignoreSync     ctxThreadManager <- T.newThreadManager $ confTimeoutManager conf     let ctxConnection = conn     return Context{..}   where+    ignoreSync :: E.SomeException -> IO ()+    ignoreSync se+        | isAsyncException se = E.throwIO se+        | otherwise = return ()     abortWith :: ApplicationProtocolError -> E.SomeException -> IO ()     abortWith aerr se         | isAsyncException se = E.throwIO se@@ -93,18 +117,47 @@         Just (E.SomeAsyncException _) -> True         Nothing -> False +-- | The handler for a unidirectional stream the peer opened, by its type.+--+-- The control stream and the two QPACK streams are critical: a peer may open+-- each of them only once (RFC 9114, section 6.2.1; RFC 9204, section 4.2),+-- and may not close any of them.  The control stream handler sees to the+-- closing itself; the QPACK ones are library code that simply returns when+-- the stream ends. switch     :: Connection+    -> IORef [H3StreamType]+    -- ^ The critical streams the peer has opened so far     -> InstructionHandler     -> InstructionHandler     -> InstructionHandler     -> H3StreamType     -> InstructionHandler-switch conn ctl handleEI handleDI styp-    | styp == H3ControlStreams = ctl-    | styp == QPACKEncoderStream = handleEI-    | styp == QPACKDecoderStream = handleDI-    | otherwise = \_ -> connDebugLog conn "switch unknown stream type"+switch conn seen ctl handleEI handleDI styp = case styp of+    H3ControlStreams -> once ctl+    QPACKEncoderStream -> once $ closing handleEI+    QPACKDecoderStream -> once $ closing handleDI+    -- RFC 9114, section 6.2.2: "Only servers can push; if a server receives+    -- a client-initiated push stream, this MUST be treated as a connection+    -- error of type H3_STREAM_CREATION_ERROR."  And section 4.6: a client+    -- "MUST treat receipt of a push stream as a connection error of type+    -- H3_ID_ERROR when no MAX_PUSH_ID frame has been sent", which this client+    -- never does.+    H3PushStreams+        | isServer conn -> \_ -> abortConnection conn H3StreamCreationError ""+        | otherwise -> \_ -> abortConnection conn H3IdError ""+    -- 'unidirectional' does not get here with an unknown type.+    H3StreamTypeUnknown _ -> \_ -> return ()+  where+    once, closing :: InstructionHandler -> InstructionHandler+    once handler recv = do+        dup <- atomicModifyIORef' seen $ \ts -> (styp : ts, styp `elem` ts)+        if dup+            then abortConnection conn H3StreamCreationError ""+            else handler recv+    closing handler recv = do+        handler recv+        abortConnection conn H3ClosedCriticalStream ""  isH3Server :: Context -> Bool isH3Server Context{..} = isServer ctxConnection@@ -121,6 +174,9 @@ qpackDecode :: Context -> QDecoder qpackDecode Context{..} = ctxQDecoder +cancelStream :: Context -> StreamId -> IO ()+cancelStream Context{..} = ctxCancelStream+ unidirectional :: Context -> Stream -> IO () unidirectional Context{..} strm = do     -- The type is a variable-length integer (RFC 9114, section 6.2), so one,@@ -132,8 +188,23 @@         -- The peer opened a unidirectional stream and closed it without         -- saying what it was for.  Nothing to dispatch to; this used to be a         -- pattern match failure.-        Nothing -> return ()-        Just i -> ctxUniSwitch (toH3StreamType i) (recvStream strm)+        --+        -- Closed here, as below, because only a stream we close is counted+        -- as done with, and so given back to the peer's limit on the+        -- unidirectional streams it may open.  One left unclosed is lost to+        -- it for good.+        Nothing -> closeStream strm+        Just i -> case toH3StreamType i of+            -- RFC 9114, section 6.2: "Recipients of unknown stream types MUST+            -- either abort reading of the stream or discard incoming data+            -- without further processing.  If reading is aborted, the+            -- recipient SHOULD use the H3_STREAM_CREATION_ERROR error code".+            -- Neither was done: whatever the peer sent was left where it+            -- arrived, for as long as the connection lasted.+            H3StreamTypeUnknown _ -> do+                stopStream strm H3StreamCreationError+                closeStream strm+            styp -> ctxUniSwitch styp (recvStream strm)  withHandle :: Context -> (T.Handle -> IO ()) -> IO () withHandle Context{..} action = void $ T.withHandle ctxThreadManager (return ()) action@@ -170,3 +241,6 @@  getMaxFieldSectionSize :: Context -> Int getMaxFieldSectionSize = ctxMaxFieldSectionSize++getPeerMaxFieldSectionSize :: Context -> IO Int+getPeerMaxFieldSectionSize = ctxPeerMaxFieldSectionSize

@@ -6,6 +6,7 @@     controlStream, ) where +import Control.Concurrent.MVar import qualified Data.ByteString as BS import Data.IORef import Data.IntSet (IntSet)@@ -47,7 +48,11 @@     H3.onControlStreamCreated hooks sC     H3.onEncoderStreamCreated hooks sE     H3.onDecoderStreamCreated hooks sD-    return (sendStream sE, sendStream sD)+    -- Every request stream writes acknowledgements and cancellations to the+    -- decoder stream, and an instruction must not be split by another one.+    -- quic sends a write in two pieces when flow control stops it partway.+    lockD <- newMVar ()+    return (sendStream sE, \bs -> withMVar lockD $ \_ -> sendStream sD bs)   where     stC = mkType H3ControlStreams     stE = mkType QPACKEncoderStream

@@ -2,6 +2,7 @@  module Network.HTTP3.Error (     ContentLengthMismatch (..),+    ConnectionSpecificField (..),     ApplicationProtocolError (         H3NoError,         H3GeneralProtocolError,@@ -24,6 +25,7 @@ ) where  import qualified Control.Exception as E+import Data.ByteString (ByteString) import Network.QUIC  -- | A message whose content does not match the content-length it declared.@@ -40,6 +42,14 @@     deriving (Eq, Show)  instance E.Exception ContentLengthMismatch++-- | A message carrying a connection-specific field, named here, which makes+--   it malformed (RFC 9114, section 4.2).  Thrown where 'ContentLengthMismatch'+--   is, and handled the same way.+newtype ConnectionSpecificField = ConnectionSpecificField ByteString+    deriving (Eq, Show)++instance E.Exception ConnectionSpecificField  {- FOURMOLU_DISABLE -} pattern H3NoError                :: ApplicationProtocolError

@@ -8,6 +8,8 @@     readSource',     recvHeader,     newBodyReader,+    cancelUnlessReadToEnd,+    connectionSpecificField, ) where  import qualified Control.Exception as E@@ -22,13 +24,32 @@ import Network.HTTP3.Frame  data Source = Source-    { sourceRead :: IO ByteString+    { sourceStream :: Stream+    , sourceRead :: IO ByteString     , sourcePending :: IORef (Maybe ByteString)+    , sourceReadToEnd :: IORef Bool+    -- ^ Whether the body reader has come to the end of the stream between two+    -- frames, and so has processed every field section on it.     }  newSource :: Stream -> IO Source-newSource strm = Source (recvStream strm 1024) <$> newIORef Nothing+newSource strm =+    Source strm (recvStream strm 1024) <$> newIORef Nothing <*> newIORef False +-- | Telling the peer's QPACK encoder, unless the stream has been read to its+--   end, that the field sections left on it will never be processed (RFC 9204,+--   section 4.4.2): until it is told, it keeps the entries they refer to.+--+-- A stream the peer reset has not been read to its end, even if it looks so:+-- the reset reads as an end, and one that lands between two frames used to+-- be taken for the real thing.  Nothing is lost by telling an encoder about a+-- stream it has nothing outstanding on.+cancelUnlessReadToEnd :: Context -> StreamId -> Source -> IO ()+cancelUnlessReadToEnd ctx sid Source{..} = do+    done <- readIORef sourceReadToEnd+    reset <- isJust <$> resetReceived sourceStream+    when (not done || reset) $ cancelStream ctx sid+ readSource :: Source -> IO ByteString readSource Source{..} = do     mx <- readIORef sourcePending@@ -79,6 +100,25 @@                         loop IInit -- dummy                 st' -> loop st' +-- | The first connection-specific field in a field section, if any.+--+-- RFC 9114, section 4.2: "An endpoint MUST NOT generate an HTTP/3 field+-- section containing connection-specific fields; any message containing+-- connection-specific fields MUST be treated as malformed."  It names+-- Connection, Keep-Alive, Proxy-Connection, Transfer-Encoding and Upgrade,+-- and lets TE through only with the value "trailers".  Everything else a+-- Connection field could name is a connection-specific field too, but then+-- the Connection field is there to be refused.+connectionSpecificField :: TokenHeaderTable -> Maybe ByteString+connectionSpecificField (ths, vt)+    | isJust (getFieldValue tokenConnection vt) = Just "connection"+    | isJust (getFieldValue tokenTransferEncoding vt) = Just "transfer-encoding"+    | maybe False (/= "trailers") (getFieldValue tokenTE vt) = Just "te"+    | otherwise = find (`elem` byName) $ map (foldedCase . tokenKey . fst) ths+  where+    -- No tokens of their own.+    byName = ["keep-alive", "proxy-connection", "upgrade"]+ -- | A body reader for one message, and the place its trailers will appear. -- -- The reader counts what it hands out and checks the total against@@ -126,7 +166,11 @@     loop st = do         bs <- readSource src         if bs == ""-            then endOfBody+            then do+                -- Not in the middle of a frame, which would mean it was cut+                -- off.+                when (st == IInit) $ writeIORef (sourceReadToEnd src) True+                endOfBody             else case parseH3Frame lim st bs of                 ITooLong _ _ -> do                     abort ctx H3ExcessiveLoad@@ -143,12 +187,17 @@                         writeIORef refI IInit                         -- pushbackSource src leftover -- fixme                         hdr <- qpackDecode ctx sid payload+                        forM_ (connectionSpecificField hdr) $+                            E.throwIO . ConnectionSpecificField                         writeIORef refH $ Just hdr                         endOfBody                     | typ == H3FrameData -> do                         writeIORef refI IInit                         pushbackSource src leftover-                        chunk payload+                        -- A DATA frame may be empty (RFC 9114, section+                        -- 7.2.1), and "" is how the end of the body is told+                        -- to the reader.  Go on to the next frame instead.+                        if BS.null payload then loop IInit else chunk payload                     | permittedInRequestStream typ -> do                         pushbackSource src leftover                         loop IInit

@@ -3,6 +3,7 @@  module Network.HTTP3.Send (     sendHeader,+    checkHeaderSize,     sendBody, ) where @@ -11,7 +12,6 @@ import qualified Data.ByteString.Internal as BS import Data.IORef import Foreign.ForeignPtr-import Network.HPACK.Internal (toTokenHeaderTable) import Network.HTTP.Semantics.Client import Network.HTTP.Semantics.IO import qualified Network.HTTP.Types as HT@@ -21,6 +21,19 @@ import Imports import Network.HTTP3.Context import Network.HTTP3.Frame+import Network.QPACK++-- | Refusing a header section the peer said it would not take, before+--   anything is opened or sent.+--+-- The encoder refuses it too, but on a client that happens in the thread+-- sending the request, which has nobody to tell.+checkHeaderSize :: Context -> HT.RequestHeaders -> IO ()+checkHeaderSize ctx hdrs = do+    (ths, _) <- toTokenHeaderTable hdrs+    lim <- getPeerMaxFieldSectionSize ctx+    let siz = fieldSectionSize ths+    when (siz > lim) $ E.throwIO $ FieldSectionTooLargeForPeer siz lim  sendHeader :: Context -> Stream -> T.Handle -> HT.ResponseHeaders -> IO () sendHeader ctx strm th hdrs = do

@@ -33,7 +33,6 @@ import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Exception as E-import Data.IORef import GHC.Conc.Sync import Network.HTTP.Semantics import Network.HTTP.Semantics.Server@@ -48,7 +47,6 @@ import Network.HTTP3.Config import Network.HTTP3.Context import Network.HTTP3.Error-import Network.HTTP3.Frame import Network.HTTP3.Recv import Network.HTTP3.Send import Network.QPACK@@ -105,37 +103,45 @@     -> IO () processRequest ctx server strm th = E.handle reset $ do     src <- newSource strm-    mvt <- recvHeader ctx sid src-    case mvt of-        Nothing -> QUIC.resetStream strm H3MessageError-        Just ht -> do-            mreq <- mkRequest ctx strm src ht-            case mreq of-                -- Malformed; 'mkRequest' has reset the stream.-                Nothing -> return ()-                Just req -> do-                    let aux =-                            defaultAux-                                { auxTimeHandle = th-                                , auxMySockAddr = getMySockAddr ctx-                                , auxPeerSockAddr = getPeerSockAddr ctx-                                }-                    server req aux $ sendResponse ctx strm th+    (`E.finally` cancelUnlessReadToEnd ctx sid src) $ do+        emvt <- E.try $ recvHeader ctx sid src+        case emvt of+            Left FieldSectionTooLarge -> refuseTooLarge ctx strm th+            Right Nothing -> QUIC.resetStream strm H3MessageError+            Right (Just ht) -> do+                mreq <- mkRequest ctx strm src ht+                case mreq of+                    -- Malformed; 'mkRequest' has reset the stream.+                    Nothing -> return ()+                    Just req -> do+                        let aux =+                                defaultAux+                                    { auxTimeHandle = th+                                    , auxMySockAddr = getMySockAddr ctx+                                    , auxPeerSockAddr = getPeerSockAddr ctx+                                    }+                        server req aux $ sendResponse ctx strm th   where     sid = QUIC.streamId strm     reset se         | isAsyncException se = 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  processRequestIO :: Context -> ((Stream, Request) -> IO ()) -> Stream -> IO () processRequestIO ctx put strm = E.handle reset $ do     src <- newSource strm-    mvt <- recvHeader ctx sid src-    case mvt of-        Nothing -> QUIC.resetStream strm H3MessageError-        Just ht -> do+    emvt <- E.try $ recvHeader ctx sid src+    case emvt of+        Left FieldSectionTooLarge ->+            void $ withHandle ctx $ refuseTooLarge ctx strm+        Right Nothing -> QUIC.resetStream strm H3MessageError+        Right (Just ht) -> do             mreq <- mkRequest ctx strm src ht             case mreq of                 Nothing -> return ()@@ -148,6 +154,19 @@             abort ctx QpackDecompressionFailed         | otherwise = QUIC.resetStream strm H3MessageError +-- | Answering a request whose header section is more than we said we would+--   take.+--+-- RFC 9114, section 4.2.2: "A server that receives a larger field section+-- than it is willing to handle can send an HTTP 431 (Request Header Fields+-- Too Large) status code".  What is left of the request is not wanted, and+-- section 4.1.1 lets a server say so with STOP_SENDING and H3_NO_ERROR.+refuseTooLarge :: Context -> Stream -> T.Handle -> IO ()+refuseTooLarge ctx strm th = do+    QUIC.stopStream strm H3NoError+    sendHeader ctx strm th [(":status", "431")]+    QUIC.shutdownStream strm+ -- | Build the 'Request', or reset the stream and answer 'Nothing' when the -- message is malformed. --@@ -168,12 +187,14 @@         mScheme = getFieldValue tokenScheme vt         mAuthority = getFieldValue tokenAuthority vt         mPath = getFieldValue tokenPath vt+        malformed = do+            QUIC.resetStream strm H3MessageError+            return Nothing     case (mMethod, mScheme, mAuthority, mPath) of+        _ | isJust (connectionSpecificField ht) -> malformed         (Just "CONNECT", _, Just _, _) -> Just <$> build         (Just _, Just _, Just _, Just _) -> Just <$> build-        _ -> do-            QUIC.resetStream strm H3MessageError-            return Nothing+        _ -> malformed   where     build = do         let sid = QUIC.streamId strm

@@ -9,6 +9,7 @@     QEncoder,     newQEncoder,     TableOperation (..),+    fieldSectionSize,      -- ** Encoder for debugging     QEncoderS,@@ -19,6 +20,8 @@     defaultQDecoderConfig,     QDecoder,     newQDecoder,+    FieldSectionTooLarge (..),+    FieldSectionTooLargeForPeer (..),      -- ** Decoder for debugging     QDecoderS,@@ -104,8 +107,19 @@     { setCapacity :: Int -> IO ()     , setBlockedStreams :: Int -> IO ()     , setHeaderSize :: Int -> IO ()+    , getHeaderSize :: IO Int+    -- ^ The peer's SETTINGS_MAX_FIELD_SECTION_SIZE, or 'maxBound' until it+    -- is known     } +-- | The size of a field section as SETTINGS_MAX_FIELD_SECTION_SIZE counts+--   it: the lengths of each name and value plus 32 for every field (RFC+--   9114, section 4.2.2).+fieldSectionSize :: TokenHeaderList -> Int+fieldSectionSize = foldl' (\n (t, v) -> n + keyLength t + BS.length v + 32) 0+  where+    keyLength = BS.length . CI.original . tokenKey+ ----------------------------------------------------------------  -- | Configuration for QPACK encoder.@@ -151,36 +165,45 @@                 ecUseHuffman                 dyntbl                 lock-        handler = decoderInstructionHandler dyntbl+        handler = decoderInstructionHandler dyntbl lock         ctl =             TableOperation-                { setCapacity = \n -> do+                { setCapacity = \n -> withMVar lock $ \_ -> do                     -- "n" is decoder-proposed size via settings.+                    -- It, not the capacity chosen below, determines+                    -- MaxEntries.+                    setMaxEntries dyntbl n                     let tableSize = min ecMaxTableCapacity n                     setTableCapacity dyntbl tableSize                     ins <- encodeEncoderInstructions [SetDynamicTableCapacity tableSize] False                     sendIns dyntbl ins                 , setBlockedStreams = setMaxBlockedStreams dyntbl                 , setHeaderSize = setMaxHeaderSize dyntbl+                , getHeaderSize = getMaxHeaderSize dyntbl                 }     return (enc, handler, ctl)  tokenHeaderSize :: TokenHeader -> Int tokenHeaderSize (t, v) = BS.length (CI.original (tokenKey t)) + BS.length v + 8 -- adhoc overhead +-- | Taking as many fields as fit in @lim@, but always at least one.+--+-- A field that does not fit on its own makes a chunk by itself, which+-- 'encodeChunk' gives buffers of its own.  It used to be refused with+-- 'BufferOverrun' -- so a value of 4K or so could not be sent at all -- and+-- one that came to exactly @lim@ produced an empty chunk and left the rest+-- as it was, so 'splitThrough' went round forever. split :: Int -> TokenHeaderList -> (TokenHeaderList, TokenHeaderList) split lim ts = split' 0 ts   where     split' _ [] = ([], [])     split' s xxs@(x : xs)-        | siz > lim = E.throw BufferOverrun-        | s' < lim =+        | s /= 0 && s' > lim = ([], xxs)+        | otherwise =             let (ys, zs) = split' s' xs              in (x : ys, zs)-        | otherwise = ([], xxs)       where-        siz = tokenHeaderSize x-        s' = s + siz+        s' = s + tokenHeaderSize x  splitThrough :: Int -> TokenHeaderList -> [TokenHeaderList] splitThrough lim ts0 = loop ts0 id@@ -190,6 +213,33 @@       where         (ts1, ts2) = split lim ts +-- | 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.+encodeChunk+    :: Buffer+    -> BufferSize+    -> Buffer+    -> BufferSize+    -> Bool+    -> DynamicTable+    -> TokenHeaderList+    -> IO (ByteString, [AbsoluteIndex])+encodeChunk buf1 bufsiz1 buf2 bufsiz2 huff dyntbl ts+    | siz <= min bufsiz1 bufsiz2 =+        qpackEncodeHeader buf1 bufsiz1 buf2 bufsiz2 huff dyntbl ts+    | otherwise = do+        let bufsiz = siz * 4 + 64+        gcbuf1 <- mallocPlainForeignPtrBytes bufsiz+        gcbuf2 <- mallocPlainForeignPtrBytes bufsiz+        withForeignPtr gcbuf1 $ \b1 ->+            withForeignPtr gcbuf2 $ \b2 ->+                qpackEncodeHeader b1 bufsiz b2 bufsiz huff dyntbl ts+  where+    siz = sum $ map tokenHeaderSize ts+ qpackEncoder     :: GCBuffer     -> Int@@ -199,7 +249,11 @@     -> DynamicTable     -> MVar ()     -> QEncoder-qpackEncoder gcbuf1 bufsiz1 gcbuf2 bufsiz2 huff dyntbl lock sid ts =+qpackEncoder gcbuf1 bufsiz1 gcbuf2 bufsiz2 huff dyntbl lock sid ts = do+    -- Before anything is inserted or counted.+    lim <- getMaxHeaderSize dyntbl+    let siz0 = fieldSectionSize ts+    when (siz0 > lim) $ E.throwIO $ FieldSectionTooLargeForPeer siz0 lim     withMVar lock $ \_ ->         withForeignPtr gcbuf1 $ \buf1 ->             withForeignPtr gcbuf2 $ \buf2 -> do@@ -209,15 +263,20 @@                         "---- Stream " ++ show sid ++ " " ++ "tblsiz: " ++ show siz                 setBasePointToInsersionPoint dyntbl                 clearRequiredInsertCount dyntbl-                let tss = splitThrough bufsiz1 ts-                his <- mapM (qpackEncodeHeader buf1 bufsiz1 buf2 bufsiz2 huff dyntbl) tss+                let tss = splitThrough (min bufsiz1 bufsiz2) ts+                his <- mapM (encodeChunk buf1 bufsiz1 buf2 bufsiz2 huff dyntbl) tss                 let (hbs, daiss) = unzip his                 prefix <- qpackEncodePrefix buf1 bufsiz1 dyntbl                 let section = BS.concat (prefix : hbs)                 reqInsCnt <- getRequiredInsertCount dyntbl                 -- To count only blocked sections,                 -- dont' register this section if reqInsCnt == 0.-                when (reqInsCnt /= 0) $+                when (reqInsCnt /= 0) $ do+                    -- Counted against the decoder's+                    -- SETTINGS_QPACK_BLOCKED_STREAMS, which+                    -- 'checkBlockedStreams' consults while encoding.+                    blocked <- wouldSectionBeBlocked dyntbl reqInsCnt+                    when blocked $ insertBlockedStreamE dyntbl sid                     insertSection dyntbl sid $                         Section reqInsCnt $                             concat daiss@@ -242,8 +301,8 @@                         "---- Stream " ++ show sid ++ " " ++ "tblsiz: " ++ show siz                 setBasePointToInsersionPoint dyntbl                 clearRequiredInsertCount dyntbl-                let tss = splitThrough bufsiz1 ts-                his <- mapM (qpackEncodeHeader buf1 bufsiz1 buf2 bufsiz2 huff dyntbl) tss+                let tss = splitThrough (min bufsiz1 bufsiz2) ts+                his <- mapM (encodeChunk buf1 bufsiz1 buf2 bufsiz2 huff dyntbl) tss                 let (hbs, daiss) = unzip his                 prefix <- qpackEncodePrefix buf1 bufsiz1 dyntbl                 let section = BS.concat (prefix : hbs)@@ -260,6 +319,7 @@                         -- The same logic of SectionAcknowledgement.                         updateKnownReceivedCount dyntbl reqInsCnt                         mapM_ (decreaseReference dyntbl) dais+                        _ <- getAndDelSection dyntbl sid                         deleteBlockedStreamE dyntbl sid                 -- Need to emulate InsertCountIncrement since                 -- SectionAcknowledgement is not returned if@@ -297,18 +357,28 @@     toByteString wbuf1  -- Note: dyntbl for encoder-decoderInstructionHandler :: DynamicTable -> DecoderInstructionHandler-decoderInstructionHandler dyntbl recv = loop ""+--+-- The lock is the encoder's.  Acknowledgements change the same reference+-- counts, sections and blocked streams that encoding reads and writes, with+-- plain reads and writes rather than atomic ones; run beside an encoding in+-- progress, an update could be lost and an entry either kept forever or+-- evicted while a field section still referred to it.+decoderInstructionHandler+    :: DynamicTable -> MVar () -> DecoderInstructionHandler+decoderInstructionHandler dyntbl lock recv = loop ""   where+    -- Returns when the stream ends, with an instruction cut short or not.+    -- Going on with what was left over used to spin: the same incomplete+    -- instruction, decoded again after every empty read.     loop bs0 = do         bs1 <- recv 1024         let bs                 | bs0 == "" = bs1                 | otherwise = bs0 <> bs1-        when (bs /= "") $ do+        when (bs1 /= "") $ do             (ins, leftover) <- decodeDecoderInstructions bs             qpackDebug dyntbl $ mapM_ print ins-            mapM_ handle ins+            withMVar lock $ \_ -> mapM_ handle ins             loop leftover     handle (SectionAcknowledgement sid) = do         msec <- getAndDelSection dyntbl sid@@ -317,11 +387,25 @@             Just (Section reqInsCnt ais) -> do                 updateKnownReceivedCount dyntbl reqInsCnt                 mapM_ (decreaseReference dyntbl) ais-                deleteBlockedStreamE dyntbl sid-    handle (StreamCancellation _n) = return () -- fixme+                -- Not simply deleted: a later section on the same stream+                -- may still be blocked.+                unblockStreamsE dyntbl+    -- The decoder will not process the rest of the stream (RFC 9204, section+    -- 4.4.2), so its outstanding field sections will never be acknowledged.+    -- Their references are released as an acknowledgement would release+    -- them, but the Known Received Count stays where it is: nothing about+    -- which insertions arrived is learnt from this.  Ignoring it used to keep+    -- the entries those sections referred to from ever being evicted, and the+    -- stream counted as blocked for good.+    handle (StreamCancellation sid) = do+        secs <- getAndDelSections dyntbl sid+        forM_ secs $ \(Section _ ais) -> mapM_ (decreaseReference dyntbl) ais+        unblockStreamsE dyntbl     handle (InsertCountIncrement n)         | n == 0 = E.throwIO DecoderInstructionError-        | otherwise = incrementKnownReceivedCount dyntbl n+        | otherwise = do+            incrementKnownReceivedCount dyntbl n+            unblockStreamsE dyntbl  ---------------------------------------------------------------- @@ -338,6 +422,7 @@     gcbuf1 <- mallocPlainForeignPtrBytes bufsiz1     gcbuf2 <- mallocPlainForeignPtrBytes bufsiz2     dyntbl <- newDynamicTableForEncoding saveEI+    setMaxEntries dyntbl ecMaxTableCapacity     setTableCapacity dyntbl ecMaxTableCapacity     setMaxBlockedStreams dyntbl blocked     setImmediateAck dyntbl immediateAck@@ -386,7 +471,10 @@ newQDecoder QDecoderConfig{..} sendDI = do     dyntbl <-         newDynamicTableForDecoding dcHuffmanBufferSize sendDI+    setMaxEntries dyntbl dcMaxTableCapacity     setMaxBlockedStreams dyntbl dcBlockedSterams+    -- What we announce as SETTINGS_MAX_FIELD_SECTION_SIZE.+    setMaxHeaderSize dyntbl dcMaxFieldSectionSize     let dec = qpackDecoder dyntbl         handler = encoderInstructionHandler dcMaxTableCapacity dyntbl     return (dec, handler)@@ -400,7 +488,10 @@ newQDecoderS QDecoderConfig{..} sendDI debug = do     dyntbl <-         newDynamicTableForDecoding dcHuffmanBufferSize sendDI+    setMaxEntries dyntbl dcMaxTableCapacity     setMaxBlockedStreams dyntbl dcBlockedSterams+    -- What we announce as SETTINGS_MAX_FIELD_SECTION_SIZE.+    setMaxHeaderSize dyntbl dcMaxFieldSectionSize     setDebugQPACK dyntbl debug     let dec = qpackDecoderS dyntbl         handler = encoderInstructionHandlerS dcMaxTableCapacity dyntbl@@ -430,12 +521,13 @@ encoderInstructionHandler :: Int -> DynamicTable -> EncoderInstructionHandler encoderInstructionHandler decCapLim dyntbl recv = loop ""   where+    -- Returns when the stream ends; see 'decoderInstructionHandler'.     loop bs0 = do         bs1 <- recv 1024         let bs                 | bs0 == "" = bs1                 | otherwise = bs0 <> bs1-        when (bs /= "") $ do+        when (bs1 /= "") $ do             leftover <- encoderInstructionHandlerS decCapLim dyntbl bs             loop leftover @@ -453,7 +545,7 @@     handle ins@(SetDynamicTableCapacity n)         | n > decCapLim = E.throwIO EncoderInstructionError         | otherwise = do-            setTableCapacity dyntbl n+            setDecoderTableCapacity dyntbl n             qpackDebug dyntbl $ print ins             return 0     handle ins@(InsertWithNameReference ii val) = do

@@ -8,6 +8,8 @@         QpackDecoderStreamError     ),     DecodeError (..),+    FieldSectionTooLarge (..),+    FieldSectionTooLargeForPeer (..),     EncoderInstructionError (..),     DecoderInstructionError (..), ) where@@ -35,11 +37,32 @@     | BlockedStreamsOverflow     deriving (Eq, Show) +-- | A field section that decodes to more than the+--   SETTINGS_MAX_FIELD_SECTION_SIZE we announced (RFC 9114, section 4.2.2).+--+-- Not a 'DecodeError': nothing is wrong with the encoding, and the+-- connection can go on.  The size is counted as the RFC counts it, the+-- lengths of each name and value plus 32 for every field.+data FieldSectionTooLarge = FieldSectionTooLarge+    deriving (Eq, Show)++-- | A field section more than the peer's SETTINGS_MAX_FIELD_SECTION_SIZE,+--   which "SHOULD NOT" be sent (RFC 9114, section 4.2.2).  Thrown by the+--   encoder before it touches anything, so nothing has been sent or changed.+data FieldSectionTooLargeForPeer = FieldSectionTooLargeForPeer+    { sectionSize :: Int+    -- ^ As the limit counts it+    , peerLimit :: Int+    }+    deriving (Eq, Show)+ data EncoderInstructionError = EncoderInstructionError     deriving (Eq, Show) data DecoderInstructionError = DecoderInstructionError     deriving (Eq, Show)  instance E.Exception DecodeError+instance E.Exception FieldSectionTooLarge+instance E.Exception FieldSectionTooLargeForPeer instance E.Exception EncoderInstructionError instance E.Exception DecoderInstructionError

@@ -6,7 +6,9 @@ import qualified Control.Exception as E import qualified Data.ByteString.Char8 as BS8 import Data.CaseInsensitive+import Data.IORef import Network.ByteOrder+import qualified Network.HPACK as HPACK import Network.HPACK.Internal (     HuffmanDecoder,     decodeH,@@ -32,14 +34,25 @@ decodeTokenHeader dyntbl rbuf = do     (reqInsertCount, bp, needAck) <- decodePrefix rbuf dyntbl     ready <- checkRequiredInsertCountNB dyntbl reqInsertCount-    unless ready $ do+    -- The count of blocked streams has to come down however the wait ends.+    -- A stream reset while waiting kills the thread, and the count left up+    -- counted a stream that was not there any more: once as many had gone as+    -- SETTINGS_QPACK_BLOCKED_STREAMS allows, every section that had to wait+    -- was refused.+    unless ready $ E.mask $ \restore -> do         ok <- tryIncreaseStreams dyntbl         unless ok $ E.throwIO BlockedStreamsOverflow-        checkRequiredInsertCount dyntbl reqInsertCount-        decreaseStreams dyntbl+        restore (checkRequiredInsertCount dyntbl reqInsertCount)+            `E.finally` decreaseStreams dyntbl     checkRequiredInsertCount dyntbl reqInsertCount     hufdec <- newHuffmanDecoder rbuf-    tbl <- decodeSophisticated (toTokenHeader dyntbl bp hufdec) rbuf+    dec <- limitFieldSection dyntbl $ toTokenHeader dyntbl bp hufdec+    -- HPACK's decoder refuses a section of more than 200 fields, which is+    -- the same thing as far as we are concerned: more than we will take.+    tbl <-+        decodeSophisticated dec rbuf `E.catch` \e -> case e of+            HPACK.TooLargeHeader -> E.throwIO FieldSectionTooLarge+            _ -> E.throwIO e     return (tbl, needAck)  decodeTokenHeaderS@@ -52,9 +65,32 @@     if ok         then do             hufdec <- newHuffmanDecoder rbuf-            hs <- decodeSimple (toTokenHeader dyntbl bp hufdec) rbuf+            dec <- limitFieldSection dyntbl $ toTokenHeader dyntbl bp hufdec+            hs <- decodeSimple dec rbuf             return $ Just (hs, needAck)         else return Nothing++-- | A field line decoder that stops once the section comes to more than we+--   said we would take.+--+-- The length of a HEADERS frame is capped, but that bounds the section only+-- as it is encoded.  A field line of a couple of octets can refer to a+-- dynamic table entry as large as the table, so a frame within the cap could+-- decode to many megabytes.  Counting field by field stops that before it is+-- built, and holds one section to the limit plus one field.+limitFieldSection+    :: DynamicTable+    -> (Word8 -> ReadBuffer -> IO TokenHeader)+    -> IO (Word8 -> ReadBuffer -> IO TokenHeader)+limitFieldSection dyntbl dec = do+    lim <- getMaxHeaderSize dyntbl+    ref <- newIORef 0+    return $ \w8 rbuf -> do+        th@(t, v) <- dec w8 rbuf+        let siz = BS8.length (original (tokenKey t)) + BS8.length v + 32+        total <- atomicModifyIORef' ref $ \n -> (n + siz, n + siz)+        when (total > lim) $ E.throwIO FieldSectionTooLarge+        return th  -- | A Huffman decoder with room for anything the rest of this field section -- can decode to.

@@ -152,11 +152,17 @@                 encodeIndexed wbuf1 dyntbl hi                 increaseReference dyntbl ai                 return $ Just ai-        K hi@(SIndex i) -> tryInsertVal hi $ do+        K hi@(SIndex i) -> tryInsertVal hi id $ do             insertWithNameReference val ent Nothing $ Left i         K hi@(DIndex ai) -> do             qpackDebug dyntbl $ checkAbsoluteIndex dyntbl ai "K (1)"-            withDIndex ai $ tryInsertVal hi $ do+            -- Only a field line referring to the entry can block the+            -- stream.  The insertion refers to it on the encoder stream,+            -- which never blocks anything (RFC 9204, section 2.1.1), so it+            -- is only the fallback that has to be guarded.  Guarding the+            -- whole of it gave up inserting whenever the name was in an+            -- entry not yet acknowledged and this stream could not block.+            tryInsertVal hi (withDIndex ai) $ do                 ridx <- toInsRelativeIndex ai <$> getInsertionPoint dyntbl                 insertWithNameReference val ent (Just ai) $ Right ridx         N -> tryInsertKeyVal $ insertWithLiteralName val ent@@ -203,7 +209,9 @@                 return $ Just ai             else encodeLiteralFieldLineStatic -    tryInsertVal hi action = do+    -- 'guardRef' wraps the fallback, a field line with a reference to the+    -- name, which is where a reference to the dynamic table can block.+    tryInsertVal hi guardRef action = do         -- Field representation MUST not refer to a dropped entry         -- on insertion.         let possiblelyDropMySelf = case hi of@@ -212,7 +220,7 @@         ok <- checkExistenceAndSpace ent key val possiblelyDropMySelf "Val"         if ok             then action-            else do+            else guardRef $ do                 -- 4.5.4/4.5.5                 encodeWithNameReference wbuf1 dyntbl hi val huff                 case hi of

@@ -40,7 +40,9 @@ decodeRequiredInsertCount     :: Int -> InsertionPoint -> Int -> RequiredInsertCount decodeRequiredInsertCount _ _ 0 = 0-decodeRequiredInsertCount 0 _ n = RequiredInsertCount (n - 1)+-- With no dynamic table, nothing but 0 can be encoded (RFC 9204, section+-- 4.5.1.1).+decodeRequiredInsertCount 0 _ _ = E.throw IllegalInsertCount decodeRequiredInsertCount maxEntries (InsertionPoint totalNumberOfInserts) encodedInsertCount     | encodedInsertCount > fullRange = E.throw IllegalInsertCount     | reqInsertCount > maxValue && reqInsertCount <= fullRange =@@ -83,7 +85,7 @@ encodePrefix :: WriteBuffer -> DynamicTable -> IO () encodePrefix wbuf dyntbl = do     clearWriteBuffer wbuf-    maxEntries <- getMaxNumOfEntries dyntbl+    maxEntries <- getMaxEntries dyntbl     baseIndex <- getBasePoint dyntbl     reqInsCnt <- getRequiredInsertCount dyntbl     qpackDebug dyntbl $ print reqInsCnt@@ -101,7 +103,7 @@ decodePrefix     :: ReadBuffer -> DynamicTable -> IO (RequiredInsertCount, BasePoint, Bool) decodePrefix rbuf dyntbl = do-    maxEntries <- getMaxNumOfEntries dyntbl+    maxEntries <- getMaxEntries dyntbl     totalNumberOfInserts <- getInsertionPoint dyntbl     w8 <- read8 rbuf     ric <- decodeI 8 w8 rbuf

@@ -11,7 +11,10 @@     isTableReady,     getTableCapacity,     setTableCapacity,+    setDecoderTableCapacity,     getMaxNumOfEntries,+    getMaxEntries,+    setMaxEntries,      -- * Entry     insertEntryToDecoder,@@ -22,6 +25,7 @@     Section (..),     insertSection,     getAndDelSection,+    getAndDelSections,     increaseReference,     decreaseReference, @@ -34,6 +38,7 @@     -- * Blocked streams     insertBlockedStreamE,     deleteBlockedStreamE,+    unblockStreamsE,     checkBlockedStreams,      -- * Required insert count@@ -97,6 +102,8 @@ import Data.IORef import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap+import Data.Sequence (Seq, ViewL (..), viewl, (|>))+import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set -- Set.size is O(1), IntSet.size is O(n) import Imports@@ -135,7 +142,7 @@         , drainingPoint       :: IORef AbsoluteIndex         , knownReceivedCount  :: TVar Int         , referenceCounters   :: IORef (IOArray Index Reference)-        , sections            :: IORef (IntMap Section)+        , sections            :: IORef (IntMap (Seq Section)) -- oldest first         , lruCache            :: LRUCacheRef (FieldName, FieldValue) ()         , immediateAck        :: IORef Bool -- for QIF         , blockedStreamsE     :: IORef (Set Int)@@ -152,6 +159,7 @@     { codeInfo          :: CodeInfo     , insertionPoint    :: TVar InsertionPoint     , maxNumOfEntries   :: TVar Int+    , maxEntries        :: IORef Int -- MaxEntries of RFC 9204 section 4.5.1.1     , circularTable     :: TVar Table     , basePoint         :: IORef BasePoint     , debugQPACK        :: IORef Bool@@ -206,6 +214,7 @@     let codeInfo = info     insertionPoint <- newTVarIO 0     maxNumOfEntries <- newTVarIO 0+    maxEntries <- newIORef 0     circularTable <- newTVarIO tbl     basePoint <- newIORef 0     debugQPACK <- newIORef False@@ -245,9 +254,47 @@     maxN = maxNumbers maxsiz     end = maxN - 1 +-- | Setting the capacity of the decoder's table, as the encoder instructs.+--+-- The encoder may change the capacity whenever it likes, within the maximum+-- the decoder announced (RFC 9204, section 3.2.3), and the entries in the+-- table stay where they are.  So the ring is allocated once, for as many+-- entries as the maximum allows ('setMaxEntries'), and a later change only+-- moves the capacity.  Reallocating it, as 'setTableCapacity' does, emptied+-- the table and changed what the absolute indices map onto: references to+-- entries inserted before the change came back as a dummy entry.+setDecoderTableCapacity :: DynamicTable -> Int -> IO ()+setDecoderTableCapacity dyntbl@DynamicTable{..} cap = do+    qpackDebug dyntbl $ putStrLn $ "setDecoderTableCapacity " ++ show cap+    maxN <- readIORef maxEntries+    allocated <- (>= 1) <$> readTVarIO maxNumOfEntries+    when (not allocated && maxN >= 1) $ do+        tbl <- atomically $ newArray (0, maxN - 1) dummyEntry+        atomically $ do+            writeTVar maxNumOfEntries maxN+            writeTVar circularTable tbl+    writeIORef maxTableSize cap+    -- No entry is smaller than 32, so below that nothing can be inserted.+    writeIORef capaReady (maxN >= 1 && maxNumbers cap >= 1)+ getMaxNumOfEntries :: DynamicTable -> IO Int getMaxNumOfEntries DynamicTable{..} = readTVarIO maxNumOfEntries +-- | MaxEntries, which the Required Insert Count of a field section is+-- encoded and decoded against (RFC 9204, section 4.5.1.1).+--+-- It comes from the decoder's SETTINGS_QPACK_MAX_TABLE_CAPACITY, not from the+-- capacity the encoder actually set.  The two ends agree on the former; the+-- latter is only the encoder's choice within it, and using it here made the+-- two ends disagree once more than 2*MaxEntries entries had been inserted.+getMaxEntries :: DynamicTable -> IO Int+getMaxEntries DynamicTable{..} = readIORef maxEntries++-- | Setting MaxEntries from the decoder's maximum table capacity.+setMaxEntries :: DynamicTable -> Int -> IO ()+setMaxEntries DynamicTable{..} maxCapacity =+    writeIORef maxEntries $ maxNumbers maxCapacity+ ----------------------------------------------------------------  insertEntryToEncoder :: Entry -> DynamicTable -> IO AbsoluteIndex@@ -308,23 +355,44 @@  ---------------------------------------------------------------- +-- | Registering a field section which awaits acknowledgement.+--+-- A stream can have more than one outstanding -- headers and trailers, say --+-- and a Section Acknowledgement is for the oldest of them (RFC 9204, section+-- 4.4.1), so they are queued rather than keyed by the stream alone.  Keyed+-- alone, the second replaced the first, whose references were then never+-- released, and the second acknowledgement found nothing and was taken for a+-- decoder stream error. insertSection :: DynamicTable -> StreamId -> Section -> IO () insertSection DynamicTable{..} sid section = atomicModifyIORef' sections ins   where     ins m =-        let m' = IntMap.insert sid section m+        let m' = IntMap.insertWith (\_ old -> old |> section) sid (Seq.singleton section) m          in (m', ())     EncodeInfo{..} = codeInfo +-- | Taking out the oldest outstanding field section of a stream. getAndDelSection :: DynamicTable -> StreamId -> IO (Maybe Section) getAndDelSection DynamicTable{..} sid = atomicModifyIORef' sections getAndDel   where-    getAndDel m =-        let (msec, m') = IntMap.updateLookupWithKey f sid m-         in (m', msec)-    f _ _ = Nothing -- delete the entry if found+    getAndDel m = case IntMap.lookup sid m of+        Nothing -> (m, Nothing)+        Just q -> case viewl q of+            EmptyL -> (IntMap.delete sid m, Nothing)+            sec :< rest+                | Seq.null rest -> (IntMap.delete sid m, Just sec)+                | otherwise -> (IntMap.insert sid rest m, Just sec)     EncodeInfo{..} = codeInfo +-- | Taking out every outstanding field section of a stream.+getAndDelSections :: DynamicTable -> StreamId -> IO [Section]+getAndDelSections DynamicTable{..} sid = atomicModifyIORef' sections getAndDel+  where+    getAndDel m = case IntMap.lookup sid m of+        Nothing -> (m, [])+        Just q -> (IntMap.delete sid m, toList q)+    EncodeInfo{..} = codeInfo+ increaseReference :: DynamicTable -> AbsoluteIndex -> IO () increaseReference = modifyReference $ \(Reference c t) -> Reference (c + 1) (t + 1) @@ -366,8 +434,9 @@ tryIncreaseStreams :: DynamicTable -> IO Bool tryIncreaseStreams DynamicTable{..} = do     lim <- readIORef maxBlockedStreams-    curr <- atomicModifyIORef' blockedStreamsD (\n -> (n + 1, n + 1))-    return (curr <= lim)+    -- Counted only if it is let in, since nothing takes a refused one off.+    atomicModifyIORef' blockedStreamsD $ \n ->+        if n < lim then (n + 1, True) else (n, False)   where     DecodeInfo{..} = codeInfo @@ -386,16 +455,34 @@  insertBlockedStreamE :: DynamicTable -> StreamId -> IO () insertBlockedStreamE DynamicTable{..} sid =-    modifyIORef' blockedStreamsE (Set.insert sid)+    atomicModifyIORef' blockedStreamsE (\set -> (Set.insert sid set, ()))   where     EncodeInfo{..} = codeInfo  deleteBlockedStreamE :: DynamicTable -> StreamId -> IO () deleteBlockedStreamE DynamicTable{..} sid =-    modifyIORef' blockedStreamsE (Set.delete sid)+    atomicModifyIORef' blockedStreamsE (\set -> (Set.delete sid set, ()))   where     EncodeInfo{..} = codeInfo +-- | Forgetting the blocked streams that the known received count has caught+-- up with.+--+-- A stream stops being blocked once the decoder holds every entry its+-- section refers to (RFC 9204, section 2.1.2), which an Insert Count+-- Increment can say as well as a Section Acknowledgement.  Waiting for the+-- acknowledgement alone would be safe but would keep a stream counted for as+-- long as it is never acknowledged -- forever, for one that was reset.+unblockStreamsE :: DynamicTable -> IO ()+unblockStreamsE DynamicTable{..} = do+    krc <- readTVarIO knownReceivedCount+    secs <- readIORef sections+    let blocking (Section (RequiredInsertCount ric) _) = ric > krc+        stillBlocked sid = maybe False (any blocking) $ IntMap.lookup sid secs+    atomicModifyIORef' blockedStreamsE (\set -> (Set.filter stillBlocked set, ()))+  where+    EncodeInfo{..} = codeInfo+ checkBlockedStreams :: DynamicTable -> IO Bool checkBlockedStreams dyntbl = do     maxBlocked <- getMaxBlockedStreams dyntbl@@ -464,7 +551,10 @@ wouldInstructionBeBlocked :: DynamicTable -> AbsoluteIndex -> IO Bool wouldInstructionBeBlocked DynamicTable{..} (AbsoluteIndex ai) = atomically $ do     krc <- readTVar knownReceivedCount-    return (ai > krc)+    -- The decoder is known to hold entries 0 .. krc-1, so a reference to+    -- krc itself is still one it may not have.  This is the same test as+    -- 'wouldSectionBeBlocked', whose Required Insert Count is ai + 1.+    return (ai >= krc)   where     EncodeInfo{..} = codeInfo @@ -532,8 +622,10 @@     maxN <- readTVarIO maxNumOfEntries     let i = ai `mod` maxN     -- modifyArray' is not provided by GHC 9.4 or earlier, sigh.-    Reference current total <- unsafeRead arr i-    if current == 0 && total >= tailDuplicationThreshold+    ref@(Reference _ total) <- unsafeRead arr i+    krc <- readTVarIO knownReceivedCount+    -- Duplicating it evicts it, so it has to be evictable.+    if evictable krc ai ref && total >= tailDuplicationThreshold         then return $ Just dai         else return Nothing   where@@ -558,6 +650,19 @@  ---------------------------------------------------------------- +-- | Whether the entry at an absolute index may be evicted, given the Known+--   Received Count (RFC 9204, section 2.1.1): once its insertion has been+--   acknowledged and no unacknowledged field section refers to it.+--+-- Whether it was ever referred to has nothing to do with it.  This used to+-- ask for that instead of the acknowledgement, which kept an entry nothing+-- referred to for good -- and, since entries go oldest first, every entry+-- after it too, so that the table filled up and took nothing new for the+-- rest of the connection.  An encoder inserts such an entry whenever it may+-- not block another stream and so writes the field out literally.+evictable :: Int -> Int -> Reference -> Bool+evictable krc ai (Reference current _) = current == 0 && ai < krc+ canInsertEntry :: DynamicTable -> Entry -> Maybe AbsoluteIndex -> IO Bool canInsertEntry DynamicTable{..} ent mai = do     let siz = entrySize ent@@ -583,8 +688,9 @@                     maxN <- readTVarIO maxNumOfEntries                     let i = ai `mod` maxN                     refs <- readIORef referenceCounters-                    Reference current total <- unsafeRead refs i-                    if current == 0 && total >= 1+                    ref <- unsafeRead refs i+                    krc <- readTVarIO knownReceivedCount+                    if evictable krc ai ref                         then do                             table <- readTVarIO circularTable                             dent <- atomically $ unsafeRead table i@@ -613,8 +719,9 @@         then do             let i = ai `mod` maxN             refs <- readIORef referenceCounters-            Reference current total <- unsafeRead refs i-            if current == 0 && total >= 1+            ref <- unsafeRead refs i+            krc <- readTVarIO knownReceivedCount+            if evictable krc ai ref                 then do                     table <- readTVarIO circularTable                     ent <- atomically $ do

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               http3-version:            0.1.5+version:            0.1.6 license:            BSD-3-Clause license-file:       LICENSE maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>@@ -83,13 +83,13 @@         containers,         http-semantics >= 0.4 && <0.5,         http-types,-        http2 >=5.4.5 && <5.5,+        http2 >=5.4.6 && <5.5,         iproute >= 1.7 && < 1.8,         network,         network-byte-order,         network-control >= 0.1.7 && <0.2,         psqueues,-        quic >= 0.3.0 && < 0.4,+        quic >= 0.3.9 && < 0.4,         sockaddr,         stm,         time-manager >= 0.2.3 && <0.4,@@ -208,6 +208,7 @@         HTTP3.Error         HTTP3.ErrorSpec         HTTP3.FrameSpec+        HTTP3.LimitSpec         HTTP3.Server         HTTP3.ServerSpec         QPACK.HeaderBlockSpec

@@ -4,8 +4,10 @@     makeTestServerConfig,     testClientConfig,     testH3ClientConfig,+    waitForSettings, ) where +import Control.Concurrent (threadDelay) import Data.ByteString (ByteString) import qualified Data.List as L import qualified Network.HTTP3.Client as H3@@ -30,6 +32,11 @@ testServerConfig =     defaultServerConfig         { scAddresses = [("127.0.0.1", 8003)]+        , -- Room for more unidirectional streams than the three a client+          -- needs, so that a test can open a second control or QPACK stream+          -- and see it refused.  The default of three leaves no room for one.+          scParameters =+            (scParameters defaultServerConfig){initialMaxStreamsUni = 10}         }  testClientConfig :: ClientConfig@@ -53,3 +60,13 @@  testH3ClientConfig :: H3.ClientConfig testH3ClientConfig = H3.defaultClientConfig{H3.authority = "127.0.0.1"}++-- | Giving the peer's SETTINGS time to take effect, after a round trip.+--+-- A response is no sign that they have: they come on the control stream,+-- and that is read by a thread of its own, so the response on a request+-- stream can get to the application first.  A test that depends on them --+-- a limit the peer announced, or a dynamic table it allowed -- used to fail+-- a time or two in a hundred.  There is nothing to wait on, so this sleeps.+waitForSettings :: IO ()+waitForSettings = threadDelay 100000

@@ -7,9 +7,11 @@  import Control.Concurrent import qualified Control.Exception as E+import Control.Monad (forM_) import Data.ByteString () import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8+import qualified Data.CaseInsensitive as CI import Data.IORef import Network.HTTP.Types import qualified Network.HTTP3.Client as H3@@ -124,7 +126,33 @@                     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 "+                    ++ C8.unpack (CI.original name)+                    ++ " as malformed [HTTP/3 4.2]"+                )+                $ \(_, served) -> do+                    let req = H3.requestNoBody methodGet "/" [field]+                        qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")+                    before' <- readIORef served+                    runCReq req qcc' cconf conf0 ms+                        `shouldThrow` applicationProtocolErrorsIn [H3MessageError]+                    threadDelay 200000+                    readIORef served `shouldReturn` before'         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 ()+        it             "MUST send H3_MISSING_SETTINGS if the first control frame is not SETTINGS [HTTP/3 6.2.1]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlFrameCreated startWithNonSettings@@ -214,6 +242,53 @@                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream]         it+            "MUST send H3_STREAM_CREATION_ERROR if a second control stream is opened [HTTP/3 6.2.1]"+            $ \_ -> do+                -- A stream type of 0x00, then an empty SETTINGS frame.+                let conf = addHook conf0 $ setOnControlStreamCreated $ openAnother "\x00\x04\x00"+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3StreamCreationError]+        it+            "MUST send H3_STREAM_CREATION_ERROR if a client opens a push stream [HTTP/3 6.2.2]"+            $ \_ -> do+                -- A stream type of 0x01, then push ID 0.+                let conf = addHook conf0 $ setOnControlStreamCreated $ openAnother "\x01\x00"+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3StreamCreationError]+        it+            "MUST send H3_STREAM_CREATION_ERROR if a second encoder stream is opened [QPACK 4.2]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnEncoderStreamCreated $ openAnother "\x02"+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3StreamCreationError]+        it+            "MUST send H3_STREAM_CREATION_ERROR if a second decoder stream is opened [QPACK 4.2]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnDecoderStreamCreated $ openAnother "\x03"+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3StreamCreationError]+        it+            "MUST send H3_CLOSED_CRITICAL_STREAM if an encoder stream is closed [QPACK 4.2]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnEncoderStreamCreated closeStream+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream]+        it+            "MUST send H3_CLOSED_CRITICAL_STREAM if a decoder stream is closed [QPACK 4.2]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnDecoderStreamCreated closeStream+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream]+        it+            "MUST send H3_CLOSED_CRITICAL_STREAM if an encoder stream ends inside an instruction [QPACK 4.2]"+            $ \_ -> do+                -- The first octet of a Set Dynamic Table Capacity that goes on.+                let conf = addHook conf0 $ setOnEncoderStreamCreated $ \strm -> do+                        sendStream strm "\x3f"+                        closeStream strm+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream]+        it             "MUST send QPACK_DECODER_STREAM_ERROR if Insert Count Increment is 0 [QPACK 4.4.3]"             $ \_ -> do                 let conf = addHook conf0 $ setOnDecoderStreamCreated zeroInsertCountIncrement@@ -382,6 +457,30 @@     ]  ----------------------------------------------------------------++-- | The fields RFC 9114, section 4.2, names as connection-specific, and TE+-- with a value other than "trailers".+connectionSpecific :: [(HeaderName, BS.ByteString)]+connectionSpecific =+    [ ("connection", "close")+    , ("keep-alive", "timeout=5")+    , ("proxy-connection", "keep-alive")+    , ("transfer-encoding", "chunked")+    , ("upgrade", "websocket")+    , ("te", "gzip")+    ]++-- | Trailers of a single Connection field.+connectionTrailer :: H3.TrailersMaker+connectionTrailer Nothing = return $ H3.Trailers [("connection", "close")]+connectionTrailer (Just _) = return $ H3.NextTrailersMaker connectionTrailer++-- | Opening a unidirectional stream of our own next to the one given, and+-- sending it these octets: a stream type and whatever follows it.+openAnother :: BS.ByteString -> Stream -> IO ()+openAnother bs strm = do+    strm' <- unidirectionalStream $ streamConnection strm+    sendStream strm' bs  -- A GOAWAY frame announcing 2^30 octets and then sending none of them. --

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTP3.LimitSpec 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 (H3Frame (..), H3FrameType (..))+import Network.HTTP3.Server+import qualified Network.QUIC.Client as QUIC+import Test.Hspec++import HTTP3.Config+import HTTP3.Server++-- | A server that keeps to its SETTINGS_MAX_FIELD_SECTION_SIZE without+-- announcing it.+--+-- Our client keeps to the limit a server announces and sends nothing over+-- it, so a server that announces its limit never sees a section over it from+-- us.  Such a section has to be sent all the same to see what the server+-- does with it, and a client that has not been told of a limit sends it.+spec :: Spec+spec =+    describe "H3 server keeping to a limit it does not announce" $+        it "answers 431 to a request header section over its limit" $+            E.bracket (setupWith hideLimit server 4096) teardown $+                \_ -> runTooLargeClient++-- | SETTINGS with the dynamic table as the test server has it, and without+-- SETTINGS_MAX_FIELD_SECTION_SIZE: QPACK_MAX_TABLE_CAPACITY 4096 and+-- QPACK_BLOCKED_STREAMS 100.+hideLimit :: Config -> Config+hideLimit conf = conf{confHooks = (confHooks conf){onControlFrameCreated = map replace}}+  where+    replace (H3Frame H3FrameSettings _) =+        H3Frame H3FrameSettings "\x01\x50\x00\x07\x40\x64"+    replace frame = frame++-- | 150 copies of one field with a 300-octet value.  After the first two,+-- each is a reference to the dynamic table of an octet or so, so the HEADERS+-- frame comes to around 600 octets, well within the cap on its length.  As+-- the limit counts them, though, they are 335 octets each, 50250 in all+-- against the server's 32768.+runTooLargeClient :: IO ()+runTooLargeClient = QUIC.run testClientConfig $ \conn ->+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+        C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+            -- One round trip first, so that the server's SETTINGS are in and+            -- the encoder may use the dynamic table.  Without it every copy+            -- goes as a literal and the frame is over the cap.+            sendRequest (C.requestNoBody methodGet "/" []) $ \_ -> return ()+            waitForSettings+            let hdr = replicate 150 ("x-a", B.replicate 300 0x62)+                req = C.requestNoBody methodGet "/" hdr+            sendRequest req $ \rsp ->+                C.responseStatus rsp `shouldBe` Just requestHeaderFieldsTooLarge431

@@ -3,6 +3,7 @@  module HTTP3.Server (     setup,+    setupWith,     server,     countingServer,     teardown,@@ -21,7 +22,7 @@ import qualified Crypto.Hash as CH import Data.ByteString (ByteString) import qualified Data.ByteString as B-import Data.ByteString.Builder (byteString)+import Data.ByteString.Builder (Builder, byteString) import qualified Data.ByteString.Char8 as C8 import Data.IORef import Data.IP ()@@ -35,7 +36,11 @@ import HTTP3.Config  setup :: Server -> Int -> IO ThreadId-setup svr siz = do+setup = setupWith id++-- | 'setup', with the HTTP/3 configuration changed as given.+setupWith :: (Config -> Config) -> Server -> Int -> IO ThreadId+setupWith modify svr siz = do     sc <- makeTestServerConfig     tid <- forkIO $ QUIC.run sc loop     threadDelay 500000 -- give enough time to the server@@ -48,7 +53,7 @@                     , confQDecoderConfig = defaultQDecoderConfig{dcMaxTableCapacity = siz}                     } -        run conn conf svr+        run conn (modify conf) svr  teardown :: ThreadId -> IO () teardown tid = killThread tid@@ -67,6 +72,13 @@     Just "GET" -> case requestPath req of         Just "/" -> sendResponse responseHello []         Just "/sockaddr" -> sendResponse (responseSockAddr aux) []+        -- A response that is reset after one DATA frame, between two+        -- frames: the body throws, and the stream is reset.+        Just "/reset" ->+            sendResponse (responseStreaming ok200 [] resetAfterOne) []+        -- A response whose header section is some 2K.+        Just "/bigheader" ->+            sendResponse (responseNoBody ok200 [("x-big", B.replicate 2000 0x61)]) []         _ -> sendResponse response404 []     Just "POST" -> case requestPath req of         Just "/echo" -> sendResponse (responseEcho req) []@@ -78,8 +90,30 @@                     unless (B.null bs) loop             loop             sendResponse responseHello []+        -- Answers with the length of the body it read.+        Just "/length" -> do+            let loop n = do+                    bs <- getRequestBodyChunk req+                    if B.null bs then return n else loop (n + B.length bs)+            n <- loop (0 :: Int)+            sendResponse (responseLength n) []         _ -> sendResponse responseHello []     _ -> sendResponse response405 []++responseLength :: Int -> Response+responseLength n = responseBuilder ok200 header body+  where+    header = [("Content-Type", "text/plain")]+    body = byteString $ C8.pack $ show n++resetAfterOne :: (Builder -> IO ()) -> IO () -> IO ()+resetAfterOne write flush = do+    write $ byteString "partial"+    flush+    -- A RESET_STREAM can go out ahead of stream data queued before it, and+    -- then the client sees neither HEADERS nor DATA.  Let them arrive first.+    threadDelay 200000+    E.throwIO $ userError "reset after one DATA frame"  responseHello :: Response responseHello = responseBuilder ok200 header body

@@ -3,14 +3,36 @@  module HTTP3.ServerSpec where +import Control.Concurrent (threadDelay) import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad import qualified Data.ByteString as B+import Data.IORef import Network.HTTP.Types import qualified Network.HTTP3.Client as C+import Network.HTTP3.Internal (+    ApplicationProtocolError (..),+    H3Frame (..),+    H3FrameType (..),+ ) import Network.HTTP3.Server+import Network.QPACK (+    FieldSectionTooLargeForPeer (..),+    QDecoderConfig (..),+ )+import qualified Network.QUIC as Q import qualified Network.QUIC.Client as QUIC+import Network.QUIC.Internal (+    ClientConfig (..),+    EncryptionLevel,+    Frame (..),+    Hooks (..),+    Plain (..),+    StreamId,+ )+import System.IO.Unsafe (unsafePerformIO)+import System.Timeout (timeout) import Test.Hspec  import HTTP3.Config@@ -25,6 +47,20 @@         it "handles normal cases" $ \_ -> runClient         it "tells the application the peer's address, not its own" $ \_ ->             runSockAddrClient+        it "reads a body past a DATA frame that is empty" $ \_ ->+            runEmptyDataClient+        it "cancels a stream whose response it does not read to the end" $ \_ ->+            runCancelClient+        it "cancels a stream reset between two frames" $ \_ ->+            runResetCancelClient+        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" $ \_ ->+            runManyUnknownStreamsClient+        it "does not send a request header section over the server's limit" $ \_ ->+            runTooLargeForServerClient+        it "does not send a response header section over the client's limit" $ \_ ->+            runTooLargeForClientClient  runClient :: IO () runClient = QUIC.run testClientConfig $ \conn ->@@ -65,6 +101,211 @@         go build = do             bs <- C.getResponseBodyChunk rsp             if B.null bs then return (B.concat (build [])) else go (build . (bs :))++-- | A DATA frame may carry nothing (RFC 9114, section 7.2.1).  One sent right+-- after HEADERS used to be taken for the end of the body, and the server read+-- nothing of what followed.+runEmptyDataClient :: IO ()+runEmptyDataClient = QUIC.run testClientConfig $ \conn ->+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf0 -> do+        let hooks = (confHooks conf0){C.onHeadersFrameCreated = (++ [emptyData])}+            conf = conf0{confHooks = hooks}+            req = C.requestBuilder methodPost "/length" [] "hello"+        C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+            sendRequest req $ \rsp -> do+                C.responseStatus rsp `shouldBe` Just ok200+                C.getResponseBodyChunk rsp `shouldReturn` "5"+  where+    emptyData = H3Frame H3FrameData ""++-- | RFC 9204, section 4.4.2: a decoder that gives up on a stream sends a+-- Stream Cancellation, so that the encoder stops keeping the entries the+-- field sections it will never hear about refer to.  None was ever sent.+--+-- The first response is read to the end and the second is not; only the+-- second is cancelled.  What the client writes on its decoder stream is taken+-- from the QUIC packets it sends.+runCancelClient :: IO ()+runCancelClient = do+    writeIORef sentOnDecoderStream []+    let qcc =+            testClientConfig+                { ccHooks =+                    (ccHooks testClientConfig){onPlainCreated = recordDecoderStream}+                }+    QUIC.run qcc $ \conn ->+        E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+            C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+                let req = C.requestNoBody methodGet "/" []+                -- Stream 0, read to the end.+                sendRequest req $ \rsp -> do+                    let drain = do+                            bs <- C.getResponseBodyChunk rsp+                            unless (B.null bs) drain+                    drain+                -- Stream 4, not.+                sendRequest req $ \_rsp -> return ()+                -- Time for the cancellation to go out.+                threadDelay 100000+    bs <- B.concat <$> readIORef sentOnDecoderStream+    -- Stream Cancellation is 01 and then the stream ID in six bits.+    B.elem 0x40 bs `shouldBe` False+    B.elem 0x44 bs `shouldBe` True++-- | RFC 9114, section 6.2: the receiver of a stream of an unknown type must+-- stop reading it or throw away what arrives on it.  The server did neither.+--+-- STOP_SENDING is answered with a RESET_STREAM carrying the same code, so the+-- client sending one for its stream of a reserved type shows the server asked+-- it to stop.  The connection goes on.+runUnknownStreamClient :: IO ()+runUnknownStreamClient = do+    writeIORef sentResets []+    let qcc =+            testClientConfig+                { ccHooks =+                    (ccHooks testClientConfig){onPlainCreated = recordResets}+                }+    sid <- QUIC.run qcc $ \conn ->+        E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+            C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+                -- 0x21 is the first of the reserved types, 0x1f * N + 0x21.+                strm <- Q.unidirectionalStream conn+                Q.sendStream strm "\x21hello"+                let req = C.requestNoBody methodGet "/" []+                sendRequest req $ \rsp ->+                    C.responseStatus rsp `shouldBe` Just ok200+                threadDelay 200000+                return $ Q.streamId strm+    lookup sid <$> readIORef sentResets+        `shouldReturn` Just H3StreamCreationError++-- | The test server lets a client have 10 unidirectional streams, and the+-- control and QPACK streams take 3.  Opening 15 more, one after another,+-- needs the server to give each back once it is done with it: quic counts a+-- stream as done with only when it is closed, and the server used to stop+-- reading one of an unknown type and never close it.  The eighth then waited+-- for room that never came.+runManyUnknownStreamsClient :: IO ()+runManyUnknownStreamsClient = QUIC.run testClientConfig $ \conn ->+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+        C.run conn testH3ClientConfig conf $ \_sendRequest _aux -> do+            opened <- newIORef (0 :: Int)+            _ <- timeout 3000000 $ forM_ [1 .. 15 :: Int] $ \_ -> do+                strm <- Q.unidirectionalStream conn+                Q.sendStream strm "\x21hello"+                modifyIORef' opened (+ 1)+            readIORef opened `shouldReturn` 15++{-# NOINLINE sentResets #-}+sentResets :: IORef [(StreamId, ApplicationProtocolError)]+sentResets = unsafePerformIO $ newIORef []++{-# NOINLINE recordResets #-}+recordResets :: EncryptionLevel -> Plain -> Plain+recordResets _ plain = unsafePerformIO $ do+    forM_ (plainFrames plain) $ \frame -> case frame of+        ResetStream sid aerr _ ->+            atomicModifyIORef' sentResets $ \xs -> ((sid, aerr) : xs, ())+        _ -> return ()+    return plain++-- | RFC 9114, section 4.2.2: an endpoint "SHOULD NOT send an HTTP message+-- header that exceeds the indicated size".  The peer's limit used to be kept+-- and never consulted.+--+-- 40000 octets in one field is over the server's 32768; the caller is told,+-- and the connection goes on.+runTooLargeForServerClient :: IO ()+runTooLargeForServerClient = QUIC.run testClientConfig $ \conn ->+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+        C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+            let hello = C.requestNoBody methodGet "/" []+                ok rsp = C.responseStatus rsp `shouldBe` Just ok200+            -- The server's SETTINGS in first, so that its limit is known.+            sendRequest hello ok+            waitForSettings+            let big = C.requestNoBody methodGet "/" [("x-a", B.replicate 40000 0x62)]+                tooLarge FieldSectionTooLargeForPeer{} = True+            sendRequest big (\_ -> return ()) `shouldThrow` tooLarge+            sendRequest hello ok++-- | The client says it takes 1000 octets, and /bigheader answers with some+-- 2000.  The server does not send it, and resets the stream with+-- H3_INTERNAL_ERROR: the failure is its own.+runTooLargeForClientClient :: IO ()+runTooLargeForClientClient = do+    let qcc =+            testClientConfig+                { ccHooks =+                    (ccHooks testClientConfig)+                        { onResetStreamReceived = \_ aerr ->+                            E.throwIO $ Q.ApplicationProtocolErrorIsReceived aerr ""+                        }+                }+        isInternalError (Q.ApplicationProtocolErrorIsReceived aerr _) =+            aerr == H3InternalError+        isInternalError _ = False+        client = QUIC.run qcc $ \conn ->+            E.bracket allocSimpleConfig freeSimpleConfig $ \conf0 -> do+                let conf =+                        conf0+                            { confQDecoderConfig =+                                defaultQDecoderConfig{dcMaxFieldSectionSize = 1000}+                            }+                C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+                    -- Our SETTINGS in at the server first.+                    sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->+                        C.responseStatus rsp `shouldBe` Just ok200+                    waitForSettings+                    sendRequest (C.requestNoBody methodGet "/bigheader" []) (\_ -> return ())+    client `shouldThrow` isInternalError++-- | A response reset right after a DATA frame reads, to the body reader,+-- just like one that ended there.  It is not one, and the client has to send+-- a Stream Cancellation for it all the same; it used to take the reset for+-- the end and send none.+runResetCancelClient :: IO ()+runResetCancelClient = do+    writeIORef sentOnDecoderStream []+    let qcc =+            testClientConfig+                { ccHooks =+                    (ccHooks testClientConfig){onPlainCreated = recordDecoderStream}+                }+    QUIC.run qcc $ \conn ->+        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+                    let drain = do+                            bs <- C.getResponseBodyChunk rsp+                            unless (B.null bs) drain+                    drain+                threadDelay 100000+    bs <- B.concat <$> readIORef sentOnDecoderStream+    B.elem 0x40 bs `shouldBe` True++-- | The client's QPACK decoder stream: its third unidirectional stream, after+-- the control stream and the encoder stream.+clientDecoderStream :: StreamId+clientDecoderStream = 10++{-# NOINLINE sentOnDecoderStream #-}+sentOnDecoderStream :: IORef [B.ByteString]+sentOnDecoderStream = unsafePerformIO $ newIORef []++-- | The hook is pure, so this is the only way to see what goes out.+{-# NOINLINE recordDecoderStream #-}+recordDecoderStream :: EncryptionLevel -> Plain -> Plain+recordDecoderStream _ plain = unsafePerformIO $ do+    forM_ (plainFrames plain) $ \frame -> case frame of+        StreamF sid _ dats _+            | sid == clientDecoderStream ->+                atomicModifyIORef' sentOnDecoderStream $ \xs -> (xs ++ dats, ())+        _ -> return ()+    return plain  client0 :: C.Client () client0 sendRequest _aux = do

@@ -2,10 +2,23 @@  module QPACK.HeaderBlockSpec where +import Control.Concurrent (threadDelay)+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Monad import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8+import Data.IORef+import Data.Maybe (isNothing) import Network.HPACK.Token (toToken) import Network.QPACK+import Network.QPACK.Internal (+    DecoderInstruction (..),+    EncoderInstruction (..),+    encodeDecoderInstructions,+    encodeEncoderInstructions,+ )+import System.Timeout (timeout) import Test.Hspec  spec :: Spec@@ -19,17 +32,319 @@             -- advertise.             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+            -- 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+                r <- timeout 5000000 $ roundTripWith defaultQEncoderConfig n+                void 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;+            -- encoding it against the 4K made the two ends disagree once+            -- 2*128 entries had been inserted.+            roundTripMany 4096 65536 600++        it "does not refer to an unacknowledged entry when blocking is not allowed" $ do+            -- SETTINGS_QPACK_BLOCKED_STREAMS is 0, and no acknowledgement+            -- ever arrives: every section has to be decodable with what the+            -- decoder is known to hold, i.e. Required Insert Count 0.  The+            -- third one used to refer to the entry the second one inserted.+            (enc, _, tblop) <- newQEncoder defaultQEncoderConfig (\_ -> return ())+            setCapacity tblop 4096+            setBlockedStreams tblop 0+            forM_ [0 .. 4] $ \i -> do+                blk <- enc (i * 4) [(toToken "x-foo", "bar")]+                encodedInsertCount blk `shouldBe` 0++        it "keeps the number of blocked streams within the decoder's limit" $ do+            -- One blocked stream allowed, and nothing is ever acknowledged, so+            -- every section that refers to the dynamic table is blocked: at+            -- most one of them may do so.+            (enc, _, tblop) <- newQEncoder defaultQEncoderConfig (\_ -> return ())+            setCapacity tblop 4096+            setBlockedStreams tblop 1+            blks <- forM [0 .. 29] $ \i -> do+                let hdr = [(toToken "x-foo", C8.pack (show (i `div` 3 :: Int)))]+                enc (i * 4) hdr+            length (filter ((/= 0) . encodedInsertCount) blks) `shouldSatisfy` (<= 1)++        it "takes two outstanding sections on one stream one at a time" $ do+            -- Headers and trailers on the same stream, both referring to the+            -- dynamic table and so both acknowledged.  The second used to+            -- replace the first, and the second acknowledgement then found+            -- nothing and was taken for a decoder stream error.+            eiRef <- newIORef []+            diRef <- newIORef []+            let save ref bs = modifyIORef' ref (++ [bs])+            (enc, handleDI, tblop) <- newQEncoder defaultQEncoderConfig (save eiRef)+            (dec, handleEI) <- newQDecoder defaultQDecoderConfig (save diRef)+            setCapacity tblop 4096+            setBlockedStreams tblop 100+            let hdr = [(toToken "x-foo", "bar")]+                exchange sid = do+                    blk <- enc sid hdr+                    drain eiRef handleEI+                    (ths, _) <- dec sid blk+                    ths `shouldBe` hdr+                    return blk+            -- Get the field into the table and acknowledged.+            forM_ [0, 4, 8] $ \sid -> exchange sid >> drain diRef handleDI+            blk1 <- exchange 12+            blk2 <- exchange 12+            map encodedInsertCount [blk1, blk2] `shouldSatisfy` all (/= 0)+            drain diRef handleDI++        it "keeps the decoder's entries across a change of capacity" $ do+            -- The encoder may change the capacity at any time.  The decoder+            -- used to reallocate its table when told, so the entry inserted+            -- before the change was gone when referred to after it.+            eiRef <- newIORef []+            (dec, handleEI) <- newQDecoder defaultQDecoderConfig (\_ -> return ())+            ins <-+                encodeEncoderInstructions+                    [ SetDynamicTableCapacity 4096+                    , InsertWithLiteralName (toToken "x-foo") "bar"+                    , SetDynamicTableCapacity 2048+                    ]+                    False+            writeIORef eiRef [ins]+            drain eiRef handleEI+            -- Required Insert Count 1 (encoded as 2 against 128 entries),+            -- Delta Base 0, then an indexed field line for relative index 0.+            (ths, _) <- dec 0 $ BS.pack [0x02, 0x00, 0x80]+            ths `shouldBe` [(toToken "x-foo", "bar")]++        it "stops counting a blocked stream whose wait is given up" $ do+            -- One blocked stream allowed.  A section waiting for an entry+            -- that has not arrived is abandoned, as when its stream is reset.+            -- The stream it was counted as used to stay counted, and the next+            -- section that had to wait was refused as one too many.+            eiRef <- newIORef []+            (dec, handleEI) <-+                newQDecoder defaultQDecoderConfig{dcBlockedSterams = 1} (\_ -> return ())+            -- Required Insert Count 1, Delta Base 0, then an indexed field+            -- line for relative index 0: the first entry, not inserted yet.+            let blk = BS.pack [0x02, 0x00, 0x80]+            withAsync (dec 0 blk) $ \a -> do+                threadDelay 100000+                poll a >>= (`shouldSatisfy` isNothing)+            withAsync (dec 4 blk) $ \a -> do+                threadDelay 100000+                poll a >>= (`shouldSatisfy` isNothing)+                ins <-+                    encodeEncoderInstructions+                        [ SetDynamicTableCapacity 4096+                        , InsertWithLiteralName (toToken "x-foo") "bar"+                        ]+                        False+                writeIORef eiRef [ins]+                drain eiRef handleEI+                (ths, _) <- wait a+                ths `shouldBe` [(toToken "x-foo", "bar")]++        it "evicts an entry nothing refers to once its insertion is acknowledged" $ do+            -- No stream may block, and nothing is acknowledged at first, so+            -- every entry is inserted without being referred to.  Such an+            -- entry used to be kept for good, and once the table was full+            -- nothing new went in.+            eiRef <- newIORef []+            diRef <- newIORef []+            (enc, handleDI, tblop) <-+                newQEncoder defaultQEncoderConfig (\bs -> modifyIORef' eiRef (++ [bs]))+            setCapacity tblop 256+            setBlockedStreams tblop 0+            let inserts i = do+                    writeIORef eiRef []+                    -- Twice, since a field is only inserted the second time+                    -- it is seen.+                    forM_ [0, 1] $ \j ->+                        enc ((i * 2 + j) * 4) [(toToken (C8.pack ("x-foo-" ++ show i)), "a")]+                    any (not . BS.null) <$> readIORef eiRef+            -- 40 octets each: six fit in 256.+            mapM inserts [0 .. 5] `shouldReturn` replicate 6 True+            -- Full, and none of them acknowledged, so none is evictable.+            inserts 6 `shouldReturn` False+            di <- encodeDecoderInstructions [InsertCountIncrement 6]+            writeIORef diRef [di]+            drain diRef handleDI+            inserts 7 `shouldReturn` True++        it "releases the sections of a stream the decoder cancels" $ do+            -- One blocked stream allowed, and nothing acknowledged.  Stream 4+            -- takes it, so stream 8 may not refer to the entry.  Once the+            -- decoder cancels stream 4, stream 12 may.  The cancellation used+            -- to be ignored, and stream 4 stayed blocked for good.+            diRef <- newIORef []+            (enc, handleDI, tblop) <- newQEncoder defaultQEncoderConfig (\_ -> return ())+            setCapacity tblop 4096+            setBlockedStreams tblop 1+            let hdr = [(toToken "x-foo", "bar")]+            -- Inserted the second time it is seen.+            _ <- enc 0 hdr+            enc 4 hdr >>= (`shouldSatisfy` (/= 0)) . encodedInsertCount+            enc 8 hdr >>= (`shouldBe` 0) . encodedInsertCount+            di <- encodeDecoderInstructions [StreamCancellation 4]+            writeIORef diRef [di]+            drain diRef handleDI+            enc 12 hdr >>= (`shouldSatisfy` (/= 0)) . encodedInsertCount++        it "refuses a section that decodes to more than the announced limit" $ do+            -- A field line of one octet refers to a 1037-octet entry, so a+            -- section of a few octets decodes to far more than its length.+            -- Only the length of the frame used to be capped.+            eiRef <- newIORef []+            (dec, handleEI) <-+                newQDecoder+                    defaultQDecoderConfig{dcMaxFieldSectionSize = 2000}+                    (\_ -> return ())+            ins <-+                encodeEncoderInstructions+                    [ SetDynamicTableCapacity 4096+                    , InsertWithLiteralName (toToken "x-foo") (C8.replicate 1000 'a')+                    ]+                    False+            writeIORef eiRef [ins]+            drain eiRef handleEI+            -- Required Insert Count 1, Delta Base 0, then indexed field+            -- lines for relative index 0: once, and then twice.+            (ths, _) <- dec 0 $ BS.pack [0x02, 0x00, 0x80]+            map fst ths `shouldBe` [toToken "x-foo"]+            dec 4 (BS.pack [0x02, 0x00, 0x80, 0x80])+                `shouldThrow` (== FieldSectionTooLarge)++        it "inserts with a reference to a name not yet acknowledged" $ do+            -- No stream may block, and nothing is acknowledged.  x-foo is in+            -- the table, unacknowledged, so a field line may not refer to it;+            -- but an insertion may, on the encoder stream, and x-foo: b is+            -- inserted so.  The encoder used to give that up and insert+            -- nothing, since it guarded the insertion as though it were a+            -- field line.+            eiRef <- newIORef []+            (enc, _, tblop) <-+                newQEncoder defaultQEncoderConfig (\bs -> modifyIORef' eiRef (++ [bs]))+            (dec, handleEI) <- newQDecoder defaultQDecoderConfig (\_ -> return ())+            setCapacity tblop 4096+            setBlockedStreams tblop 0+            let hdr v = [(toToken "x-foo", v)]+            -- Twice each, since a field is only inserted the second time it+            -- is seen.+            blks1 <- forM [0, 4] $ \sid -> enc sid (hdr "a")+            eis1 <- readIORef eiRef+            writeIORef eiRef []+            blks2 <- forM [8, 12] $ \sid -> enc sid (hdr "b")+            eis2 <- readIORef eiRef+            BS.concat eis2 `shouldSatisfy` (not . BS.null)+            -- And what went out still decodes.+            eiQ <- newIORef [BS.concat (eis1 ++ eis2)]+            drain eiQ handleEI+            forM_ (zip [0, 4, 8, 12] (blks1 ++ blks2)) $ \(sid, blk) -> do+                encodedInsertCount blk `shouldBe` 0+                (ths, _) <- dec sid blk+                ths `shouldSatisfy` (`elem` [hdr "a", hdr "b"])++        it "refuses a section more than the peer will take" $ do+            -- RFC 9114, section 4.2.2: "SHOULD NOT send".  The peer's limit+            -- used to be kept and never looked at.  Refused before anything+            -- is inserted, so the encoder stream carries nothing.+            eiRef <- newIORef []+            (enc, _, tblop) <-+                newQEncoder defaultQEncoderConfig (\bs -> modifyIORef' eiRef (++ [bs]))+            setCapacity tblop 4096+            setHeaderSize tblop 100+            writeIORef eiRef []+            -- 5 + 100 + 32 octets as the limit counts them.+            enc 0 [(toToken "x-foo", C8.replicate 100 'a')]+                `shouldThrow` (== FieldSectionTooLargeForPeer 137 100)+            BS.concat <$> readIORef eiRef `shouldReturn` ""+            void $ enc 4 [(toToken "x-foo", "bar")]++-- | Feeding an instruction handler what has been queued for it, then an end+-- of stream, so that it returns -- or throws -- here.+drain :: IORef [BS.ByteString] -> ((Int -> IO BS.ByteString) -> IO ()) -> IO ()+drain ref handler = do+    bss <- readIORef ref+    writeIORef ref []+    queue <- newIORef [BS.concat bss]+    handler $ \_ -> atomicModifyIORef' queue $ \xs -> case xs of+        [] -> ([], "")+        y : ys -> (ys, y)+ roundTrip :: Int -> IO () roundTrip n = do-    (enc, _, _) <--        newQEncoder-            defaultQEncoderConfig{ecHeaderBlockBufferSize = 262144}+    blk <- roundTripWith defaultQEncoderConfig{ecHeaderBlockBufferSize = 262144} n+    -- The encoded section stays well under the announced limit; it is only+    -- the decoded value that is large.+    BS.length blk `shouldSatisfy` (< dcMaxFieldSectionSize defaultQDecoderConfig)++-- | Encoding and decoding a field with an n-octet value; the encoded field+-- section is returned.+roundTripWith :: QEncoderConfig -> Int -> IO BS.ByteString+roundTripWith conf n = do+    (enc, _, _) <- newQEncoder conf (\_ -> return ())+    -- Room for the largest field here, which the default limit on a field+    -- section is not.+    (dec, _) <-+        newQDecoder+            defaultQDecoderConfig{dcMaxFieldSectionSize = 1000000}             (\_ -> return ())-    (dec, _) <- newQDecoder defaultQDecoderConfig (\_ -> return ())     let val = C8.replicate n 'a'     blk <- enc 0 [(toToken ":status", "200"), (toToken "x-big", val)]     (ths, _) <- dec 0 blk-    -- The encoded section stays well under the announced limit; it is only-    -- the decoded value that is large.-    BS.length blk `shouldSatisfy` (< dcMaxFieldSectionSize defaultQDecoderConfig)     lookup (toToken "x-big") ths `shouldBe` Just val+    return blk++roundTripMany :: Int -> Int -> Int -> IO ()+roundTripMany encCap decCap n = do+    eiQ <- newTQueueIO+    diQ <- newTQueueIO+    (enc, handleDI, tblop) <-+        newQEncoder+            defaultQEncoderConfig{ecMaxTableCapacity = encCap}+            (atomically . writeTQueue eiQ)+    (dec, handleEI) <-+        newQDecoder+            defaultQDecoderConfig{dcMaxTableCapacity = decCap}+            (atomically . writeTQueue diQ)+    -- What the decoder's SETTINGS would carry.+    setCapacity tblop decCap+    setBlockedStreams tblop 100+    let recvFrom q _ = atomically $ readTQueue q+    ricMax <- newIORef 0+    withAsync (handleEI $ recvFrom eiQ) $ \_ ->+        withAsync (handleDI $ recvFrom diQ) $ \_ ->+            forM_ [0 .. n - 1] $ \i -> do+                -- Twice each, since a field is only inserted the second+                -- time it is seen.+                forM_ [0, 1] $ \j -> do+                    let sid = (i * 2 + j) * 4+                        hdr = [(toToken "x-count", C8.pack (show i))]+                    blk <- enc sid hdr+                    modifyIORef' ricMax (max (encodedInsertCount blk))+                    (ths, _) <- dec sid blk+                    ths `shouldBe` hdr+                    -- Let acknowledgements reach the encoder, so that+                    -- entries can be evicted and inserting goes on.+                    atomically $ isEmptyTQueue diQ >>= check+    -- Our own decoder would accept either reading of MaxEntries as long as+    -- the encoder used the same one, so look at the prefix itself: against+    -- the decoder's 2048 entries nothing here wraps, and the encoded count+    -- goes past what 2*128 would have allowed.+    readIORef ricMax >>= (`shouldSatisfy` (> 2 * (encCap `div` 32)))++-- | The encoded Required Insert Count: an integer with an 8-bit prefix.+encodedInsertCount :: BS.ByteString -> Int+encodedInsertCount blk = case BS.unpack blk of+    w : ws+        | w < 255 -> fromIntegral w+        | otherwise -> 255 + go 0 0 ws+    [] -> 0+  where+    go acc sh (x : xs)+        | x < 128 = acc + fromIntegral x * 2 ^ (sh :: Int)+        | otherwise = go (acc + fromIntegral (x - 128) * 2 ^ sh) (sh + 7) xs+    go acc _ [] = acc