http3 0.1.9 → 0.1.10

raw patch · 29 files changed

+1402/−321 lines, 29 filesdep −base16-bytestringdep ~arraydep ~asyncdep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: base16-bytestring

Dependency ranges changed: array, async, bytestring, case-insensitive, containers, http-types, network, network-byte-order, psqueues, quic, sockaddr, stm

API changes (from Hackage documentation)

Files

• ChangeLog.md +24/−0
• Network/HQ/Server.hs +74/−37
• Network/HTTP3/Client.hs +13/−1
• Network/HTTP3/Context.hs +113/−16
• Network/HTTP3/Control.hs +82/−24
• Network/HTTP3/Frame.hs +18/−0
• Network/HTTP3/Recv.hs +40/−10
• Network/HTTP3/Send.hs +19/−11
• Network/HTTP3/Server.hs +122/−24
• Network/QPACK.hs +30/−13
• Network/QPACK/Error.hs +5/−0
• Network/QPACK/HeaderBlock/Decode.hs +88/−30
• Network/QPACK/HeaderBlock/Prefix.hs +10/−4
• Network/QPACK/Table/Dynamic.hs +24/−2
• http3.cabal +21/−26
• test/HQ/ServerSpec.hs +79/−0
• test/HTTP3/ClientSpec.hs +49/−0
• test/HTTP3/Config.hs +17/−2
• test/HTTP3/Error.hs +219/−78
• test/HTTP3/GoAwaySpec.hs +75/−0
• test/HTTP3/LimitSpec.hs +16/−1
• test/HTTP3/RunIOSpec.hs +77/−0
• test/HTTP3/ServerSpec.hs +63/−0
• test/QPACK/HeaderBlockSpec.hs +53/−0
• test/QPACK/QIF2Spec.hs +24/−11
• util/h3-client.hs +17/−18
• util/h3-server.hs +10/−6
• util/qif-dec.hs +17/−7
• util/qif-enc.hs +3/−0

@@ -1,5 +1,29 @@ # Revision history for http3 +## 0.1.10++These changes were made on main without PRs.++* New `runWith` and `runIOWith`: the connection goes away with two+  GOAWAYs and ends once the requests taken are answered.+* `runIO` processes each request stream in a thread of its own and+  returns once `sioDone` is called and every request is answered.+* Request streams are closed with H3_NO_ERROR (server) and+  H3_REQUEST_CANCELLED (client).+* A request that the server never started is rejected with+  H3_REQUEST_REJECTED, and the client gets the reset code as+  `StreamResetIsReceived`.+* A connection error stops where it is sent.+* Validate PUSH_PROMISE, CANCEL_PUSH, GOAWAY and MAX_PUSH_ID, and skip+  unknown frames.+* Answer 431 to a HEADERS frame longer than the limit, and check what+  follows the trailers.+* QPACK: validate the prefix, references and Insert Count Increment, and+  make a badly encoded field section QPACK_DECOMPRESSION_FAILED.+* HQ server: reset unfinished responses, and parse and bound the request+  line.+* Requires `quic` 0.3.20. The library's dependencies are bounded.+ ## 0.1.9  * A connection's threads are waited for, up to five seconds, before `run`

@@ -50,6 +50,7 @@  import Imports import Network.HTTP3.Config+import Network.HTTP3.Error (ApplicationProtocolError (H3InternalError)) import Network.HTTP3.Recv (newSource, readSource')  -- | Running an HQ server.@@ -61,57 +62,93 @@     forever $ do         strm <- QUIC.acceptStream conn         forkFinally-            (labelMe "H3 processRequest" >> processRequest conf mysa peersa server strm)-            (\_ -> QUIC.closeStream strm)+            (labelMe "HQ processRequest" >> processRequest conf mysa peersa server strm)+            (finish strm)+  where+    -- Only a response sent in full ends with a FIN.  One whose handler+    -- failed or timed out used to end so too, and the client took what it+    -- had for the whole response.+    finish strm (Right True) = QUIC.closeStream strm+    finish strm _ = do+        QUIC.resetStream strm H3InternalError+        QUIC.closeStream strm  labelMe :: String -> IO () labelMe label = do     tid <- myThreadId     labelThread tid label -processRequest :: Config -> SockAddr -> SockAddr -> Server -> Stream -> IO ()+-- | Whether the response went out in full.+--+-- The handler is killed when the timeout manager says so; it used to be+-- given a timeout that did nothing, so a client that never finished its+-- request line kept the thread for as long as the connection lasted.+processRequest :: Config -> SockAddr -> SockAddr -> Server -> Stream -> IO Bool processRequest conf mysa peersa server strm-    | QUIC.isClientInitiatedBidirectional sid =-        void $ T.withHandle (confTimeoutManager conf) (return ()) $ \th -> do-            vt <- recvHeader strm mysa-            src <- newSource strm-            refH <- newIORef Nothing-            let readB = readSource' src-                req = Request $ InpObj vt Nothing readB refH-                aux =-                    defaultAux-                        { auxTimeHandle = th-                        , auxMySockAddr = mysa-                        , auxPeerSockAddr = peersa-                        }-            server req aux $ sendResponse conf strm-    | otherwise = return () -- fixme: should consume the data?+    | QUIC.isClientInitiatedBidirectional sid = do+        done <- newIORef False+        T.withHandleKillThread (confTimeoutManager conf) (return ()) $ \th -> do+            mvt <- recvHeader strm mysa+            forM_ mvt $ \vt -> do+                src <- newSource strm+                refH <- newIORef Nothing+                let readB = readSource' src+                    req = Request $ InpObj vt Nothing readB refH+                    aux =+                        defaultAux+                            { auxTimeHandle = th+                            , auxMySockAddr = mysa+                            , auxPeerSockAddr = peersa+                            }+                server req aux $ sendResponse conf strm+                writeIORef done True+        readIORef done+    | otherwise = return True -- fixme: should consume the data?   where     sid = QUIC.streamId strm -recvHeader :: Stream -> SockAddr -> IO TokenHeaderTable+-- | The request line, as a header table, or 'Nothing' when it is not one.+recvHeader :: Stream -> SockAddr -> IO (Maybe TokenHeaderTable) recvHeader strm myaddr = do-    (method, path) <- recvRequestLine id-    let auth = showSockAddrBS myaddr-        vt =-            (":path", path)-                : (":method", method)-                : (":scheme", "https")-                : (":authority", auth)-                : []-    toTokenHeaderTable vt+    mpath <- recvRequestLine strm+    forM mpath $ \path -> do+        let auth = showSockAddrBS myaddr+            vt =+                (":path", path)+                    : (":method", "GET")+                    : (":scheme", "https")+                    : (":authority", auth)+                    : []+        toTokenHeaderTable vt++-- | The path of an HTTP/0.9 request line, "GET" and the path, ending in CRLF+-- or LF, or at the end of the stream.+--+-- It was taken to be the octets after the first four, less the last two,+-- of everything up to the end of the stream: no check that the method was+-- GET, a version taken as part of the path, the last octet of the path lost+-- to a bare LF, and no limit on what was held.+recvRequestLine :: Stream -> IO (Maybe ByteString)+recvRequestLine strm = loop ""   where-    recvRequestLine builder = do+    maxLength = 8192+    loop acc = do         bs <- QUIC.recvStream strm 1024-        if bs == ""-            then do-                return $ parseRequestLine $ BS.concat $ builder []-            else recvRequestLine (builder . (bs :))-    parseRequestLine bs = (method, path)+        let acc' = acc <> bs+        case BS.elemIndex 0x0a acc' of+            Just i -> return $ parse $ BS.take i acc'+            Nothing+                | BS.null bs -> return $ parse acc'+                | BS.length acc' > maxLength -> return Nothing+                | otherwise -> loop acc'+    parse line0 = case BS.stripPrefix "GET " line of+        Just rest+            | path <- BS.takeWhile (/= 0x20) rest+            , "/" `BS.isPrefixOf` path ->+                Just path+        _ -> Nothing       where-        method = "GET"-        path0 = BS.drop 4 bs-        path = BS.take (BS.length path0 - 2) path0+        line = fromMaybe line0 $ BS.stripSuffix "\r" line0  sendResponse :: Config -> Stream -> Response -> [PushPromise] -> IO () sendResponse conf strm (Response outobj) _ = case outObjBody outobj of

@@ -178,6 +178,18 @@             mvt <- recvFinalHeader ctx strm src             case mvt of                 Nothing -> do+                    -- The server reset the stream before answering: its code+                    -- goes to the application, which may retry a request+                    -- rejected with H3_REQUEST_REJECTED (RFC 9114, section+                    -- 4.1.1).  It used to be dropped for H3_MESSAGE_ERROR.+                    --+                    -- Not at once: a server closing the connection may reset+                    -- its streams first, and the connection error, which says+                    -- more, comes to this thread in the meantime.+                    mreset <- QUIC.resetReceived strm+                    forM_ mreset $ \aerr -> do+                        threadDelay 100000+                        E.throwIO $ StreamResetIsReceived aerr                     QUIC.resetStream strm H3MessageError                     threadDelay 100000                     -- just for type inference@@ -215,7 +227,7 @@     done sent strm = do         complete <- readIORef sent         if complete-            then closeStream strm+            then QUIC.closeStreamWith strm H3RequestCancelled             else QUIC.resetStream strm H3RequestCancelled     hdr = outObjHeaders outobj     isIPv6 = isJust (readMaybe auth :: Maybe IPv6)

@@ -26,14 +26,26 @@     forkManagedTimeout,     forkManagedTimeoutFinally,     isAsyncException,+    admitRequest,+    requestDone,+    goAway,+    goAwayAll,+    waitPTO,+    drained, ) where +import Control.Concurrent (threadDelay)+import Control.Concurrent.STM import qualified Control.Exception as E-import Control.Monad (void)+import Control.Monad (forM_, void) import Data.IORef+import Data.Maybe (isJust)+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Network.ByteOrder (withWriteBuffer) import Network.HTTP.Semantics.Client import Network.QUIC-import Network.QUIC.Internal (isClient, isServer)+import Network.QUIC.Internal (Microseconds (..), connLDCC, encodeInt', getPTO, isClient, isServer) import Network.Socket (SockAddr) import qualified System.ThreadManager as T import qualified System.TimeManager as TM@@ -68,6 +80,13 @@     -- ^ The peer's SETTINGS_MAX_FIELD_SECTION_SIZE, or 'maxBound' until its     -- SETTINGS have arrived     -- ^ Sending a Stream Cancellation on our QPACK decoder stream+    , ctxSendControl :: [H3Frame] -> IO ()+    , ctxGoAway :: TVar (Maybe StreamId)+    -- ^ Server only: the ID of our GOAWAY, from which no request is taken.+    , ctxLastRequest :: TVar (Maybe StreamId)+    -- ^ Server only: the largest request stream taken.+    , ctxInFlight :: TVar IntSet+    -- ^ Server only: the request streams taken and not yet done with.     }  -- | Running an action with a context, and seeing this connection's own@@ -93,12 +112,13 @@  newContext :: Connection -> Config -> IO Context newContext conn conf = do-    (sendEI, sendDI) <- setupUnidirectional conn conf+    (sendEI, sendDI, ctxSendControl) <- setupUnidirectional conn conf     (ctxQEncoder, handleDI, dyntblE) <- newQEncoder (confQEncoderConfig conf) sendEI     -- newQDecoder passes dyntbl for decoder to handleEI internally     (ctxQDecoder, handleEI) <- newQDecoder (confQDecoderConfig conf) sendDI     let ctxMaxFieldSectionSize = dcMaxFieldSectionSize $ confQDecoderConfig conf-    ctl <- controlStream conn ctxMaxFieldSectionSize dyntblE <$> newIORef IInit+    cst <- newControlState+    ctl <- controlStream conn ctxMaxFieldSectionSize dyntblE cst <$> newIORef IInit     let ctxPeerMaxFieldSectionSize = getHeaderSize dyntblE     seen <- newIORef []     info <- getConnectionInfo conn@@ -120,6 +140,9 @@                 (encodeDecoderInstructions [StreamCancellation sid] >>= sendDI)                     `E.catch` ignoreSync     ctxThreadManager <- T.newThreadManager+    ctxGoAway <- newTVarIO Nothing+    ctxLastRequest <- newTVarIO Nothing+    ctxInFlight <- newTVarIO IntSet.empty     let ctxTimeoutManager = confTimeoutManager conf     let ctxConnection = conn     return Context{..}@@ -131,7 +154,7 @@     abortWith :: ApplicationProtocolError -> E.SomeException -> IO ()     abortWith aerr se         | isAsyncException se = E.throwIO se-        | otherwise = abortConnection conn aerr ""+        | otherwise = connectionError conn aerr  isAsyncException :: E.Exception e => e -> Bool isAsyncException e =@@ -166,8 +189,8 @@     -- 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 ""+        | isServer conn -> \_ -> connectionError conn H3StreamCreationError+        | otherwise -> \_ -> connectionError conn H3IdError     -- 'unidirectional' does not get here with an unknown type.     H3StreamTypeUnknown _ -> \_ -> return ()   where@@ -175,11 +198,11 @@     once handler recv = do         dup <- atomicModifyIORef' seen $ \ts -> (styp : ts, styp `elem` ts)         if dup-            then abortConnection conn H3StreamCreationError ""+            then connectionError conn H3StreamCreationError             else handler recv     closing handler recv = do         handler recv-        abortConnection conn H3ClosedCriticalStream ""+        connectionError conn H3ClosedCriticalStream  isH3Server :: Context -> Bool isH3Server Context{..} = isServer ctxConnection@@ -238,20 +261,38 @@ pReadMaker = ctxPReadMaker  forkManaged :: Context -> String -> IO () -> IO ()-forkManaged Context{..} = T.forkManaged ctxThreadManager+forkManaged Context{..} label =+    T.forkManaged ctxThreadManager label . endingOnConnectionError  forkManagedTimeout :: Context -> String -> (TM.Handle -> IO ()) -> IO ()-forkManagedTimeout Context{..} =-    T.forkManagedTimeout ctxThreadManager ctxTimeoutManager+forkManagedTimeout Context{..} label body =+    T.forkManagedTimeout ctxThreadManager ctxTimeoutManager label $+        endingOnConnectionError . body  forkManagedTimeoutFinally     :: Context -> String -> (TM.Handle -> IO ()) -> IO () -> IO ()-forkManagedTimeoutFinally Context{..} =-    T.forkManagedTimeoutFinally ctxThreadManager ctxTimeoutManager+forkManagedTimeoutFinally Context{..} label body =+    T.forkManagedTimeoutFinally ctxThreadManager ctxTimeoutManager label $+        endingOnConnectionError . body -abort :: Context -> ApplicationProtocolError -> IO ()-abort ctx aerr = abortConnection (ctxConnection ctx) aerr ""+-- | A thread that has sent a connection error ('connectionError') ends there+-- quietly: the connection is going, and the error has been told to the peer.+--+-- So does one waiting on a connection the peer has closed with no error:+-- quic tells the wait with 'ConnectionIsClosed'.  The thread reading the+-- peer's control stream used to die of it, reported as uncaught.+endingOnConnectionError :: IO () -> IO ()+endingOnConnectionError io =+    io `E.catch` \e -> case e of+        ApplicationProtocolErrorIsSent _ _ -> return ()+        ConnectionIsClosed _ -> return ()+        _ -> E.throwIO e +-- | Closing the connection with this error, and stopping here: see+-- 'connectionError'.+abort :: Context -> ApplicationProtocolError -> IO a+abort ctx = connectionError (ctxConnection ctx)+ getHooks :: Context -> Hooks getHooks = ctxHooks @@ -266,3 +307,59 @@  getPeerMaxFieldSectionSize :: Context -> IO Int getPeerMaxFieldSectionSize = ctxPeerMaxFieldSectionSize++----------------------------------------------------------------+-- GOAWAY of ours (RFC 9114, section 5.2)++-- | Taking a request stream, unless our GOAWAY has gone out at or below+--   it.  One that is not taken must be rejected, not processed.+admitRequest :: Context -> StreamId -> IO Bool+admitRequest Context{..} sid = atomically $ do+    lim <- readTVar ctxGoAway+    if maybe False (sid >=) lim+        then return False+        else do+            modifyTVar' ctxLastRequest $ Just . maybe sid (max sid)+            modifyTVar' ctxInFlight $ IntSet.insert sid+            return True++-- | Done with a request stream taken by 'admitRequest'.+requestDone :: Context -> StreamId -> IO ()+requestDone Context{..} sid = atomically $ modifyTVar' ctxInFlight $ IntSet.delete sid++-- | Sending GOAWAY once, with the first request stream not taken: the+--   streams taken so far are still answered.+goAway :: Context -> IO ()+goAway ctx@Context{..} = do+    mlim <- atomically $ do+        old <- readTVar ctxGoAway+        case old of+            Just _ -> return Nothing+            Nothing -> do+                lim <- maybe 0 (+ 4) <$> readTVar ctxLastRequest+                writeTVar ctxGoAway $ Just lim+                return $ Just lim+    forM_ mlim $ sendGoAway ctx++-- | The first of two GOAWAYs: the largest identifier, which stops the+--   client sending requests and takes every one already on its way.+goAwayAll :: Context -> IO ()+goAwayAll ctx = sendGoAway ctx $ 2 ^ (62 :: Int) - 4++-- | Waiting for the connection's probe timeout, which is at least a round+--   trip.+waitPTO :: Context -> IO ()+waitPTO Context{..} = do+    Microseconds pto <- getPTO $ connLDCC ctxConnection+    threadDelay pto++sendGoAway :: Context -> StreamId -> IO ()+sendGoAway Context{..} lim = do+    payload <- withWriteBuffer 8 $ \wbuf -> encodeInt' wbuf $ fromIntegral lim+    ctxSendControl [H3Frame H3FrameGoaway payload]++-- | Waiting until our GOAWAY is out and no request taken is left.+drained :: Context -> STM ()+drained Context{..} = do+    readTVar ctxGoAway >>= check . isJust+    readTVar ctxInFlight >>= check . IntSet.null

