diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/Network/HQ/Server.hs b/Network/HQ/Server.hs --- a/Network/HQ/Server.hs +++ b/Network/HQ/Server.hs @@ -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 diff --git a/Network/HTTP3/Client.hs b/Network/HTTP3/Client.hs --- a/Network/HTTP3/Client.hs +++ b/Network/HTTP3/Client.hs @@ -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) diff --git a/Network/HTTP3/Context.hs b/Network/HTTP3/Context.hs --- a/Network/HTTP3/Context.hs +++ b/Network/HTTP3/Context.hs @@ -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 diff --git a/Network/HTTP3/Control.hs b/Network/HTTP3/Control.hs --- a/Network/HTTP3/Control.hs +++ b/Network/HTTP3/Control.hs @@ -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 diff --git a/Network/HTTP3/Frame.hs b/Network/HTTP3/Frame.hs --- a/Network/HTTP3/Frame.hs +++ b/Network/HTTP3/Frame.hs @@ -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) diff --git a/Network/HTTP3/Recv.hs b/Network/HTTP3/Recv.hs --- a/Network/HTTP3/Recv.hs +++ b/Network/HTTP3/Recv.hs @@ -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' diff --git a/Network/HTTP3/Send.hs b/Network/HTTP3/Send.hs --- a/Network/HTTP3/Send.hs +++ b/Network/HTTP3/Send.hs @@ -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 diff --git a/Network/HTTP3/Server.hs b/Network/HTTP3/Server.hs --- a/Network/HTTP3/Server.hs +++ b/Network/HTTP3/Server.hs @@ -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 diff --git a/Network/QPACK.hs b/Network/QPACK.hs --- a/Network/QPACK.hs +++ b/Network/QPACK.hs @@ -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 () diff --git a/Network/QPACK/Error.hs b/Network/QPACK/Error.hs --- a/Network/QPACK/Error.hs +++ b/Network/QPACK/Error.hs @@ -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) diff --git a/Network/QPACK/HeaderBlock/Decode.hs b/Network/QPACK/HeaderBlock/Decode.hs --- a/Network/QPACK/HeaderBlock/Decode.hs +++ b/Network/QPACK/HeaderBlock/Decode.hs @@ -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 $ diff --git a/Network/QPACK/HeaderBlock/Prefix.hs b/Network/QPACK/HeaderBlock/Prefix.hs --- a/Network/QPACK/HeaderBlock/Prefix.hs +++ b/Network/QPACK/HeaderBlock/Prefix.hs @@ -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) diff --git a/Network/QPACK/Table/Dynamic.hs b/Network/QPACK/Table/Dynamic.hs --- a/Network/QPACK/Table/Dynamic.hs +++ b/Network/QPACK/Table/Dynamic.hs @@ -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 diff --git a/http3.cabal b/http3.cabal --- a/http3.cabal +++ b/http3.cabal @@ -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 @@ -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, diff --git a/test/HQ/ServerSpec.hs b/test/HQ/ServerSpec.hs new file mode 100644 --- /dev/null +++ b/test/HQ/ServerSpec.hs @@ -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) diff --git a/test/HTTP3/ClientSpec.hs b/test/HTTP3/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/HTTP3/ClientSpec.hs @@ -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 () diff --git a/test/HTTP3/Config.hs b/test/HTTP3/Config.hs --- a/test/HTTP3/Config.hs +++ b/test/HTTP3/Config.hs @@ -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 } diff --git a/test/HTTP3/Error.hs b/test/HTTP3/Error.hs --- a/test/HTTP3/Error.hs +++ b/test/HTTP3/Error.hs @@ -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 diff --git a/test/HTTP3/GoAwaySpec.hs b/test/HTTP3/GoAwaySpec.hs new file mode 100644 --- /dev/null +++ b/test/HTTP3/GoAwaySpec.hs @@ -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) diff --git a/test/HTTP3/LimitSpec.hs b/test/HTTP3/LimitSpec.hs --- a/test/HTTP3/LimitSpec.hs +++ b/test/HTTP3/LimitSpec.hs @@ -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 diff --git a/test/HTTP3/RunIOSpec.hs b/test/HTTP3/RunIOSpec.hs new file mode 100644 --- /dev/null +++ b/test/HTTP3/RunIOSpec.hs @@ -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 diff --git a/test/HTTP3/ServerSpec.hs b/test/HTTP3/ServerSpec.hs --- a/test/HTTP3/ServerSpec.hs +++ b/test/HTTP3/ServerSpec.hs @@ -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 diff --git a/test/QPACK/HeaderBlockSpec.hs b/test/QPACK/HeaderBlockSpec.hs --- a/test/QPACK/HeaderBlockSpec.hs +++ b/test/QPACK/HeaderBlockSpec.hs @@ -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 diff --git a/test/QPACK/QIF2Spec.hs b/test/QPACK/QIF2Spec.hs --- a/test/QPACK/QIF2Spec.hs +++ b/test/QPACK/QIF2Spec.hs @@ -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 diff --git a/util/h3-client.hs b/util/h3-client.hs --- a/util/h3-client.hs +++ b/util/h3-client.hs @@ -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)}) "") + (ReqArg (\n o -> o{optPacketSize = Just (fromMaybe 0 (readMaybe n))}) "") "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}) "") - "measure performance" - , Option ['n'] ["number-of-requests"] - (ReqArg (\n o -> o{optNumOfReqs = read n}) "") + (ReqArg (\n o -> o{optNumOfReqs = fromMaybe 0 (readMaybe 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 diff --git a/util/h3-server.hs b/util/h3-server.hs --- a/util/h3-server.hs +++ b/util/h3-server.hs @@ -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 and \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 or \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 diff --git a/util/qif-dec.hs b/util/qif-dec.hs --- a/util/qif-dec.hs +++ b/util/qif-dec.hs @@ -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 diff --git a/util/qif-enc.hs b/util/qif-enc.hs --- a/util/qif-enc.hs +++ b/util/qif-enc.hs @@ -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