@@ -4,6 +4,9 @@ module Network.HTTP3.Control (     setupUnidirectional,     controlStream,+    ControlState,+    newControlState,+    connectionError, ) where  import Control.Concurrent.MVar@@ -13,6 +16,7 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Network.QUIC+import Network.QUIC.Internal (isServer)  import Imports import qualified Network.HTTP3.Config as H3@@ -28,7 +32,11 @@ setupUnidirectional     :: Connection     -> H3.Config-    -> IO (EncodedEncoderInstruction -> IO (), EncodedDecoderInstruction -> IO ())+    -> IO+        ( EncodedEncoderInstruction -> IO ()+        , EncodedDecoderInstruction -> IO ()+        , [H3Frame] -> IO ()+        ) setupUnidirectional conn conf@H3.Config{..} = do     let QDecoderConfig{..} = confQDecoderConfig     settings <-@@ -56,6 +64,7 @@     return         ( critical $ sendStream sE         , critical $ \bs -> withMVar lockD $ \_ -> sendStream sD bs+        , critical $ sendStreamMany sC . encodeH3Frames         )   where     -- The sending part of one of our QPACK streams is closed only when the@@ -66,22 +75,45 @@     -- and nothing caught it there.     critical send bs =         send bs `E.catch` \e -> case e of-            StreamIsClosed -> abortConnection conn H3ClosedCriticalStream ""+            StreamIsClosed -> connectionError conn H3ClosedCriticalStream             _ -> E.throwIO e     stC = mkType H3ControlStreams     stE = mkType QPACKEncoderStream     stD = mkType QPACKDecoderStream     hooks = H3.confHooks conf +-- | Closing the connection with this error, and stopping here.+--+-- 'abortConnection' only throws to the connection's main thread, so code+-- after it went on running in this one: a frame refused was then handled.+connectionError :: Connection -> ApplicationProtocolError -> IO a+connectionError conn aerr = do+    abortConnection conn aerr ""+    E.throwIO $ ApplicationProtocolErrorIsSent aerr ""++-- | The last GOAWAY and MAX_PUSH_ID the peer sent on its control stream.+data ControlState = ControlState+    { lastGoaway :: IORef (Maybe Int64)+    , lastMaxPushId :: IORef (Maybe Int64)+    }++newControlState :: IO ControlState+newControlState = ControlState <$> newIORef Nothing <*> newIORef Nothing+ -- DynamicTable for Encoder controlStream-    :: Connection -> Int -> TableOperation -> IORef IFrame -> InstructionHandler-controlStream conn lim tblop ref recv = loop0+    :: Connection+    -> Int+    -> TableOperation+    -> ControlState+    -> IORef IFrame+    -> InstructionHandler+controlStream conn lim tblop cst ref recv = loop0   where     loop0 = do         bs <- recv 1024         if bs == ""-            then abortConnection conn H3ClosedCriticalStream ""+            then connectionError conn H3ClosedCriticalStream             else do                 (done, st1) <- readIORef ref >>= parse0 bs                 writeIORef ref st1@@ -89,7 +121,7 @@     loop = do         bs <- recv 1024         if bs == ""-            then abortConnection conn H3ClosedCriticalStream ""+            then connectionError conn H3ClosedCriticalStream             else do                 readIORef ref >>= parse bs >>= writeIORef ref                 loop@@ -100,15 +132,13 @@                 -- business on a control stream, so refuse it before any of it                 -- is buffered rather than after.                 | Just H3FrameData <- frameTypeOf st1' -> do-                    abortConnection conn H3FrameUnexpected ""-                    return (False, IInit)+                    connectionError conn H3FrameUnexpected             ITooLong _ _ -> do-                abortConnection conn H3ExcessiveLoad ""-                return (False, IInit)+                connectionError conn H3ExcessiveLoad             IDone typ payload leftover -> do                 case typ of                     H3FrameSettings -> checkSettings conn tblop payload-                    _ -> abortConnection conn H3MissingSettings ""+                    _ -> connectionError conn H3MissingSettings                 st1 <- parse leftover IInit                 return (True, st1)             st1 -> return (False, st1)@@ -117,23 +147,51 @@         case parseH3Frame lim st0 bs of             st1'                 | Just H3FrameData <- frameTypeOf st1' -> do-                    abortConnection conn H3FrameUnexpected ""-                    return IInit+                    connectionError conn H3FrameUnexpected             ITooLong _ _ -> do-                abortConnection conn H3ExcessiveLoad ""-                return IInit-            IDone typ _payload leftover -> do+                connectionError conn H3ExcessiveLoad+            IDone typ payload leftover -> do                 case typ of-                    H3FrameCancelPush -> return ()-                    H3FrameSettings -> abortConnection conn H3FrameUnexpected ""-                    H3FrameGoaway -> return ()-                    H3FrameMaxPushId -> return ()+                    H3FrameCancelPush -> singleInt payload >>= cancelPush+                    H3FrameSettings -> connectionError conn H3FrameUnexpected+                    H3FrameGoaway -> singleInt payload >>= goaway+                    H3FrameMaxPushId -> singleInt payload >>= maxPushId                     _                         | permittedInControlStream typ -> return ()-                        | otherwise -> abortConnection conn H3FrameUnexpected ""+                        | otherwise -> connectionError conn H3FrameUnexpected                 parse leftover IInit             st1 -> return st1 +    -- RFC 9114, section 7.1: the payload is exactly the fields the frame+    -- has, here one variable-length integer, or H3_FRAME_ERROR.+    singleInt payload = case parseQInt QInit payload of+        QDone i "" -> return i+        _ -> connectionError conn H3FrameError+    server = isServer conn+    -- Section 7.2.3: a push ID beyond what is allowed is H3_ID_ERROR.  A+    -- client allows none, since ours sends no MAX_PUSH_ID; a server, those+    -- up to the client's MAX_PUSH_ID.+    cancelPush pid = do+        allowed <-+            if server+                then readIORef (lastMaxPushId cst)+                else return Nothing+        unless (maybe False (pid <=) allowed) $ connectionError conn H3IdError+    -- Section 5.2: from a server, the ID of a client-initiated bidirectional+    -- stream; and in either direction, no larger than one sent before.+    -- What to do on GOAWAY is left to the caller of the connection.+    goaway i = do+        when (not server && i `mod` 4 /= 0) $ connectionError conn H3IdError+        prev <- readIORef (lastGoaway cst)+        when (maybe False (i >) prev) $ connectionError conn H3IdError+        writeIORef (lastGoaway cst) (Just i)+    -- Section 7.2.7: only a server takes MAX_PUSH_ID, and it may not go down.+    maxPushId i = do+        unless server $ connectionError conn H3FrameUnexpected+        prev <- readIORef (lastMaxPushId cst)+        when (maybe False (i <) prev) $ connectionError conn H3IdError+        writeIORef (lastMaxPushId cst) (Just i)+ checkSettings :: Connection -> TableOperation -> ByteString -> IO () checkSettings conn tblop payload = do     mh3settings <- decodeH3Settings payload@@ -141,7 +199,7 @@         -- RFC 9114 section 7.1: a payload that "terminates before the end of         -- the identified fields MUST be treated as a connection error of type         -- H3_FRAME_ERROR".-        Nothing -> abortConnection conn H3FrameError ""+        Nothing -> connectionError conn H3FrameError         Just h3settings -> loop IntSet.empty h3settings   where     loop :: IntSet -> H3Settings -> IO ()@@ -151,7 +209,7 @@         -- identifier, and this does.  A set rather than bits in an Int:         -- identifiers are variable-length integers, so everything from 64 up         -- fell off the end of the word and could repeat unnoticed.-        | i `IntSet.member` seen = abortConnection conn H3SettingsError ""+        | i `IntSet.member` seen = connectionError conn H3SettingsError         | otherwise = do             let seen' = IntSet.insert i seen             case k of@@ -171,7 +229,7 @@                     loop seen' ss                 _                     -- HTTP/2 settings-                    | i <= 0x6 -> abortConnection conn H3SettingsError ""+                    | i <= 0x6 -> connectionError conn H3SettingsError                     -- Unknown, so ignored -- but the rest of the frame is                     -- not.  This used to stop here, which meant a peer                     -- following section 7.2.4.1's advice to send a reserved

@@ -205,6 +205,10 @@       ITooLong         H3FrameType         Int -- The length it claimed+    | -- | Skipping the payload of a frame of unknown type+      ISkip+        H3FrameType+        Int -- Bytes still to skip     deriving (Eq, Show)  -- | The frame type, once the parse has got far enough to know it.@@ -215,6 +219,7 @@ frameTypeOf (IPay typ _ _ _) = Just typ frameTypeOf (IDone typ _ _) = Just typ frameTypeOf (ITooLong typ _) = Just typ+frameTypeOf (ISkip typ _) = Just typ  -- | Feed bytes to a frame parse. --@@ -240,6 +245,10 @@ parseH3Frame lim (ILen typ ist) bs = case parseQInt ist bs of     QDone i bs'         | reqLen == 0 -> IDone typ "" bs'+        -- RFC 9114, section 7.2.8: frames of unknown types "MUST be+        -- ignored".  Their payload is skipped rather than held, so the cap+        -- does not apply: one over it used to close the connection.+        | ignorable typ -> parseH3Frame lim (ISkip typ reqLen) bs'         | typ /= H3FrameData && reqLen > lim -> ITooLong typ reqLen         | otherwise -> parseH3Frame lim (IPay typ reqLen 0 []) bs'       where@@ -253,7 +262,16 @@          in IDone typ (compose bs2 bss0) leftover   where     len1 = len0 + BS.length bs0+parseH3Frame _ (ISkip typ n) bs+    | BS.length bs < n = ISkip typ (n - BS.length bs)+    | otherwise = IDone typ "" (BS.drop n bs) parseH3Frame _ st _ = st++-- | A frame type not defined by RFC 9114, nor reserved there for one of+-- HTTP/2's (section 11.2.1).+ignorable :: H3FrameType -> Bool+ignorable (H3FrameUnknown i) = i > 0x09+ignorable _ = False  compose :: ByteString -> [ByteString] -> ByteString compose bs bss = BS.concat $ reverse (bs : bss)

@@ -22,6 +22,7 @@ import Network.HTTP3.Context import Network.HTTP3.Error import Network.HTTP3.Frame+import Network.QPACK.Error (FieldSectionTooLarge (..))  data Source = Source     { sourceStream :: Stream@@ -68,6 +69,14 @@ pushbackSource _ "" = return () pushbackSource Source{..} bs = writeIORef sourcePending $ Just bs +-- | A PUSH_PROMISE on a request stream.  A server cannot receive one (RFC+-- 9114, section 7.2.5), and a client that has sent no MAX_PUSH_ID, as ours+-- never does, has allowed none (section 4.6).  It used to be ignored.+pushPromise :: Context -> IO a+pushPromise ctx+    | isH3Server ctx = abort ctx H3FrameUnexpected+    | otherwise = abort ctx H3IdError+ recvHeader :: Context -> StreamId -> Source -> IO (Maybe TokenHeaderTable) recvHeader ctx sid src = loop IInit   where@@ -77,9 +86,13 @@         if bs == ""             then return Nothing             else case parseH3Frame lim st bs of+                -- A field section longer than we said we would take, before+                -- it is decoded: the request is refused with 431 (RFC 9114,+                -- section 4.2.2), as one that decodes to too much is.  It+                -- used to close the connection with H3_EXCESSIVE_LOAD.+                ITooLong H3FrameHeaders _ -> E.throwIO FieldSectionTooLarge                 ITooLong _ _ -> do                     abort ctx H3ExcessiveLoad-                    loop IInit -- dummy                 st0                     -- Nothing here drains DATA, so it is not covered by the                     -- length cap; and it is not allowed before HEADERS@@ -87,17 +100,16 @@                     -- than after buffering whatever length it claimed.                     | Just H3FrameData <- frameTypeOf st0 -> do                         abort ctx H3FrameUnexpected-                        loop IInit -- dummy                 IDone typ payload leftover                     | typ == H3FrameHeaders -> do                         pushbackSource src leftover                         Just <$> qpackDecode ctx sid payload+                    | typ == H3FramePushPromise -> pushPromise ctx                     | permittedInRequestStream typ -> do                         pushbackSource src leftover                         loop IInit                     | otherwise -> do                         abort ctx H3FrameUnexpected-                        loop IInit -- dummy                 st' -> loop st'  -- | The first connection-specific field in a field section, if any.@@ -172,6 +184,28 @@     chunk bs = do         modifyIORef' refL (+ BS.length bs)         return (bs, False)+    -- The rest of the stream after the trailers, which may hold no HEADERS+    -- or DATA (RFC 9114, section 4.1).  It used to be dropped unread: the+    -- frames in the same read as the trailers, and whatever came after them.+    afterTrailers st = do+        bs <- readSource src+        if bs == ""+            then do+                when (st /= IInit) $ abort ctx H3FrameError+                writeIORef (sourceReadToEnd src) True+            else case parseH3Frame lim st bs of+                ITooLong _ _ -> abort ctx H3ExcessiveLoad+                st0+                    | Just typ <- frameTypeOf st0+                    , typ == H3FrameData || typ == H3FrameHeaders ->+                        abort ctx H3FrameUnexpected+                IDone typ _ leftover+                    | typ == H3FramePushPromise -> pushPromise ctx+                    | permittedInRequestStream typ -> do+                        pushbackSource src leftover+                        afterTrailers IInit+                    | otherwise -> abort ctx H3FrameUnexpected+                st' -> afterTrailers st'     loop st = do         bs <- readSource src         if bs == ""@@ -189,17 +223,12 @@                     Nothing                         | st /= IInit -> do                             abort ctx H3FrameError-                            E.throwIO $-                                ApplicationProtocolErrorIsSent-                                    H3FrameError-                                    "a frame cut off by the end of the stream"                         | otherwise -> do                             writeIORef (sourceReadToEnd src) True                             endOfBody             else case parseH3Frame lim st bs of                 ITooLong _ _ -> do                     abort ctx H3ExcessiveLoad-                    return ("", True) -- dummy                 IPay H3FrameData siz received bss -> do                     let st' = IPay H3FrameData siz received []                     if null bss@@ -210,11 +239,12 @@                 IDone typ payload leftover                     | typ == H3FrameHeaders -> do                         writeIORef refI IInit-                        -- pushbackSource src leftover -- fixme                         hdr <- qpackDecode ctx sid payload                         forM_ (connectionSpecificField hdr) $                             E.throwIO . ConnectionSpecificField                         writeIORef refH $ Just hdr+                        pushbackSource src leftover+                        afterTrailers IInit                         endOfBody                     | typ == H3FrameData -> do                         writeIORef refI IInit@@ -223,10 +253,10 @@                         -- 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+                    | typ == H3FramePushPromise -> pushPromise ctx                     | permittedInRequestStream typ -> do                         pushbackSource src leftover                         loop IInit                     | otherwise -> do                         abort ctx H3FrameUnexpected-                        return (payload, False) -- dummy                 st' -> loop st'

@@ -87,12 +87,23 @@     fp <- BS.mallocByteString 2048     Next len _reqflush mnext1 <- withForeignPtr fp $ \buf -> action buf 2048     if len == 0-        then return ("", Nothing, tlrmkr0)+        -- Nothing this time, but not necessarily the end: there may be a+        -- next.  This used to end the body here.+        then return ("", mnext1, tlrmkr0)         else do             let bs = PS fp 0 len-            NextTrailersMaker tlrmkr1 <- tlrmkr0 $ Just bs+            tlrmkr1 <- nextMaker <$> tlrmkr0 (Just bs)             return (bs, mnext1, tlrmkr1) +-- | The trailers maker to go on with after a chunk of the body.+--+-- One that answers with the trailers before the end keeps them for the end.+-- That was taken to be impossible, and failed with a pattern match; or the+-- trailers were dropped for none.+nextMaker :: NextTrailersMaker -> TrailersMaker+nextMaker (NextTrailersMaker t) = t+nextMaker tm@(Trailers _) = \_ -> return tm+ newByteStringAndSend     :: Stream     -> T.Handle@@ -106,10 +117,7 @@         then return (signal, tlrmkr0)         else do             let bs = PS fp 0 len-            tm <- tlrmkr0 $ Just bs-            let tlrmkr1 = case tm of-                    NextTrailersMaker t -> t-                    _ -> defaultTrailersMaker+            tlrmkr1 <- nextMaker <$> tlrmkr0 (Just bs)             encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm             T.tickle th             return (signal, tlrmkr1)@@ -134,7 +142,10 @@                     }         strmbdy iface     tlrmkr <- readIORef ref-    Trailers trailers <- tlrmkr Nothing+    tm <- tlrmkr Nothing+    let trailers = case tm of+            Trailers t -> t+            _ -> []     unless (null trailers) $ sendHeader ctx strm th trailers   where     -- fixme: how to implement flush and cancel?@@ -150,9 +161,6 @@             newByteStringAndSend strm th tlrmkr1 writer >>= loop         loop (B.Chunk bs writer, tlrmkr1) = do             encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm-            tm2 <- tlrmkr1 $ Just bs-            let tlrmkr2 = case tm2 of-                    NextTrailersMaker t -> t-                    _ -> defaultTrailersMaker+            tlrmkr2 <- nextMaker <$> tlrmkr1 (Just bs)             T.tickle th             newByteStringAndSend strm th tlrmkr2 writer >>= loop

@@ -5,6 +5,7 @@ module Network.HTTP3.Server (     -- * Runner     run,+    runWith,      -- * Common configration     Config (..),@@ -26,6 +27,7 @@      -- * Internal     runIO,+    runIOWith,     ServerIO (..), ) where @@ -33,6 +35,8 @@ import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Exception as E+import qualified Control.Monad.STM as STM+import Data.IORef import GHC.Conc.Sync import Network.HTTP.Semantics import Network.HTTP.Semantics.Server@@ -40,7 +44,6 @@ import Network.HTTP2.Server.Internal (ServerIO (..)) import Network.QUIC (Connection, ConnectionInfo (..), Stream, getConnectionInfo) import qualified Network.QUIC as QUIC-import Network.QUIC.Internal (mainDone) import qualified System.TimeManager as T  import Imports@@ -54,32 +57,109 @@  -- | Running an HTTP\/3 server. run :: Connection -> Config -> Server -> IO ()-run conn conf server = withContext conn conf $ \ctx -> do+run = runServer Nothing++-- | Like 'run', but the connection goes away once the 'STM' action fires:+--   two GOAWAYs a PTO apart (RFC 9114, section 5.2), request streams from+--   the second one's ID on rejected, and the connection ended when the+--   requests taken before it are answered.+--+--   @since 0.1.10+runWith :: STM () -> Connection -> Config -> Server -> IO ()+runWith = runServer . Just++runServer :: Maybe (STM ()) -> Connection -> Config -> Server -> IO ()+runServer mstop conn conf server = withContext conn conf $ \ctx -> do     myThreadId >>= \t -> labelThread t "H3 server: run"-    readerServer ctx $ \strm ->-        -- 'processRequest' handles its own exceptions; only asynchronous ones-        -- leave it, and the thread manager takes those that it threw.-        forkManagedTimeoutFinally-            ctx-            "H3 server: processRequest"-            (processRequest ctx server strm)-            (closeStream strm)+    let serve = readerServer ctx $ \strm -> do+            started <- newIORef False+            -- 'processRequest' handles its own exceptions; only asynchronous ones+            -- leave it, and the thread manager takes those that it threw.+            forkManagedTimeoutFinally+                ctx+                "H3 server: processRequest"+                (\th -> writeIORef started True >> processRequest ctx server strm th)+                (finish ctx strm started)+    maybe serve (\stop -> race_ (goingAway ctx (True <$ stop)) serve) mstop+  where+    -- A thread stopped before it began, as the connection goes, has not+    -- looked at the request: it is rejected, which tells the client it may+    -- retry (RFC 9114, section 4.1.1).  The stream used to end with a FIN+    -- and nothing on it, which the client could only take for malformed.+    --+    -- The request is done with however that goes: a stream or connection+    -- already gone must not leave it in flight for a GOAWAY to wait on.+    finish ctx strm started =+        ( do+            s <- readIORef started+            unless s $ QUIC.resetStream strm H3RequestRejected+            QUIC.closeStreamWith strm H3NoError+        )+            `E.finally` requestDone ctx (QUIC.streamId strm) +-- | Once told: GOAWAY, and the requests taken before it answered.+--+-- Told to stop, in two steps (RFC 9114, section 5.2): the largest+-- identifier first, and the last request taken once a PTO has passed, so+-- that requests already on their way are taken.  An application that is+-- done answers nothing more, so its GOAWAY is the last one at once.+goingAway :: Context -> STM Bool -> IO ()+goingAway ctx told = do+    twoSteps <- atomically told+    when twoSteps $ do+        goAwayAll ctx+        waitPTO ctx+    goAway ctx+    atomically $ drained ctx+ runIO :: Connection -> Config -> (ServerIO Stream -> IO (IO ())) -> IO ()-runIO conn conf action = withContext conn conf $ \ctx -> do+runIO = runIOServer Nothing++-- | Like 'runIO', but the connection goes away once the 'STM' action+--   fires, as with 'runWith'.+--+--   @since 0.1.10+runIOWith+    :: STM () -> Connection -> Config -> (ServerIO Stream -> IO (IO ())) -> IO ()+runIOWith = runIOServer . Just++runIOServer+    :: Maybe (STM ())+    -> Connection+    -> Config+    -> (ServerIO Stream -> IO (IO ()))+    -> IO ()+runIOServer mstop conn conf action = withContext conn conf $ \ctx -> do     info <- getConnectionInfo conn     reqq <- newTQueueIO+    done <- newTVarIO False     let sio =             ServerIO                 { sioMySockAddr = localSockAddr info                 , sioPeerSockAddr = remoteSockAddr info                 , sioReadRequest = atomically $ readTQueue reqq-                , sioWriteResponse = sendResponseIO ctx-                , sioDone = mainDone conn+                , sioWriteResponse = \strm rsp ->+                    sendResponseIO ctx strm rsp+                        `E.finally` requestDone ctx (QUIC.streamId strm)+                , -- Not quic's 'mainDone': its sender ends once that is set+                  -- and nothing is queued, before the responses still to come.+                  sioDone = atomically $ writeTVar done True                 }-        put strmreq = atomically $ writeTQueue reqq strmreq+        put = atomically . writeTQueue reqq+        -- The application being done ends the connection as being told to+        -- does.  This used to wait for streams for good, and so the+        -- connection was left open until the peer or the idle timeout ended it.+        appDone = readTVar done >>= check     io <- action sio-    concurrently_ io (readerServer ctx $ processRequestIO ctx put)+    -- A thread per stream, as in 'run'.  Reading HEADERS on the accept loop+    -- let one stream that never sent them stop every stream after it.+    race_ (goingAway ctx $ (False <$ appDone) <|> maybe STM.retry (True <$) mstop) $+        concurrently_ io $+            readerServer ctx $ \strm ->+                forkManagedTimeout ctx "H3 server: processRequestIO" $ \_th -> do+                    let sid = QUIC.streamId strm+                    handed <- processRequestIO ctx put strm `E.onException` requestDone ctx sid+                    unless handed $ requestDone ctx sid  readerServer :: Context -> (Stream -> IO ()) -> IO () readerServer ctx action = loop@@ -91,7 +171,15 @@         | QUIC.isClientInitiatedUnidirectional sid =             forkManaged ctx "H3 server: unidirectional handler" $                 unidirectional ctx strm-        | QUIC.isClientInitiatedBidirectional sid = action strm+        | QUIC.isClientInitiatedBidirectional sid = do+            admitted <- admitRequest ctx sid+            -- At or above our GOAWAY: not processed, so the client may+            -- retry it elsewhere (RFC 9114, section 5.2).+            if admitted+                then action strm+                else do+                    QUIC.stopStream strm H3RequestRejected+                    QUIC.resetStream strm H3RequestRejected         | QUIC.isServerInitiatedUnidirectional sid = return () -- error         | otherwise = return ()       where@@ -137,6 +225,9 @@             E.throwIO se         | Just (_ :: DecodeError) <- E.fromException se =             abort ctx QpackDecompressionFailed+        -- A connection error has been sent: the stream goes with it.+        | Just (QUIC.ApplicationProtocolErrorIsSent _ _) <- E.fromException se =+            return ()         -- 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 =@@ -156,26 +247,33 @@         | Just FieldSectionTooLarge <- E.fromException se = True         | otherwise = False -processRequestIO :: Context -> ((Stream, Request) -> IO ()) -> Stream -> IO ()+-- | Answers whether the request was handed to the application.+processRequestIO :: Context -> ((Stream, Request) -> IO ()) -> Stream -> IO Bool processRequestIO ctx put strm = E.handle reset $ do     src <- newSource strm     emvt <- E.try $ recvHeader ctx sid src     case emvt of         Left FieldSectionTooLarge ->-            void $ withHandle ctx $ refuseTooLarge ctx strm-        Right Nothing -> QUIC.resetStream strm H3MessageError+            False <$ withHandle ctx (refuseTooLarge ctx strm)+        Right Nothing -> False <$ QUIC.resetStream strm H3MessageError         Right (Just ht) -> do             mreq <- mkRequest ctx strm src ht             case mreq of-                Nothing -> return ()-                Just req -> put (strm, req)+                Nothing -> return False+                Just req -> True <$ put (strm, req)   where     sid = QUIC.streamId strm     reset se-        | isAsyncException se = E.throwIO se+        -- Killed by the timeout, or with the connection, before the request+        -- was handed over.+        | isAsyncException se = do+            QUIC.resetStream strm H3RequestIncomplete+            E.throwIO se         | Just (_ :: DecodeError) <- E.fromException se =             abort ctx QpackDecompressionFailed-        | otherwise = QUIC.resetStream strm H3MessageError+        | Just (QUIC.ApplicationProtocolErrorIsSent _ _) <- E.fromException se =+            return False+        | otherwise = False <$ QUIC.resetStream strm H3MessageError  -- | Answering a request whose header section is more than we said we would --   take.@@ -237,4 +335,4 @@     void $ withHandle ctx $ \th -> do         sendHeader ctx strm th $ outObjHeaders outobj         sendBody ctx strm th outobj-        QUIC.closeStream strm+        QUIC.closeStreamWith strm H3NoError

@@ -515,9 +515,8 @@ qpackDecoder     :: DynamicTable -> StreamId -> EncodedFieldSection -> IO TokenHeaderTable qpackDecoder dyntbl sid bs = do-    (tbl, needAck) <- withReadBuffer bs $ \rbuf -> decodeTokenHeader dyntbl rbuf-    when needAck $-        encodeDecoderInstructions [SectionAcknowledgement sid] >>= sendIns dyntbl+    (tbl, ric) <- withReadBuffer bs $ \rbuf -> decodeTokenHeader dyntbl rbuf+    acknowledgeSection dyntbl sid ric     return tbl  qpackDecoderS@@ -527,11 +526,30 @@     mhs <- withReadBuffer bs $ \rbuf -> decodeTokenHeaderS dyntbl rbuf     case mhs of         Nothing -> return Nothing-        Just (hs, needAck) -> do-            when needAck $-                encodeDecoderInstructions [SectionAcknowledgement sid] >>= sendIns dyntbl+        Just (hs, ric) -> do+            acknowledgeSection dyntbl sid ric             return $ Just hs +-- | A Section Acknowledgement, for a section with a Required Insert Count+-- other than 0 (RFC 9204, section 4.4.1).  It tells the encoder that the+-- insertions up to that count have arrived.+acknowledgeSection :: DynamicTable -> StreamId -> RequiredInsertCount -> IO ()+acknowledgeSection _ _ 0 = return ()+acknowledgeSection dyntbl sid (RequiredInsertCount ric) =+    updateReported dyntbl $ \reported -> do+        encodeDecoderInstructions [SectionAcknowledgement sid] >>= sendIns dyntbl+        return $ max reported ric++-- | An Insert Count Increment for the insertions the encoder has not been+-- told of, by this or by a Section Acknowledgement (RFC 9204, section 4.4.3).+reportInsertions :: DynamicTable -> IO ()+reportInsertions dyntbl = updateReported dyntbl $ \reported -> do+    InsertionPoint ip <- getInsertionPoint dyntbl+    when (ip > reported) $+        encodeDecoderInstructions [InsertCountIncrement (ip - reported)]+            >>= sendIns dyntbl+    return $ max reported ip+ -- Note: dyntbl for decoder encoderInstructionHandler :: Int -> DynamicTable -> EncoderInstructionHandler encoderInstructionHandler decCapLim dyntbl recv = loop ""@@ -568,9 +586,8 @@ encoderInstructionHandlerS _ _dyntbl "" = return "" encoderInstructionHandlerS decCapLim dyntbl bs = do     (ins, leftover) <- decodeEncoderInstructions hufdec bs-    cnt <- sum <$> mapM handle ins-    when (cnt /= 0) $-        encodeDecoderInstructions [InsertCountIncrement cnt] >>= sendIns dyntbl+    mapM_ handle ins+    reportInsertions dyntbl     return leftover   where     hufdec = getHuffmanDecoder dyntbl -- only for encoder instruction handler@@ -579,7 +596,7 @@         | otherwise = do             setDecoderTableCapacity dyntbl n             qpackDebug dyntbl $ print ins-            return 0+            return ()     handle ins@(InsertWithNameReference ii val) = do         ready <- isTableReady dyntbl         unless ready $ E.throwIO EncoderInstructionError@@ -594,7 +611,7 @@             _ <- insertEntryToDecoder ent dyntbl             return idx         qpackDebug dyntbl $ putStrLn $ show ins ++ ": " ++ show dai-        return 1+        return ()     handle ins@(InsertWithLiteralName t val) = do         ready <- isTableReady dyntbl         unless ready $ E.throwIO EncoderInstructionError@@ -602,7 +619,7 @@             let ent = toEntryToken t val             insertEntryToDecoder ent dyntbl         qpackDebug dyntbl $ putStrLn $ show ins ++ ": " ++ show dai-        return 1+        return ()     handle ins@(Duplicate ri) = do         ready <- isTableReady dyntbl         unless ready $ E.throwIO EncoderInstructionError@@ -616,4 +633,4 @@         qpackDebug dyntbl $             putStrLn $                 show ins ++ ": " ++ show dai ++ " -> " ++ show dai'-        return 1+        return ()

@@ -34,6 +34,11 @@     | -- | An absolute index outside the dynamic table's live window       IllegalDynamicIndex Int     | IllegalInsertCount+    | -- | A Base below zero (RFC 9204, section 4.5.1.2)+      IllegalBase+    | -- | A field line that is cut short, or whose Huffman string or+      -- integer is not one+      MalformedFieldLine String     | BlockedStreamsOverflow     deriving (Eq, Show) 

@@ -10,6 +10,7 @@ import Network.ByteOrder import qualified Network.HPACK as HPACK import Network.HPACK.Internal (+    Entry,     HuffmanDecoder,     decodeH,     decodeI,@@ -27,12 +28,43 @@ import Network.QPACK.Table import Network.QPACK.Types +-- | Errors in the encoding of a field section, as QPACK's 'DecodeError', and+-- so QPACK_DECOMPRESSION_FAILED (RFC 9204, section 2.2).  They came out as+-- HPACK's errors, or 'BufferOverrun' for a section cut short, which nothing+-- took for a decoding error: the request was reset as malformed.+asDecodeError :: IO a -> IO a+asDecodeError io =+    io+        `E.catches` [ E.Handler $ \e -> case e of+                        HPACK.TooLargeHeader -> E.throwIO FieldSectionTooLarge+                        _+                            | encoding e -> E.throwIO $ MalformedFieldLine $ show e+                            -- A field section well encoded but not a valid+                            -- one, such as a pseudo-header after a field:+                            -- the message is malformed.+                            | otherwise -> E.throwIO e+                    , E.Handler $ \BufferOverrun ->+                        E.throwIO $ MalformedFieldLine "cut short"+                    ]++-- | HPACK's errors in the encoding itself, as opposed to the fields it+-- decodes to.+encoding :: HPACK.DecodeError -> Bool+encoding e =+    e+        `elem` [ HPACK.EosInTheMiddle+               , HPACK.IllegalEos+               , HPACK.TooLongEos+               , HPACK.TooLargeInteger+               , HPACK.HeaderBlockTruncated+               ]+ decodeTokenHeader     :: DynamicTable     -> ReadBuffer-    -> IO (TokenHeaderTable, Bool)-decodeTokenHeader dyntbl rbuf = do-    (reqInsertCount, bp, needAck) <- decodePrefix rbuf dyntbl+    -> IO (TokenHeaderTable, RequiredInsertCount)+decodeTokenHeader dyntbl rbuf = asDecodeError $ do+    (reqInsertCount, bp) <- decodePrefix rbuf dyntbl     ready <- checkRequiredInsertCountNB dyntbl reqInsertCount     -- 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@@ -46,28 +78,27 @@             `E.finally` decreaseStreams dyntbl     checkRequiredInsertCount dyntbl reqInsertCount     hufdec <- newHuffmanDecoder rbuf-    dec <- limitFieldSection dyntbl $ toTokenHeader dyntbl bp hufdec+    dec <- limitFieldSection dyntbl $ toTokenHeader dyntbl reqInsertCount 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)+    -- 'asDecodeError' says so.+    tbl <- decodeSophisticated dec rbuf+    return (tbl, reqInsertCount)  decodeTokenHeaderS     :: DynamicTable     -> ReadBuffer-    -> IO (Maybe ([Header], Bool))-decodeTokenHeaderS dyntbl rbuf = do-    (reqInsertCount, bp, needAck) <- decodePrefix rbuf dyntbl+    -> IO (Maybe ([Header], RequiredInsertCount))+decodeTokenHeaderS dyntbl rbuf = asDecodeError $ do+    (reqInsertCount, bp) <- decodePrefix rbuf dyntbl     ok <- checkRequiredInsertCountNB dyntbl reqInsertCount     if ok         then do             hufdec <- newHuffmanDecoder rbuf-            dec <- limitFieldSection dyntbl $ toTokenHeader dyntbl bp hufdec+            dec <-+                limitFieldSection dyntbl $ toTokenHeader dyntbl reqInsertCount bp hufdec             hs <- decodeSimple dec rbuf-            return $ Just (hs, needAck)+            return $ Just (hs, reqInsertCount)         else return Nothing  -- | A field line decoder that stops once the section comes to more than we@@ -116,34 +147,54 @@ {- FOURMOLU_DISABLE -} toTokenHeader     :: DynamicTable+    -> RequiredInsertCount     -> BasePoint     -> HuffmanDecoder     -> Word8     -> ReadBuffer     -> IO TokenHeader-toTokenHeader dyntbl bp hufdec w8 rbuf+toTokenHeader dyntbl ric bp hufdec w8 rbuf     | w8 `testBit` 7 =-        decodeIndexedFieldLine                  rbuf dyntbl        bp w8+        decodeIndexedFieldLine                  rbuf dyntbl ric        bp w8     | w8 `testBit` 6 =-        decodeLiteralFieldLineWithNameReference rbuf dyntbl hufdec bp w8+        decodeLiteralFieldLineWithNameReference rbuf dyntbl ric hufdec bp w8     | w8 `testBit` 5 =-        decodeLiteralFieldLineWithLiteralName   rbuf dyntbl hufdec bp w8+        decodeLiteralFieldLineWithLiteralName   rbuf dyntbl     hufdec bp w8     | w8 `testBit` 4 =-        decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl        bp w8+        decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl ric        bp w8     | otherwise =-        decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl hufdec bp w8+        decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl ric hufdec bp w8 {- FOURMOLU_ENABLE -} +-- | The entry a field line refers to.+--+-- RFC 9204, section 2.2.3: a reference to an entry at or above the Required+-- Insert Count is QPACK_DECOMPRESSION_FAILED.  It was checked only against+-- what had been inserted, so a section with a Required Insert Count of 0 --+-- which is never acknowledged -- could name any entry in the table.+lookupEntry :: DynamicTable -> RequiredInsertCount -> HIndex -> IO Entry+lookupEntry dyntbl (RequiredInsertCount ric) hidx = do+    case hidx of+        DIndex (AbsoluteIndex ai)+            | ai >= ric -> E.throwIO $ IllegalDynamicIndex ai+        _ -> return ()+    atomically $ toIndexedEntry dyntbl hidx+ -- 4.5.2.  Indexed Field Line decodeIndexedFieldLine-    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader-decodeIndexedFieldLine rbuf dyntbl bp w8 = do+    :: ReadBuffer+    -> DynamicTable+    -> RequiredInsertCount+    -> BasePoint+    -> Word8+    -> IO TokenHeader+decodeIndexedFieldLine rbuf dyntbl ric bp w8 = do     i <- decodeI 6 (w8 .&. 0b00111111) rbuf     let static = w8 `testBit` 6         hidx             | static = SIndex $ AbsoluteIndex i             | otherwise = DIndex $ fromPreBaseIndex (PreBaseIndex i) bp-    ret <- atomically (entryTokenHeader <$> toIndexedEntry dyntbl hidx)+    ret <- entryTokenHeader <$> lookupEntry dyntbl ric hidx     qpackDebug dyntbl $         putStrLn $             "IndexedFieldLine (" ++ show hidx ++ ") " ++ showTokenHeader ret@@ -151,11 +202,16 @@  -- 4.5.3.  Indexed Field Line With Post-Base Index decodeIndexedFieldLineWithPostBaseIndex-    :: ReadBuffer -> DynamicTable -> BasePoint -> Word8 -> IO TokenHeader-decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl bp w8 = do+    :: ReadBuffer+    -> DynamicTable+    -> RequiredInsertCount+    -> BasePoint+    -> Word8+    -> IO TokenHeader+decodeIndexedFieldLineWithPostBaseIndex rbuf dyntbl ric bp w8 = do     i <- decodeI 4 (w8 .&. 0b00001111) rbuf     let hidx = DIndex $ fromPostBaseIndex (PostBaseIndex i) bp-    ret <- atomically (entryTokenHeader <$> toIndexedEntry dyntbl hidx)+    ret <- entryTokenHeader <$> lookupEntry dyntbl ric hidx     qpackDebug dyntbl $         putStrLn $             "IndexedFieldLineWithPostBaseIndex ("@@ -172,17 +228,18 @@ decodeLiteralFieldLineWithNameReference     :: ReadBuffer     -> DynamicTable+    -> RequiredInsertCount     -> HuffmanDecoder     -> BasePoint     -> Word8     -> IO TokenHeader-decodeLiteralFieldLineWithNameReference rbuf dyntbl hufdec bp w8 = do+decodeLiteralFieldLineWithNameReference rbuf dyntbl ric hufdec bp w8 = do     i <- decodeI 4 (w8 .&. 0b00001111) rbuf     let static = w8 `testBit` 4         hidx             | static = SIndex $ AbsoluteIndex i             | otherwise = DIndex $ fromPreBaseIndex (PreBaseIndex i) bp-    key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx)+    key <- entryToken <$> lookupEntry dyntbl ric hidx     val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf     let ret = (key, val)     qpackDebug dyntbl $@@ -197,14 +254,15 @@ decodeLiteralFieldLineWithPostBaseNameReference     :: ReadBuffer     -> DynamicTable+    -> RequiredInsertCount     -> HuffmanDecoder     -> BasePoint     -> Word8     -> IO TokenHeader-decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl hufdec bp w8 = do+decodeLiteralFieldLineWithPostBaseNameReference rbuf dyntbl ric hufdec bp w8 = do     i <- decodeI 3 (w8 .&. 0b00000111) rbuf     let hidx = DIndex $ fromPostBaseIndex (PostBaseIndex i) bp-    key <- atomically (entryToken <$> toIndexedEntry dyntbl hidx)+    key <- entryToken <$> lookupEntry dyntbl ric hidx     val <- decodeS (`clearBit` 7) (`testBit` 7) 7 hufdec rbuf     let ret = (key, val)     qpackDebug dyntbl $

@@ -48,6 +48,9 @@     | reqInsertCount > maxValue && reqInsertCount <= fullRange =         E.throw IllegalInsertCount     | reqInsertCount > maxValue = RequiredInsertCount (reqInsertCount - fullRange)+    -- RFC 9204, section 4.5.1.1: "Value of 0 must be encoded as 0."  An+    -- encoded 1 with nothing inserted yet came out as 0, and was taken.+    | reqInsertCount == 0 = E.throw IllegalInsertCount     | otherwise = RequiredInsertCount reqInsertCount   where     fullRange = 2 * maxEntries@@ -76,7 +79,11 @@ -- BasePoint 6 decodeBase :: RequiredInsertCount -> Bool -> Int -> BasePoint decodeBase (RequiredInsertCount reqInsCnt) False deltaBase = BasePoint (reqInsCnt + deltaBase)-decodeBase (RequiredInsertCount reqInsCnt) True deltaBase = BasePoint (reqInsCnt - deltaBase - 1)+-- RFC 9204, section 4.5.1.2: with the sign bit set, "the value of Required+-- Insert Count MUST be greater than the value of Delta Base".+decodeBase (RequiredInsertCount reqInsCnt) True deltaBase+    | reqInsCnt <= deltaBase = E.throw IllegalBase+    | otherwise = BasePoint (reqInsCnt - deltaBase - 1)  ---------------------------------------------------------------- @@ -101,7 +108,7 @@  -- | Decoding the prefix part of header block. decodePrefix-    :: ReadBuffer -> DynamicTable -> IO (RequiredInsertCount, BasePoint, Bool)+    :: ReadBuffer -> DynamicTable -> IO (RequiredInsertCount, BasePoint) decodePrefix rbuf dyntbl = do     maxEntries <- getMaxEntries dyntbl     totalNumberOfInserts <- getInsertionPoint dyntbl@@ -122,5 +129,4 @@                 ++ show totalNumberOfInserts                 ++ ", maxN "                 ++ show maxEntries-    let needAck = reqInsCnt /= 0-    return (reqInsCnt, baseIndex, needAck)+    return (reqInsCnt, baseIndex)

@@ -55,6 +55,7 @@     wouldSectionBeBlocked,     wouldInstructionBeBlocked,     setInsersionPointToKnownReceivedCount,+    updateReported,      -- * Points     getBasePoint,@@ -152,6 +153,7 @@         { huffmanDecoder  :: HuffmanDecoder  -- only for encoder instruction handler         , blockedStreamsD :: IORef Int         , evictedD        :: TVar AbsoluteIndex -- the oldest entry not evicted+        , reportedD       :: MVar Int -- the Known Received Count told to the encoder         } {- FOURMOLU_ENABLE -} @@ -209,6 +211,7 @@     let huffmanDecoder = decodeH gcbuf huftmpsiz     blockedStreamsD <- newIORef 0     evictedD <- newTVarIO 0+    reportedD <- newMVar 0     newDynamicTable DecodeInfo{..} sendDI  newDynamicTable :: CodeInfo -> (ByteString -> IO ()) -> IO DynamicTable@@ -584,9 +587,15 @@  ---------------------------------------------------------------- +-- | RFC 9204, section 4.4.3: an increment that takes the Known Received+-- Count beyond what has been inserted is a QPACK_DECODER_STREAM_ERROR.  It+-- was added unchecked, and entries never acknowledged could be evicted. incrementKnownReceivedCount :: DynamicTable -> Int -> IO ()-incrementKnownReceivedCount DynamicTable{..} n =-    atomically $ modifyTVar' knownReceivedCount (+ n)+incrementKnownReceivedCount DynamicTable{..} n = atomically $ do+    krc <- readTVar knownReceivedCount+    InsertionPoint ip <- readTVar insertionPoint+    when (krc + n > ip) $ throwSTM DecoderInstructionError+    writeTVar knownReceivedCount (krc + n)   where     EncodeInfo{..} = codeInfo @@ -612,6 +621,19 @@     return (ai >= krc)   where     EncodeInfo{..} = codeInfo++-- | Telling the encoder of insertions, under a lock and with what it has+-- been told so far (decoder only).+--+-- A Section Acknowledgement tells it of insertions as well as an Insert+-- Count Increment does (RFC 9204, section 2.1.4).  The increment used to be+-- the number of entries just inserted, so a section acknowledged first had+-- them counted twice, and the encoder's Known Received Count went past what+-- had been inserted.+updateReported :: DynamicTable -> (Int -> IO Int) -> IO ()+updateReported DynamicTable{..} = modifyMVar_ reportedD+  where+    DecodeInfo{..} = codeInfo  setInsersionPointToKnownReceivedCount :: DynamicTable -> IO () setInsersionPointToKnownReceivedCount dyntbl@DynamicTable{..} = do

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               http3-version:            0.1.9+version:            0.1.10 license:            BSD-3-Clause license-file:       LICENSE maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>@@ -76,22 +76,22 @@     ghc-options:        -Wall     build-depends:         base >=4.9 && <5,-        array,-        async,-        bytestring,-        case-insensitive,-        containers,+        array >=0.5 && <0.6,+        async >=2.2 && <2.3,+        bytestring >=0.10,+        case-insensitive >=1.2 && <1.3,+        containers >=0.6,         http-semantics >= 0.4 && <0.5,-        http-types,+        http-types >=0.12 && <0.13,         http2 >=5.4.10 && <5.5,         iproute >= 1.7 && < 1.8,-        network,-        network-byte-order,+        network >=3.1,+        network-byte-order >=0.1.7 && <0.2,         network-control >= 0.1.7 && <0.2,-        psqueues,-        quic >= 0.3.18 && < 0.4,-        sockaddr,-        stm,+        psqueues >=0.2 && <0.3,+        quic >= 0.3.20 && < 0.4,+        sockaddr >=0.0.1 && <0.1,+        stm >=2.5 && <2.6,         time-manager >= 0.5 && <0.6,         utf8-string >=1.0 && <1.1 @@ -107,15 +107,13 @@     ghc-options:        -Wall -threaded -rtsopts     build-depends:         base >=4.9 && <5,-        base16-bytestring,         bytestring,         crypton,-        filepath,         http-types,         http2,         http3,         quic,-        tls >=2.3.0 && <2.5,+        tls >=2.3.0 && <2.6,         tls-session-manager      if flag(devel)@@ -136,13 +134,11 @@     build-depends:         base >=4.9 && <5,         async,-        base16-bytestring,         bytestring,-        filepath,         http-types,         http3,         quic,-        tls >=2.3.0 && <2.5,+        tls >=2.3.0 && <2.6,         unix-time      if flag(devel)@@ -164,11 +160,8 @@         cereal,         conduit,         conduit-extra,-        containers,         filepath,-        http3,-        quic,-        stm+        http3      if flag(devel) @@ -190,8 +183,7 @@         conduit-extra,         containers,         http3,-        quic,-        stm+        quic      if flag(devel) @@ -204,13 +196,17 @@     build-tool-depends: hspec-discover:hspec-discover     hs-source-dirs:     test util     other-modules:+        HQ.ServerSpec+        HTTP3.ClientSpec         HTTP3.Config         HTTP3.Error         HTTP3.ErrorSpec         HTTP3.FrameSpec+        HTTP3.GoAwaySpec         HTTP3.HandlerSpec         HTTP3.InformationalSpec         HTTP3.LimitSpec+        HTTP3.RunIOSpec         HTTP3.Server         HTTP3.ServerSpec         QPACK.HeaderBlockSpec@@ -228,7 +224,6 @@         QuickCheck,         attoparsec,         async,-        base16-bytestring,         bytestring,         case-insensitive,         conduit,

@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++module HQ.ServerSpec where++import Control.Concurrent+import qualified Control.Exception as E+import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder, byteString)+import qualified Network.HQ.Server as HQ+import Network.HTTP.Types+import qualified Network.QUIC as QUIC+import qualified Network.QUIC.Client as QUICC+import qualified Network.QUIC.Server as QUICS+import System.Timeout (timeout)+import Test.Hspec++import HTTP3.Config+import HTTP3.Server (teardown)++spec :: Spec+spec = beforeAll setupHQ $+    afterAll teardown $+        describe "HQ server" $ do+            it "answers a request" $ \_ ->+                request "GET /\r\n" `shouldReturn` Just ("hello", Nothing)+            it "takes the path alone from a request line with a version" $ \_ ->+                request "GET /path HTTP/1.0\r\n" `shouldReturn` Just ("/path", Nothing)+            it "takes a request line ending in LF alone" $ \_ ->+                request "GET /path\n" `shouldReturn` Just ("/path", Nothing)+            it "resets the stream of a request that is not GET" $ \_ ->+                fmap snd <$> request "POST /path\r\n" `shouldReturn` Just (Just resetCode)+            it "resets the stream of a response its handler failed to finish" $ \_ ->+                fmap snd <$> request "GET /fail\r\n" `shouldReturn` Just (Just resetCode)+            it "resets the stream of a request line that goes on and on" $ \_ ->+                fmap snd <$> request (BS.replicate 100000 0x61)+                    `shouldReturn` Just (Just resetCode)++resetCode :: QUIC.ApplicationProtocolError+resetCode = QUIC.ApplicationProtocolError 0x102++setupHQ :: IO ThreadId+setupHQ = do+    sc <- makeTestServerConfig+    tid <- forkIO $ QUICS.run sc $ \conn ->+        E.bracket HQ.allocSimpleConfig HQ.freeSimpleConfig $ \conf ->+            HQ.run conn conf hqServer+    threadDelay 500000 -- give enough time to the server+    return tid++-- | "/" answers hello, "/fail" fails after part of its response, and+-- anything else answers with its path.+hqServer :: HQ.Server+hqServer req _aux sendResponse = case HQ.requestPath req of+    Just "/" -> sendResponse (HQ.responseBuilder ok200 [] "hello") []+    Just "/fail" -> sendResponse (HQ.responseStreaming ok200 [] failing) []+    Just path -> sendResponse (HQ.responseBuilder ok200 [] (byteString path)) []+    Nothing -> sendResponse (HQ.responseNoBody badRequest400 []) []+  where+    failing :: (Builder -> IO ()) -> IO () -> IO ()+    failing write flush = do+        write "partial"+        flush+        E.throwIO $ userError "failing"++-- | Sending the octets as a request, and reading the response: what came,+-- and the code of a reset if there was one.+request+    :: BS.ByteString+    -> IO (Maybe (BS.ByteString, Maybe QUIC.ApplicationProtocolError))+request bs = timeout 3000000 $ QUICC.run testClientConfig $ \conn -> do+    strm <- QUIC.stream conn+    QUIC.sendStream strm bs+    QUIC.shutdownStream strm+    let loop acc = do+            x <- QUIC.recvStream strm 1024+            if BS.null x then return acc else loop (acc <> x)+    body <- loop "" `E.catch` \(E.SomeException _) -> return ""+    reset <- QUIC.resetReceived strm+    return (body, reset)

@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTP3.ClientSpec where++import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+import Network.HTTP.Types+import qualified Network.HTTP3.Client as C+import Network.HTTP3.Internal (+    ApplicationProtocolError (..),+    StreamResetIsReceived (..),+ )+import qualified Network.QUIC as QUIC+import qualified Network.QUIC.Client as QUICC+import qualified Network.QUIC.Server as QUICS+import System.Timeout (timeout)+import Test.Hspec++import HTTP3.Config+import HTTP3.Server (teardown)++spec :: Spec+spec =+    describe "H3 client" $+        it "tells the application of a request the server rejected" $+            E.bracket setupRejecting teardown $ \_ ->+                timeout 3000000 rejectedRequest+                    `shouldReturn` Just (Left (StreamResetIsReceived H3RequestRejected))++-- | A server that resets every request stream with H3_REQUEST_REJECTED,+-- which says the request may be retried (RFC 9114, section 4.1.1).+setupRejecting :: IO ThreadId+setupRejecting = do+    sc <- makeTestServerConfig+    tid <- forkIO $ QUICS.run sc $ \conn -> forever $ do+        strm <- QUIC.acceptStream conn+        when (QUIC.isClientInitiatedBidirectional $ QUIC.streamId strm) $+            QUIC.resetStream strm H3RequestRejected+    threadDelay 500000 -- give enough time to the server+    return tid++-- | The client used to reset the stream back with H3_MESSAGE_ERROR and throw+-- a generic error, so the application could not tell it might retry.+rejectedRequest :: IO (Either StreamResetIsReceived ())+rejectedRequest = QUICC.run testClientConfig $ \conn ->+    E.bracket C.allocSimpleConfig C.freeSimpleConfig $ \conf ->+        C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+            E.try $ sendRequest (C.requestNoBody methodGet "/" []) $ \_ -> return ()

@@ -8,10 +8,13 @@ ) where  import Control.Concurrent (threadDelay)+import qualified Control.Exception as E import Data.ByteString (ByteString) import qualified Data.List as L import qualified Network.HTTP3.Client as H3+import qualified Network.Socket as NS import Network.TLS (Credentials (..), credentialLoadX509)+import System.IO.Unsafe (unsafePerformIO)  import Network.QUIC.Client import Network.QUIC.Internal@@ -28,10 +31,22 @@             , scALPN = Just chooseALPN             } +-- | The UDP port of this test process, one the OS had free.+--+-- It used to be 8003 for every run, and two runs at once -- from two+-- working trees, say -- reached each other's servers: a test failed, or+-- passed, against another run's server.+testPort :: NS.PortNumber+testPort = unsafePerformIO $+    E.bracket (NS.socket NS.AF_INET NS.Datagram NS.defaultProtocol) NS.close $ \s -> do+        NS.bind s $ NS.SockAddrInet 0 $ NS.tupleToHostAddress (127, 0, 0, 1)+        NS.socketPort s+{-# NOINLINE testPort #-}+ testServerConfig :: ServerConfig testServerConfig =     defaultServerConfig-        { scAddresses = [("127.0.0.1", 8003)]+        { scAddresses = [("127.0.0.1", testPort)]         , -- 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.@@ -42,7 +57,7 @@ testClientConfig :: ClientConfig testClientConfig =     defaultClientConfig-        { ccPortName = "8003"+        { ccPortName = show testPort         , ccValidate = False         } 

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}  module HTTP3.Error (     h3ErrorSpec,@@ -29,27 +30,16 @@  type Millisecond = Int +-- | Making a request, and then waiting for the connection error a test+-- expects, for as long as the timeout allows.+--+-- It used to wait a tenth of a second after the response.  A server+-- answering the request before it got round to the control stream, as one+-- under load could, then had the connection closed under it, and the test+-- failed for want of an error it was about to send. runC     :: ClientConfig -> H3.ClientConfig -> H3.Config -> Millisecond -> IO (Maybe ())-runC qcc cconf conf ms = timeout us $ run qcc $ \conn -> do-    info <- getConnectionInfo conn-    case alpn info of-        Just proto | "hq" `BS.isPrefixOf` proto -> do-            waitEstablished conn-            putStrLn $-                "Warning: "-                    ++ C8.unpack proto-                    ++ " is negotiated. Skipping this test. Use \"h3spec -s HTTP/3\" next time."-            E.throwIO $ ApplicationProtocolErrorIsReceived H3InternalError ""-        _ -> H3.run conn cconf conf client-  where-    us = ms * 1000-    client :: H3.Client ()-    client sendRequest _aux = do-        let req = H3.requestNoBody methodGet "/" []-        ret <- sendRequest req $ \_rsp -> return ()-        threadDelay 100000-        return ret+runC = runCReq $ H3.requestNoBody methodGet "/" []  -- | Like 'runC', but sending a request of our own choosing. runCReq@@ -59,20 +49,62 @@     -> H3.Config     -> Millisecond     -> IO (Maybe ())-runCReq req qcc cconf conf ms = timeout us $ run qcc $ \conn -> do+runCReq = runCWith True++-- | Like 'runCReq', for a test that expects no error: done a tenth of a+-- second after the response.+runCReqOk+    :: H3.Request+    -> ClientConfig+    -> H3.ClientConfig+    -> H3.Config+    -> Millisecond+    -> IO (Maybe ())+runCReqOk = runCWith False++-- | With 'True', a test that expects a connection error: a reset of the+-- request does not end it, since a server closing the connection may reset+-- its streams first.+runCWith+    :: Bool+    -> H3.Request+    -> ClientConfig+    -> H3.ClientConfig+    -> H3.Config+    -> Millisecond+    -> IO (Maybe ())+runCWith expectError req qcc cconf conf ms = timeout us $ run qcc $ \conn -> do     info <- getConnectionInfo conn     case alpn info of         Just proto | "hq" `BS.isPrefixOf` proto -> do             waitEstablished conn-            E.throwIO $ ApplicationProtocolErrorIsReceived H3InternalError ""+            E.throwIO $ HQNegotiated proto         _ -> H3.run conn cconf conf client   where     us = ms * 1000-    client sendRequest _aux = do-        ret <- sendRequest req $ \_rsp -> return ()-        threadDelay 100000-        return ret+    client :: H3.Client ()+    client sendRequest _aux+        | expectError = do+            _ <- E.try @StreamResetIsReceived $ sendRequest req $ \_rsp -> return ()+            threadDelay us+        | otherwise = do+            ret <- sendRequest req $ \_rsp -> return ()+            threadDelay 100000+            return ret +-- | Thrown when hq is negotiated instead of h3, so that the test is+-- reported as pending rather than passing on a generic error code.+newtype HQNegotiated = HQNegotiated BS.ByteString deriving (Show)++instance E.Exception HQNegotiated++-- | 'it' for the tests here, leaving a test pending against an hq server.+itH3 :: HasCallStack => String -> (a -> Expectation) -> SpecWith a+itH3 name body = it name $ \x ->+    body x `E.catch` \(HQNegotiated proto) ->+        pendingWith $+            C8.unpack proto ++ " is negotiated. Use \"h3spec -s HTTP/3\" next time."+ -- | The error cases for an HTTP/3 server. -- -- These also make h3spec, which runs them against a server somewhere else.@@ -89,184 +121,234 @@ h3ErrorSpec qcc cconf ms served = do     conf0 <- runIO H3.allocSimpleConfig     describe "HTTP/3 servers" $ do-        it+        itH3             "MUST send H3_FRAME_UNEXPECTED if DATA is received before HEADERS [HTTP/3 4.1]"             $ \_ -> do                 let conf = addHook conf0 $ setOnHeadersFrameCreated requestIllegalData                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected]-        it "MUST send H3_MESSAGE_ERROR if a pseudo-header is duplicated [HTTP/3 4.1.1]" $ \_ -> do-            let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader3-                qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")-            runC qcc' cconf conf ms-                `shouldThrow` applicationProtocolErrorsIn [H3MessageError]-        it-            "MUST send H3_MESSAGE_ERROR if mandatory pseudo-header fields are absent [HTTP/3 4.1.3]"+        itH3+            "MUST send H3_MESSAGE_ERROR if a pseudo-header is duplicated [HTTP/3 4.3.1]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader3+                    qcc' = throwOnReset qcc+                runC qcc' cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3MessageError]+        itH3+            "MUST send H3_MESSAGE_ERROR if mandatory pseudo-header fields are absent [HTTP/3 4.3.1]"             $ \x -> do                 let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader0-                    qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")+                    qcc' = throwOnReset qcc                 refusedNotServed (served x) $                     runC qcc' cconf conf ms                         `shouldThrow` applicationProtocolErrorsIn [H3MessageError]-        it-            "MUST send H3_MESSAGE_ERROR if prohibited pseudo-header fields are present[HTTP/3 4.1.3]"+        itH3+            "MUST send H3_MESSAGE_ERROR if prohibited pseudo-header fields are present [HTTP/3 4.3]"             $ \_ -> do                 let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader1-                    qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")+                    qcc' = throwOnReset qcc                 runC qcc' cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3MessageError]-        it-            "MUST send H3_MESSAGE_ERROR if pseudo-header fields exist after fields [HTTP/3 4.1.3]"+        itH3+            "MUST send H3_MESSAGE_ERROR if pseudo-header fields exist after fields [HTTP/3 4.3]"             $ \_ -> do                 let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader2-                    qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")+                    qcc' = throwOnReset qcc                 runC qcc' cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3MessageError]         forM_ connectionSpecific $ \field@(name, _) ->-            it+            itH3                 ( "MUST treat a request with "                     ++ C8.unpack (CI.original name)                     ++ " as malformed [HTTP/3 4.2]"                 )                 $ \x -> do                     let req = H3.requestNoBody methodGet "/" [field]-                        qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")+                        qcc' = throwOnReset qcc                     refusedNotServed (served x) $                         runCReq req qcc' cconf conf0 ms                             `shouldThrow` applicationProtocolErrorsIn [H3MessageError]-        it "MUST accept TE with trailers [HTTP/3 4.2]" $ \_ -> do+        itH3 "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+            runCReqOk req qcc cconf conf0 ms `shouldReturn` Just ()+        itH3             "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                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3MissingSettings]-        it+        itH3             "MUST send H3_FRAME_UNEXPECTED if a DATA frame is received on a control stream [HTTP/3 7.2.1]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlFrameCreated controlData                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected]-        it+        itH3             "MUST send H3_FRAME_UNEXPECTED if a HEADERS frame is received on a control stream [HTTP/3 7.2.2]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlFrameCreated controlHeaders                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected]-        it+        itH3             "MUST send H3_FRAME_UNEXPECTED if a second SETTINGS frame is received [HTTP/3 7.2.4]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlFrameCreated doubleSettings                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected]         {- this is MAY-                it "MUST send H3_SETTINGS_ERROR if duplicate setting identifiers exist [HTTP/3 7.2.4]" $ \_ -> do+                itH3 "MUST send H3_SETTINGS_ERROR if duplicate setting identifiers exist [HTTP/3 7.2.4]" $ \_ -> do                     let conf = addHook conf0 $ setOnControlFrameCreated illegalSettings0                     runC qcc cconf conf ms `shouldThrow` applicationProtocolErrorsIn [H3SettingsError]         -}-        it+        itH3             "MUST send H3_SETTINGS_ERROR if HTTP/2 settings are included [HTTP/3 7.2.4.1]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlFrameCreated illegalSettings1                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3SettingsError]-        it+        itH3             "MUST send H3_FRAME_ERROR if a SETTINGS frame stops mid-parameter [HTTP/3 7.1]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlFrameCreated truncatedSettings                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3FrameError]-        it+        itH3             "MUST NOT stop reading settings at a reserved identifier [HTTP/3 7.2.4.1]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlFrameCreated greaseThenHttp2Setting                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3SettingsError]-        it-            "treats a repeated setting identifier as an error whatever its value [HTTP/3 7.2.4.1]"+        itH3+            "treats a repeated setting identifier as an error whatever its value [HTTP/3 7.2.4]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlFrameCreated duplicateLargeSetting                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3SettingsError]-        it-            "MUST send H3_FRAME_UNEXPECTED if CANCEL_PUSH is received in a request stream [HTTP/3 7.2.5]"+        itH3+            "MUST send H3_FRAME_UNEXPECTED if CANCEL_PUSH is received in a request stream [HTTP/3 7.2.3]"             $ \_ -> do                 let conf = addHook conf0 $ setOnHeadersFrameCreated requestCancelPush                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected]-        it-            "MUST send QPACK_DECOMPRESSION_FAILED if an invalid static table index exits in a field line representation [QPACK 3.1]"+        itH3+            "MUST send H3_FRAME_UNEXPECTED if PUSH_PROMISE is received [HTTP/3 7.2.5]"             $ \_ -> do+                let conf = addHook conf0 $ setOnHeadersFrameCreated requestPushPromise+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3FrameUnexpected]+        itH3+            "MUST send H3_ID_ERROR if CANCEL_PUSH names a push ID not allowed [HTTP/3 7.2.3]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnControlFrameCreated cancelPushNotAllowed+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3IdError]+        itH3+            "MUST send H3_ID_ERROR if MAX_PUSH_ID goes down [HTTP/3 7.2.7]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnControlFrameCreated maxPushIdDown+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3IdError]+        itH3+            "MUST send H3_ID_ERROR if GOAWAY goes up [HTTP/3 5.2]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnControlFrameCreated goawayUp+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3IdError]+        itH3+            "MUST send H3_FRAME_ERROR if MAX_PUSH_ID has octets after its push ID [HTTP/3 7.1]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnControlFrameCreated maxPushIdTrailing+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [H3FrameError]+        itH3+            "MUST ignore a frame of unknown type, however long [HTTP/3 7.2.8]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnControlFrameCreated longUnknownFrame+                runCReqOk (H3.requestNoBody methodGet "/" []) qcc cconf conf ms+                    `shouldReturn` Just ()+        itH3+            "MUST send QPACK_DECOMPRESSION_FAILED if an invalid static table index exists in a field line representation [QPACK 3.1]"+            $ \_ -> do                 let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader4                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [QpackDecompressionFailed]-        it-            "MUST send QPACK_DECOMPRESSION_FAILED if a field line references a dynamic table entry that is not there [QPACK 2.1.2]"+        itH3+            "MUST send QPACK_DECOMPRESSION_FAILED if a field line references a dynamic table entry that is not there [QPACK 2.2.3]"             $ \_ -> do                 let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader5                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [QpackDecompressionFailed]-        it-            "MUST NOT buffer a frame longer than SETTINGS_MAX_FIELD_SECTION_SIZE [HTTP/3 7.1]"+        itH3+            "MUST send QPACK_DECOMPRESSION_FAILED if a field line is cut short [QPACK 2.2.3]"             $ \_ -> do+                let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader6+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [QpackDecompressionFailed]+        itH3+            "MUST send QPACK_DECOMPRESSION_FAILED if a Huffman string is badly padded [QPACK 4.1.2]"+            $ \_ -> do+                let conf = addHook conf0 $ setOnHeadersFrameCreated illegalHeader7+                runC qcc cconf conf ms+                    `shouldThrow` applicationProtocolErrorsIn [QpackDecompressionFailed]+        itH3+            "MUST NOT buffer an over-long frame on a control stream [HTTP/3 7.1]"+            $ \_ -> do                 let conf = addHook conf0 $ setOnControlStreamCreated overLongFrame                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3ExcessiveLoad]-        it-            "MUST send QPACK_ENCODER_STREAM_ERROR if a new dynamic table capacity value exceeds the limit [QPACK 4.1.3]"+        itH3+            "MUST send QPACK_ENCODER_STREAM_ERROR if a new dynamic table capacity value exceeds the limit [QPACK 4.3.1]"             $ \_ -> do                 let conf = addHook conf0 $ setOnEncoderStreamCreated largeTableCapacity                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [QpackEncoderStreamError]-        it-            "MUST send H3_CLOSED_CRITICAL_STREAM if a control stream is closed [QPACK 4.2]"+        itH3+            "MUST send H3_CLOSED_CRITICAL_STREAM if a control stream is closed [HTTP/3 6.2.1]"             $ \_ -> do                 let conf = addHook conf0 $ setOnControlStreamCreated closeStream                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream]-        it+        itH3             "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.                 opened <- newIORef False                 let conf = addHook conf0 $ setOnControlStreamCreated $ openAnother opened "\x00\x04\x00"                 expectIfOpened opened (runC qcc cconf conf ms) [H3StreamCreationError]-        it+        itH3             "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.                 opened <- newIORef False                 let conf = addHook conf0 $ setOnControlStreamCreated $ openAnother opened "\x01\x00"                 expectIfOpened opened (runC qcc cconf conf ms) [H3StreamCreationError]-        it+        itH3             "MUST send H3_STREAM_CREATION_ERROR if a second encoder stream is opened [QPACK 4.2]"             $ \_ -> do                 opened <- newIORef False                 let conf = addHook conf0 $ setOnEncoderStreamCreated $ openAnother opened "\x02"                 expectIfOpened opened (runC qcc cconf conf ms) [H3StreamCreationError]-        it+        itH3             "MUST send H3_STREAM_CREATION_ERROR if a second decoder stream is opened [QPACK 4.2]"             $ \_ -> do                 opened <- newIORef False                 let conf = addHook conf0 $ setOnDecoderStreamCreated $ openAnother opened "\x03"                 expectIfOpened opened (runC qcc cconf conf ms) [H3StreamCreationError]-        it+        itH3             "MUST send H3_CLOSED_CRITICAL_STREAM if an encoder stream is closed [QPACK 4.2]"             $ \_ -> do                 let conf =                         noEncoderTable $ addHook conf0 $ setOnEncoderStreamCreated closeStream                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream]-        it+        itH3             "MUST send H3_CLOSED_CRITICAL_STREAM if a decoder stream is closed [QPACK 4.2]"             $ \_ -> do                 let conf =                         noDecoderTable $ addHook conf0 $ setOnDecoderStreamCreated closeStream                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream]-        it+        itH3             "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.@@ -275,7 +357,7 @@                         closeStream strm                 runC qcc cconf conf ms                     `shouldThrow` applicationProtocolErrorsIn [H3ClosedCriticalStream]-        it+        itH3             "MUST send QPACK_DECODER_STREAM_ERROR if Insert Count Increment is 0 [QPACK 4.4.3]"             $ \_ -> do                 let conf = addHook conf0 $ setOnDecoderStreamCreated zeroInsertCountIncrement@@ -333,23 +415,23 @@ h3DrainSpec qcc cconf ms = do     conf0 <- runIO H3.allocSimpleConfig     describe "HTTP/3 servers reading a request's body" $ do-        it+        itH3             "MUST treat content that does not match content-length as malformed [HTTP/3 4.1.2]"             $ \_ -> do                 -- content-length says five octets and the request carries                 -- none.  /drain reads the body, which is where the count is                 -- checked; a body nobody reads is never counted.                 let req = H3.requestNoBody methodPost "/drain" [("content-length", "5")]-                    qcc' = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr -> E.throwIO (ApplicationProtocolErrorIsReceived aerr "")+                    qcc' = throwOnReset qcc                 runCReq req qcc' cconf conf0 ms                     `shouldThrow` applicationProtocolErrorsIn [H3MessageError]-        it+        itH3             "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 "")+                    qcc' = throwOnReset qcc                 runCReq req qcc' cconf conf0 ms                     `shouldThrow` applicationProtocolErrorsIn [H3MessageError] @@ -392,6 +474,32 @@ requestCancelPush :: [H3Frame] -> [H3Frame] requestCancelPush fs = H3Frame H3FrameCancelPush "" : fs +-- PUSH_PROMISE, push ID 0, and no field section to speak of.  Before+-- HEADERS, since a server need not read what comes after them.+requestPushPromise :: [H3Frame] -> [H3Frame]+requestPushPromise fs = H3Frame H3FramePushPromise "\x00" : fs++-- CANCEL_PUSH for push ID 0, with no MAX_PUSH_ID sent: no push is allowed.+cancelPushNotAllowed :: [H3Frame] -> [H3Frame]+cancelPushNotAllowed fs = fs ++ [H3Frame H3FrameCancelPush "\x00"]++-- MAX_PUSH_ID 5, then 3.+maxPushIdDown :: [H3Frame] -> [H3Frame]+maxPushIdDown fs = fs ++ [H3Frame H3FrameMaxPushId "\x05", H3Frame H3FrameMaxPushId "\x03"]++-- GOAWAY 0, then 4.+goawayUp :: [H3Frame] -> [H3Frame]+goawayUp fs = fs ++ [H3Frame H3FrameGoaway "\x00", H3Frame H3FrameGoaway "\x04"]++-- MAX_PUSH_ID 5, and an octet more.+maxPushIdTrailing :: [H3Frame] -> [H3Frame]+maxPushIdTrailing fs = fs ++ [H3Frame H3FrameMaxPushId "\x05\x00"]++-- A reserved type (0x21), with a payload longer than+-- SETTINGS_MAX_FIELD_SECTION_SIZE.+longUnknownFrame :: [H3Frame] -> [H3Frame]+longUnknownFrame fs = fs ++ [H3Frame (H3FrameUnknown 0x21) (BS.replicate 40000 0)]+ requestIllegalData :: [H3Frame] -> [H3Frame] requestIllegalData fs = H3Frame H3FrameData "" : fs @@ -466,6 +574,34 @@         "\x00\x00\xd1\xd7\x50\x09\x31\x32\x37\x2e\x30\x2e\x30\x2e\x31\xc1\x80"     ] +-- [(":method","GET")+-- ,(":scheme","https")+-- ,(":authority","127.0.0.1")+-- ,(":path","/")] ++ age with a value of five octets, of which two are there+--+-- Running off the end of the section raised BufferOverrun, which the server+-- answered with a stream reset of H3_MESSAGE_ERROR.+illegalHeader6 :: [H3Frame] -> [H3Frame]+illegalHeader6 _ =+    [ H3Frame+        H3FrameHeaders+        "\x00\x00\xd1\xd7\x50\x09\x31\x32\x37\x2e\x30\x2e\x30\x2e\x31\xc1\x52\x05ab"+    ]++-- [(":method","GET")+-- ,(":scheme","https")+-- ,(":authority","127.0.0.1")+-- ,(":path","/")] ++ age with a one-octet Huffman value of 0x00+--+-- The three bits left over are padding, which must be the start of EOS:+-- ones (RFC 7541, section 5.2).+illegalHeader7 :: [H3Frame] -> [H3Frame]+illegalHeader7 _ =+    [ H3Frame+        H3FrameHeaders+        "\x00\x00\xd1\xd7\x50\x09\x31\x32\x37\x2e\x30\x2e\x30\x2e\x31\xc1\x52\x81\x00"+    ]+ {- -- [(SettingsQpackBlockedStreams,100) -- ,(SettingsQpackMaxTableCapacity,4096)@@ -586,6 +722,11 @@ addQUICHook cc modify = cc'   where     cc' = cc{ccHooks = modify $ ccHooks cc}++-- | Turning a RESET_STREAM from the server into the exception the tests expect.+throwOnReset :: ClientConfig -> ClientConfig+throwOnReset qcc = addQUICHook qcc $ setOnResetStreamReceived $ \_strm aerr ->+    E.throwIO (ApplicationProtocolErrorIsReceived aerr "")  setOnResetStreamReceived     :: (Stream -> ApplicationProtocolError -> IO ()) -> Hooks -> Hooks

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HTTP3.GoAwaySpec where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import qualified Control.Exception as E+import Network.HTTP.Types+import qualified Network.HTTP3.Client as C+import Network.HTTP3.Server+import qualified Network.QUIC.Client as QUICC+import qualified Network.QUIC.Server as QUICS+import System.Timeout (timeout)+import Test.Hspec++import HTTP3.Config+import HTTP3.Server (teardown)++spec :: Spec+spec =+    describe "H3 server going away" $+        -- RFC 9114, section 5.2: the request taken before GOAWAY is answered,+        -- one opened after it is rejected, and the connection then ends.+        do+            it "answers the request it took and rejects a later one" $ do+                stop <- newTVarIO False+                returned <- newEmptyMVar+                E.bracket (setupGoAway stop returned) teardown $ \_ -> do+                    -- Long after the second GOAWAY.+                    timeout 5000000 (slowThenFast 500000 stop) `shouldReturn` Just (Just ok200, False)+                    timeout 3000000 (takeMVar returned) `shouldReturn` Just ()+            -- The first GOAWAY has the largest identifier, and the second+            -- comes a PTO later: a request sent in between is taken.+            it "answers a request sent between its two GOAWAYs" $ do+                stop <- newTVarIO False+                returned <- newEmptyMVar+                E.bracket (setupGoAway stop returned) teardown $ \_ -> do+                    timeout 5000000 (slowThenFast 0 stop) `shouldReturn` Just (Just ok200, True)+                    timeout 3000000 (takeMVar returned) `shouldReturn` Just ()++-- | A server going away once the variable is set; the 'MVar' is filled when+-- 'runWith' returns.  "/slow" is answered after a second.+setupGoAway :: TVar Bool -> MVar () -> IO ThreadId+setupGoAway stop returned = do+    sc <- makeTestServerConfig+    tid <- forkIO $ QUICS.run sc $ \conn ->+        E.bracket allocSimpleConfig freeSimpleConfig $ \conf -> do+            runWith (readTVar stop >>= check) conn conf svr+            putMVar returned ()+    threadDelay 500000 -- give enough time to the server+    return tid+  where+    svr req _aux sendResponse = do+        case requestPath req of+            Just "/slow" -> threadDelay 1000000+            _ -> return ()+        sendResponse (responseBuilder ok200 [] "hello") []++-- | A request for "/slow"; the server told to go away; then, after the+-- delay, a request for "/".  The status of the first, and whether the+-- second succeeded.+slowThenFast :: Int -> TVar Bool -> IO (Maybe Status, Bool)+slowThenFast delay stop = QUICC.run testClientConfig $ \conn ->+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+        C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+            let get path = sendRequest (C.requestNoBody methodGet path []) $ return . C.responseStatus+            slow <- async $ get "/slow"+            threadDelay 100000+            atomically $ writeTVar stop True+            threadDelay delay+            fast <- E.try $ get "/"+            s <- wait slow+            return (s, either (\(_ :: E.SomeException) -> False) (const True) fast)

@@ -23,10 +23,13 @@ -- 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" $+    describe "H3 server keeping to a limit it does not announce" $ do         it "answers 431 to a request header section over its limit" $             E.bracket (setupWith hideLimit server 4096) teardown $                 \_ -> runTooLargeClient+        it "answers 431 to a HEADERS frame longer than its limit" $+            E.bracket (setupWith hideLimit server 4096) teardown $+                \_ -> runTooLongFrameClient  -- | SETTINGS with the dynamic table as the test server has it, and without -- SETTINGS_MAX_FIELD_SECTION_SIZE: QPACK_MAX_TABLE_CAPACITY 4096 and@@ -54,5 +57,17 @@             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++-- | One field with a 40000-octet value of "~", which Huffman makes no shorter: the+-- HEADERS frame itself is longer than the server's 32768.  The section was+-- refused with the 431 above only once decoded, and a frame this long closed+-- the whole connection with H3_EXCESSIVE_LOAD instead.+runTooLongFrameClient :: IO ()+runTooLongFrameClient = QUIC.run testClientConfig $ \conn ->+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+        C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+            let req = C.requestNoBody methodGet "/" [("x-a", B.replicate 40000 0x7e)]             sendRequest req $ \rsp ->                 C.responseStatus rsp `shouldBe` Just requestHeaderFieldsTooLarge431

@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTP3.RunIOSpec where++import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+import Network.HTTP.Types+import qualified Network.HTTP3.Client as C+import Network.HTTP3.Server+import qualified Network.QUIC as QUIC+import qualified Network.QUIC.Client as QUICC+import qualified Network.QUIC.Server as QUICS+import System.Timeout (timeout)+import Test.Hspec hiding (runIO)++import HTTP3.Config+import HTTP3.Server (teardown)++spec :: Spec+spec =+    describe "H3 server with runIO" $ do+        it "serves a request while an earlier stream has sent no HEADERS" $+            E.bracket setupIO teardown $ \_ ->+                timeout 3000000 stalledThenRequest `shouldReturn` Just ()+        it "returns once sioDone is called and the requests are answered" $ do+            returned <- newEmptyMVar+            E.bracket (setupDone returned) teardown $ \_ -> do+                -- sioDone comes before the response: the request is still+                -- answered, and only then does runIO return.+                timeout 3000000 oneRequest `shouldReturn` Just ()+                timeout 3000000 (takeMVar returned) `shouldReturn` Just ()++setupIO :: IO ThreadId+setupIO = do+    sc <- makeTestServerConfig+    tid <- forkIO $ QUICS.run sc $ \conn ->+        E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+            runIO conn conf $ \sio -> return $ forever $ do+                (strm, _req) <- sioReadRequest sio+                sioWriteResponse sio strm $ responseBuilder ok200 [] "hello"+    threadDelay 500000 -- give enough time to the server+    return tid++-- | A server whose application takes one request, calls 'sioDone', and+-- then answers it.  The 'MVar' is filled when 'runIO' returns.+setupDone :: MVar () -> IO ThreadId+setupDone returned = do+    sc <- makeTestServerConfig+    tid <- forkIO $ QUICS.run sc $ \conn ->+        E.bracket allocSimpleConfig freeSimpleConfig $ \conf -> do+            runIO conn conf $ \sio -> return $ do+                (strm, _req) <- sioReadRequest sio+                sioDone sio+                sioWriteResponse sio strm $ responseBuilder ok200 [] "hello"+                forever $ sioReadRequest sio+            putMVar returned ()+    threadDelay 500000 -- give enough time to the server+    return tid++oneRequest :: IO ()+oneRequest = QUICC.run testClientConfig $ \conn ->+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+        C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+            sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->+                C.responseStatus rsp `shouldBe` Just ok200++-- | A bidirectional stream carrying only the type of a HEADERS frame, and+-- then an ordinary request on the same connection.+stalledThenRequest :: IO ()+stalledThenRequest = QUICC.run testClientConfig $ \conn -> do+    strm <- QUIC.stream conn+    QUIC.sendStream strm "\x01"+    E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+        C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+            sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->+                C.responseStatus rsp `shouldBe` Just ok200

@@ -61,6 +61,12 @@             runResetRequestClient         it "resets a request interrupted before its body is sent" $ \_ ->             runInterruptedRequestClient+        it "does not hand the handler a CANCEL_PUSH it refused as body" $ \_ ->+            runCancelPushInBodyClient+        it "refuses DATA after trailers" $ \_ ->+            runDataAfterTrailersClient+        it "sends a request whose trailers maker answers early" $ \_ ->+            runEarlyTrailersClient         it "accepts a content-length on a response with no content" $ \_ ->             runNoContentClient         it "closes the connection on a stream ending in the middle of a frame" $ \_ ->@@ -344,6 +350,63 @@                 r                     `shouldBe` Just                         (Left (show (StreamResetIsReceived H3RequestCancelled)))++-- | A CANCEL_PUSH frame where the body should be.  It is a connection error+-- (RFC 9114, section 7.2.3), and its payload used to go on to the handler+-- as body all the same, since 'abort' did not stop the reader.+runCancelPushInBodyClient :: IO ()+runCancelPushInBodyClient = do+    _ <- tryTakeMVar recordedBody+    _ <- E.try @E.SomeException $ QUIC.run testClientConfig $ \conn ->+        E.bracket allocSimpleConfig freeSimpleConfig $ \conf0 -> do+            let cancelPush = H3Frame H3FrameCancelPush "abc"+                hooks = (confHooks conf0){C.onHeadersFrameCreated = (++ [cancelPush])}+                conf = conf0{confHooks = hooks}+            C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+                void $ timeout 1000000 $ sendRequest (C.requestNoBody methodPost "/record" []) $ \_ ->+                    return ()+    r <- timeout 1000000 $ takeMVar recordedBody+    r `shouldSatisfy` \x -> case x of+        Just (Right _) -> False+        _ -> True++-- | A trailers maker that answers with the trailers at the first chunk of+-- the body, rather than asking to be called again.  The sender took that+-- for granted and failed with a pattern match.+runEarlyTrailersClient :: IO ()+runEarlyTrailersClient = do+    _ <- tryTakeMVar recordedBody+    QUIC.run testClientConfig $ \conn ->+        E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+            C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+                let req0 = C.requestBuilder methodPost "/record" [] "hello"+                    req = C.setRequestTrailersMaker req0 $ \_ ->+                        return $ C.Trailers [("x-t", "1")]+                sendRequest req $ \rsp -> C.responseStatus rsp `shouldBe` Just ok200+    timeout 1000000 (takeMVar recordedBody) `shouldReturn` Just (Right 5)++-- | A DATA frame after the trailers, which RFC 9114, section 4.1, makes+-- H3_FRAME_UNEXPECTED.  Whatever followed the trailers used to be dropped+-- unread, and the handler was told of a whole body.+--+-- The hook puts the DATA after every HEADERS frame: after the request's, where+-- it is body, and after the trailers.+runDataAfterTrailersClient :: IO ()+runDataAfterTrailersClient = do+    _ <- tryTakeMVar recordedBody+    _ <- E.try @E.SomeException $ QUIC.run testClientConfig $ \conn ->+        E.bracket allocSimpleConfig freeSimpleConfig $ \conf0 -> do+            let extra = H3Frame H3FrameData "zz"+                hooks = (confHooks conf0){C.onHeadersFrameCreated = (++ [extra])}+                conf = conf0{confHooks = hooks}+                req0 = C.requestBuilder methodPost "/record" [] "hello"+                req = C.setRequestTrailersMaker req0 (trailersMaker hashInit)+            C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+                void $ timeout 1000000 $ sendRequest req $ \_ -> return ()+    r <- timeout 1000000 $ takeMVar recordedBody+    r `shouldSatisfy` \x -> case x of+        Just (Right _) -> False+        _ -> True  -- | Responses with no content and a content-length of 1000: to HEAD, and a -- 304.  The client checked the empty body against it and refused them with

@@ -14,7 +14,9 @@ import Network.HPACK.Token (toToken) import Network.QPACK import Network.QPACK.Internal (+    DecodeError (..),     DecoderInstruction (..),+    DecoderInstructionError (..),     EncoderInstruction (..),     EncoderInstructionError (..),     encodeDecoderInstructions,@@ -246,6 +248,41 @@             drain diRef handleDI             enc 12 hdr >>= (`shouldSatisfy` (/= 0)) . encodedInsertCount +        it "refuses an Insert Count Increment beyond what was inserted" $ do+            -- One entry inserted, five acknowledged.  It used to be added to+            -- the Known Received Count unchecked (RFC 9204, section 4.4.3).+            diRef <- newIORef []+            (enc, handleDI, tblop) <- newQEncoder defaultQEncoderConfig (\_ -> return ())+            setCapacity tblop 4096+            setBlockedStreams tblop 100+            let hdr = [(toToken "x-foo", "bar")]+            -- Inserted the second time it is seen.+            mapM_ (`enc` hdr) [0, 4]+            di <- encodeDecoderInstructions [InsertCountIncrement 5]+            writeIORef diRef [di]+            E.try (drain diRef handleDI) `shouldReturn` Left DecoderInstructionError++        it "refuses a reference at or above the Required Insert Count" $ do+            -- Entry 0 is in the table, but a section whose Required Insert+            -- Count is 0 may not name it (RFC 9204, section 2.2.3).+            -- Prefix 0x00 0x01: Required Insert Count 0, Base 1; then an+            -- Indexed Field Line, pre-base index 0, which is entry 0.+            dec <- decoderWithOneEntry+            decodeError (dec 0 "\x00\x01\x80")+                `shouldReturn` Left (IllegalDynamicIndex 0)++        it "refuses a negative Base" $ do+            -- Required Insert Count 1 (encoded 2), the sign bit and Delta+            -- Base 5: a Base of -5 (RFC 9204, section 4.5.1.2).+            dec <- decoderWithOneEntry+            decodeError (dec 0 "\x02\x85\x10") `shouldReturn` Left IllegalBase++        it "refuses an encoded Required Insert Count that comes to 0" $ do+            -- Encoded 1 with nothing inserted is 0, which has to be encoded+            -- as 0 (RFC 9204, section 4.5.1.1).  Then :method GET.+            (dec, _) <- newQDecoder defaultQDecoderConfig (\_ -> return ())+            decodeError (dec 0 "\x01\x00\xd1") `shouldReturn` Left IllegalInsertCount+         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.@@ -326,6 +363,22 @@     handler $ \_ -> atomicModifyIORef' queue $ \xs -> case xs of         [] -> ([], "")         y : ys -> (ys, y)++-- | The 'DecodeError' an action throws, if any.+decodeError :: IO a -> IO (Either DecodeError ())+decodeError io = E.try (void io)++-- | A decoder that has been sent one entry, x-foo: bar.+decoderWithOneEntry :: IO QDecoder+decoderWithOneEntry = do+    (dec, handleEI) <- newQDecoder defaultQDecoderConfig (\_ -> return ())+    ei <-+        encodeEncoderInstructions+            [SetDynamicTableCapacity 4096, InsertWithLiteralName (toToken "x-foo") "bar"]+            False+    ref <- newIORef [ei]+    drain ref handleEI+    return dec  roundTrip :: Int -> IO () roundTrip n = do

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}  module QPACK.QIF2Spec where @@ -15,7 +16,7 @@ import Network.HTTP.Semantics import Network.HTTP.Semantics.Client.Internal import Network.HTTP.Semantics.Server-import Network.HTTP.Types (RequestHeaders, notFound404, ok200)+import Network.HTTP.Types (RequestHeaders, ok200) import qualified Network.HTTP3.Client as C import Network.HTTP3.Server import qualified Network.HTTP3.Server as S@@ -70,7 +71,9 @@     -- delay for set table capacity     threadDelay 10000     ms <- forkClient 0 id-    mapM_ takeMVar ms+    -- A failure in a request's thread is brought back here.  It used to+    -- kill the thread before it said it was done, and the test hung.+    mapM takeMVar ms >>= mapM_ (either E.throwIO return)   where     forkClient n build = do         hs <- headerlist hdl@@ -80,16 +83,23 @@                 var <- newEmptyMVar                 _ <- forkIO $ do                     let req = requestBuilder2 hs mempty-                    _ <- sendRequest req $ checkHeader hs-                    putMVar var ()+                    r <- E.try @E.SomeException $ sendRequest req $ checkHeader hs+                    putMVar var $ void r                 when ((n :: Int) `mod` 50 == 0) $ threadDelay 100000                 forkClient (n + 1) (build . (var :))     checkHeader hs rsp = do         bs <- getBody-        let hs0 = map keyValue $ split bs-            hs0' = sort $ filter (\(k, _) -> k == "cookie:") hs0-            hs' = sort $ filter (\(k, _) -> k == "cookie:") hs-        hs0' `shouldBe` hs'+        -- Every field but the pseudo-header ones, which the client may+        -- add to or rewrite.  This compared fields named "cookie:", which+        -- there are none of, and so compared two empty lists.+        -- Cookies are split into crumbs on both sides: the server joins+        -- them with "; " (RFC 9114, section 4.2.1).+        let regular = sort . concatMap crumbs . filter ((/= ":") . B.take 1 . foldedCase . fst)+            crumbs (k, v)+                | k == "cookie" = map ((,) k) $ splitOn "; " v+                | otherwise = [(k, v)]+            hs0 = map keyValue $ split bs+        regular hs0 `shouldBe` regular hs       where         getBody = B.concat <$> loop id         loop build = do@@ -104,15 +114,18 @@               where                 (l, ls') = C8.break (== '\n') ls                 ls'' = C8.drop 1 ls'+        splitOn sep s = case B.breakSubstring sep s of+            (x, "") -> [x]+            (x, rest) -> x : splitOn sep (B.drop (B.length sep) rest)         keyValue kv = (mk k, v)           where             (k, v') = C8.break (== ' ') kv             v = C8.drop 1 v' +-- | Answering with the fields of the request, whatever its method: the QIF+-- file has POSTs as well as GETs. server :: Server-server req _aux sendResponse = case requestMethod req of-    Just "GET" -> sendResponse (responseSection req) []-    _ -> sendResponse (responseNoBody notFound404 []) []+server req _aux sendResponse = sendResponse (responseSection req) []  responseSection :: S.Request -> S.Response responseSection req = responseBuilder ok200 header body

@@ -8,8 +8,8 @@ import Control.Monad import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8+import Data.Maybe (fromMaybe) import Data.UnixTime-import Data.Word import Foreign.C.Types import qualified Network.HTTP3.Client as H3 import Network.TLS.QUIC@@ -18,6 +18,7 @@ import System.Exit import qualified System.Timeout as T import Text.Printf+import Text.Read (readMaybe)  import ClientX import Common@@ -41,7 +42,6 @@     , optInteractive :: Bool     , optMigration :: Maybe ConnectionControl     , optPacketSize :: Maybe Int-    , optPerformance :: Word64     , optNumOfReqs :: Int     }     deriving (Show)@@ -64,7 +64,6 @@         , optInteractive = False         , optMigration = Nothing         , optPacketSize = Nothing-        , optPerformance = 0         , optNumOfReqs = 1         } @@ -111,7 +110,7 @@     , Option         ['s']         ["packet-size"]-        (ReqArg (\n o -> o{optPacketSize = Just (read n)}) "<size>")+        (ReqArg (\n o -> o{optPacketSize = Just (fromMaybe 0 (readMaybe n))}) "<size>")         "specify QUIC packet size (UDP payload size)"     , Option         ['i']@@ -164,14 +163,9 @@         (NoArg (\o -> o{optMigration = Just ActiveMigration}))         "use a new address and a new server CID"     , Option-        ['t']-        ["performance"]-        (ReqArg (\n o -> o{optPerformance = read n}) "<size>")-        "measure performance"-    , Option         ['n']         ["number-of-requests"]-        (ReqArg (\n o -> o{optNumOfReqs = read n}) "<n>")+        (ReqArg (\n o -> o{optNumOfReqs = fromMaybe 0 (readMaybe n)}) "<n>")         "specify the number of requests"     ] @@ -197,14 +191,19 @@         h : p : [] -> return (h, p, ["/"])         h : p : ps -> return (h, p, C8.pack <$> ps)     cmvar <- newEmptyMVar-    let ccalpn ver-            | optPerformance /= 0 = return $ Just ["perf"]-            | otherwise =-                let (h3X, hqX) = makeProtos ver-                    protos-                        | optHQ = [hqX, h3X]-                        | otherwise = [h3X, hqX]-                 in return $ Just protos+    -- Bad numbers are left as 0 by the options, and refused here.  They+    -- used to stop the program with "Prelude.read: no parse", and a+    -- negative number of requests never ended.+    when (maybe False (<= 0) optPacketSize) $+        showUsageAndExit "packet size must be a positive integer"+    when (optNumOfReqs <= 0) $+        showUsageAndExit "number of requests must be a positive integer"+    let ccalpn ver =+            let (h3X, hqX) = makeProtos ver+                protos+                    | optHQ = [hqX, h3X]+                    | otherwise = [h3X, hqX]+             in return $ Just protos         gvers vers             | optVerNego = GreasingVersion : vers             | otherwise = vers

@@ -5,6 +5,7 @@  module Main where +import qualified Control.Exception as E import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -15,6 +16,7 @@ import System.Environment (getArgs) import System.Exit import System.IO+import Text.Read (readMaybe)  import Common import Network.QUIC@@ -100,8 +102,6 @@         (_, _, errs) -> showUsageAndExit $ concat errs  chooseALPN :: Version -> [ByteString] -> IO ByteString-chooseALPN _ protos-    | "perf" `elem` protos = return "perf" chooseALPN ver protos = return $ case mh3idx of     Nothing -> case mhqidx of         Nothing -> ""@@ -120,11 +120,15 @@     args <- getArgs     (Options{..}, ips) <- serverOpts args     when (length ips < 2) $ showUsageAndExit "cannot recognize <addr> and <port>\n"-    let port = read (last ips)-        addrs = read <$> init ips-        aps = (,port) <$> addrs+    aps <- case (,) <$> mapM readMaybe (init ips) <*> readMaybe (last ips) of+        Nothing -> showUsageAndExit "cannot parse <addr> or <port>\n"+        Just (addrs, port) -> return $ (,port) <$> addrs     smgr <- SM.newSessionManager SM.defaultConfig-    Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile+    let loadCred =+            credentialLoadX509 optCertFile optKeyFile+                `E.catch` \e -> return $ Left $ show (e :: E.IOException)+    cred@(!_cc, !_priv) <-+        loadCred >>= either (showUsageAndExit . ("cannot load credentials: " ++)) return     let sc0 = defaultServerConfig         sc =             sc0

@@ -4,6 +4,7 @@  module Main where +import Control.Monad (unless) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Conduit.Attoparsec@@ -123,9 +124,16 @@     ratio <- newIORef $ Ratio{ratioInst = 0, ratioHeader = 0}     withFile qfile ReadMode $ \h -> do         processBlock efile $ testSwitch dec insthdr ref h ratio+        waiting <- readIORef ref+        unless (Seq.null waiting) $ do+            putStrLn $ show (Seq.length waiting) ++ " blocks never decoded"+            exitFailure         r <- readIORef ratio-        let (x, y) = ((ratioInst r * 1000) `div` ratioHeader r) `divMod` 10-        putStrLn $ show x ++ "." ++ show y+        if ratioHeader r == 0+            then putStrLn "no blocks"+            else do+                let (x, y) = ((ratioInst r * 1000) `div` ratioHeader r) `divMod` 10+                putStrLn $ show x ++ "." ++ show y  testSwitch     :: (StreamId -> ByteString -> IO (Maybe [Header]))@@ -146,7 +154,7 @@         mhdr <- dec n bs         case mhdr of             Nothing -> modifyIORef' ref (blk <|)-            Just hdr -> compareHeaders hdr+            Just hdr -> compareHeaders n bs hdr   where     loop fifo = do         case viewr fifo of@@ -156,18 +164,20 @@                 case mhdr of                     Nothing -> writeIORef ref fifo                     Just hdr -> do-                        compareHeaders hdr+                        compareHeaders n1 bs1 hdr                         loop fifo'-    compareHeaders hdr = do+    -- The block's own number and octets.  The ones of the encoder stream+    -- block that let it be decoded used to be counted in their place.+    compareHeaders n0 bs0 hdr = do         hdr' <- fromCaseSensitive <$> headerlist h         if fromCaseSensitive hdr == hdr'             then modifyIORef' ratio $ \r ->                 r-                    { ratioInst = ratioInst r + BS.length bs+                    { ratioInst = ratioInst r + BS.length bs0                     , ratioHeader = ratioHeader r + sum (map headerSize hdr)                     }             else do-                putStrLn $ "---- Stream " ++ show n+                putStrLn $ "---- Stream " ++ show n0                 let hdrt = zip hdr hdr'                 mapM_ printDiff hdrt                 exitFailure

@@ -69,6 +69,9 @@                     putWord64be $ fromIntegral (sid :: Int)                     putWord32be $ fromIntegral $ BS.length bs             BS.appendFile efile $ header <> bs+    -- Started afresh: 'save' appends, and a second run used to follow the+    -- first in the same file.+    BS.writeFile efile BS.empty     enc <- newQEncoderS encConf (save 0) blocked immack debug     withFile qfile ReadMode $ qencode enc save