http3 0.1.11 → 0.1.12
raw patch · 27 files changed
+918/−189 lines, 27 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Network.HQ.Client: UnsupportedRequest :: String -> UnsupportedRequest
+ Network.HQ.Client: newtype UnsupportedRequest
+ Network.HTTP3.Internal: InvalidContentLength :: ByteString -> InvalidContentLength
+ Network.HTTP3.Internal: StreamResetIsSent :: ApplicationProtocolError -> StreamResetIsSent
+ Network.HTTP3.Internal: UnsupportedRequest :: String -> UnsupportedRequest
+ Network.HTTP3.Internal: newtype InvalidContentLength
+ Network.HTTP3.Internal: newtype StreamResetIsSent
+ Network.HTTP3.Internal: newtype UnsupportedRequest
+ Network.QPACK.Internal: setBasePointToInsertionPoint :: DynamicTable -> IO ()
+ Network.QPACK.Internal: setInsertionPointToKnownReceivedCount :: DynamicTable -> IO ()
Files
- ChangeLog.md +29/−0
- Network/HQ/Client.hs +24/−15
- Network/HQ/Server.hs +59/−50
- Network/HTTP3/Client.hs +19/−23
- Network/HTTP3/Config.hs +1/−1
- Network/HTTP3/Context.hs +87/−4
- Network/HTTP3/Control.hs +6/−4
- Network/HTTP3/Error.hs +31/−0
- Network/HTTP3/Recv.hs +22/−1
- Network/HTTP3/Send.hs +42/−16
- Network/HTTP3/Server.hs +67/−25
- Network/QPACK.hs +22/−6
- Network/QPACK/HeaderBlock/Encode.hs +1/−1
- Network/QPACK/Table/Dynamic.hs +14/−4
- http3.cabal +3/−1
- test/HQ/ClientSpec.hs +43/−0
- test/HQ/ServerSpec.hs +51/−2
- test/HTTP3/ClientSpec.hs +38/−14
- test/HTTP3/Error.hs +26/−4
- test/HTTP3/FileSpec.hs +41/−0
- test/HTTP3/GoAwaySpec.hs +40/−2
- test/HTTP3/InformationalSpec.hs +6/−4
- test/HTTP3/LimitSpec.hs +43/−9
- test/HTTP3/RunIOSpec.hs +98/−1
- test/HTTP3/Server.hs +23/−0
- test/HTTP3/ServerSpec.hs +37/−0
- test/QPACK/HeaderBlockSpec.hs +45/−2
ChangeLog.md view
@@ -1,5 +1,34 @@ # Revision history for http3 +## 0.1.12++The client now throws a stream error it detects as `StreamResetIsSent`,+not as a connection error. New exceptions: `StreamResetIsSent`,+`UnsupportedRequest` and `InvalidContentLength`.++* Release the stream of a request refused with 431 in runIO+ [#58](https://github.com/kazu-yamamoto/http3/pull/58)+* Reset the stream on outBodyCancel+ [#59](https://github.com/kazu-yamamoto/http3/pull/59)+* HQ: do not end a body on a step that fills nothing+ [#61](https://github.com/kazu-yamamoto/http3/pull/61)+* HQ: stop the handlers once the connection is gone+ [#62](https://github.com/kazu-yamamoto/http3/pull/62)+* Client: throw a stream error as one, and at once+ [#63](https://github.com/kazu-yamamoto/http3/pull/63)+* Client: act on the server's GOAWAY+ [#64](https://github.com/kazu-yamamoto/http3/pull/64)+* runIO: send a Stream Cancellation for a request not read to the end+ [#65](https://github.com/kazu-yamamoto/http3/pull/65)+* QPACK: send encoder instructions outside the encoder's lock+ [#66](https://github.com/kazu-yamamoto/http3/pull/66)+* HQ: support OutBodyStreamingIface and refuse non-GET requests+ [#67](https://github.com/kazu-yamamoto/http3/pull/67)+* Server: send nothing on a stream after closing the connection for it+ [#68](https://github.com/kazu-yamamoto/http3/pull/68)+* Fix low-priority review findings+ [#69](https://github.com/kazu-yamamoto/http3/pull/69)+ ## 0.1.11 * Do not take a closed connection for a QPACK stream error
Network/HQ/Client.hs view
@@ -6,13 +6,13 @@ -- * Runner run, - -- * Client configration+ -- * Client configuration H3.ClientConfig, H3.defaultClientConfig, H3.scheme, Scheme, - -- * Common configration+ -- * Common configuration H3.Config (..), H3.allocSimpleConfig, H3.freeSimpleConfig,@@ -31,6 +31,9 @@ -- ** Accessing response getResponseBodyChunk,++ -- * Exception+ UnsupportedRequest (..), ) where import qualified Control.Exception as E@@ -44,8 +47,8 @@ import qualified Network.QUIC as QUIC import qualified Network.QUIC.Internal as QUIC -import Imports import qualified Network.HTTP3.Client as H3+import Network.HTTP3.Error (UnsupportedRequest (..)) import Network.HTTP3.Recv (newSource, readSource') -- | Running an HQ client.@@ -59,18 +62,24 @@ } sendRequest :: Connection -> Request -> (Response -> IO a) -> IO a-sendRequest conn (Request outobj) processResponse = E.bracket open close $ \strm -> do- let hdr = outObjHeaders outobj- path = fromJust $ lookup ":path" hdr- requestLine = BS.concat ["GET ", path, "\r\n"]- QUIC.sendStream strm requestLine- QUIC.shutdownStream strm- src <- newSource strm- refH <- newIORef Nothing- vt <- toTokenHeaderTable []- let readB = readSource' src- rsp = Response $ InpObj vt Nothing readB refH- processResponse rsp+sendRequest conn (Request outobj) processResponse = do+ -- HTTP/0.9 has GET and a path, and nothing else. A request without a+ -- path failed in 'fromJust', and one of another method was sent as GET.+ path <- case (lookup ":method" hdr, lookup ":path" hdr) of+ (Just "GET", Just p) -> return p+ _ -> E.throwIO $ UnsupportedRequest "only GET with a path can be sent"+ E.bracket open close $ \strm -> sendRequest' strm path where+ hdr = outObjHeaders outobj open = QUIC.stream conn close = QUIC.closeStream+ sendRequest' strm path = do+ let requestLine = BS.concat ["GET ", path, "\r\n"]+ QUIC.sendStream strm requestLine+ QUIC.shutdownStream strm+ src <- newSource strm+ refH <- newIORef Nothing+ vt <- toTokenHeaderTable []+ let readB = readSource' src+ rsp = Response $ InpObj vt Nothing readB refH+ processResponse rsp
Network/HQ/Server.hs view
@@ -5,7 +5,7 @@ -- * Runner run, - -- * Common configration+ -- * Common configuration Config (..), allocSimpleConfig, freeSimpleConfig,@@ -29,14 +29,12 @@ responseBuilder, ) where -import Control.Concurrent+import qualified Control.Exception as E import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder.Extra as B import qualified Data.ByteString.Internal as BS import Data.IORef import Foreign.ForeignPtr-import GHC.Conc.Sync import Network.HPACK.Internal (toTokenHeaderTable) import Network.HTTP.Semantics.IO import Network.HTTP.Semantics.Server@@ -46,12 +44,17 @@ import qualified Network.QUIC as QUIC import Network.SockAddr (showSockAddrBS) import Network.Socket (SockAddr)+import qualified System.ThreadManager as TM import qualified System.TimeManager as T+import System.Timeout (timeout) import Imports import Network.HTTP3.Config-import Network.HTTP3.Error (ApplicationProtocolError (H3InternalError))+import Network.HTTP3.Error (+ ApplicationProtocolError (H3InternalError, H3RequestCancelled),+ ) import Network.HTTP3.Recv (newSource, readSource')+import Network.HTTP3.Send (closeSentinel) -- | Running an HQ server. run :: Connection -> Config -> Server -> IO ()@@ -59,37 +62,37 @@ info <- QUIC.getConnectionInfo conn let mysa = QUIC.localSockAddr info peersa = QUIC.remoteSockAddr info- forever $ do- strm <- QUIC.acceptStream conn- forkFinally- (labelMe "HQ processRequest" >> processRequest conf mysa peersa server strm)- (finish strm)+ mgr <- TM.newThreadManager+ -- The handlers are stopped once the connection is gone, as with HTTP/3.+ -- They were plain threads, left running after it.+ TM.stopAfter mgr (accept mgr mysa peersa) $ \_ ->+ void $ timeout 5000000 $ TM.waitUntilAllGone mgr where+ accept mgr mysa peersa = forever $ do+ strm <- QUIC.acceptStream conn+ done <- newIORef False+ TM.forkManagedTimeoutFinally+ mgr+ (confTimeoutManager conf)+ "HQ processRequest"+ (processRequest conf mysa peersa server strm >=> writeIORef done)+ (finish strm done) -- 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+ -- failed, timed out or was stopped is reset.+ finish strm done = do+ ok <- readIORef done+ unless ok $ QUIC.resetStream strm H3InternalError QUIC.closeStream strm -labelMe :: String -> IO ()-labelMe label = do- tid <- myThreadId- labelThread tid label- -- | 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+processRequest+ :: Config -> SockAddr -> SockAddr -> Server -> Stream -> T.Handle -> IO Bool+processRequest conf mysa peersa server strm th | QUIC.isClientInitiatedBidirectional sid = do- done <- newIORef False- T.withHandleKillThread (confTimeoutManager conf) (return ()) $ \th -> do- mvt <- recvHeader strm mysa- forM_ mvt $ \vt -> do+ mvt <- recvHeader strm mysa+ case mvt of+ Nothing -> return False+ Just vt -> do src <- newSource strm refH <- newIORef Nothing let readB = readSource' src@@ -101,8 +104,7 @@ , auxPeerSockAddr = peersa } server req aux $ sendResponse conf strm- writeIORef done True- readIORef done+ return True | otherwise = return True -- fixme: should consume the data? where sid = QUIC.streamId strm@@ -156,32 +158,39 @@ OutBodyFile (FileSpec path fileoff bytecount) -> do (pread, sentinel) <- confPositionReadMaker conf path let next = fillFileBodyGetNext pread fileoff bytecount sentinel- sendNext strm next+ sendNext strm next `E.onException` closeSentinel sentinel OutBodyBuilder builder -> do let next = fillBuilderBodyGetNext builder sendNext strm next- OutBodyStreaming strmbdy -> sendStreaming strm strmbdy- OutBodyStreamingIface _ ->- error "sendResponse: server does not support OutBodyStreamingUnmask"+ OutBodyStreaming strmbdy ->+ sendStreaming strm $ \iface -> strmbdy (outBodyPush iface) (outBodyFlush iface)+ -- It used to be refused with 'error'.+ OutBodyStreamingIface strmbdy -> sendStreaming strm strmbdy sendNext :: Stream -> DynaNext -> IO () sendNext strm action = do- fp <- BS.mallocByteString 2048- Next len _reqflush mnext <- withForeignPtr fp $ \buf -> action buf 2048- if len == 0- then return ()- else do- let bs = PS fp 0 len- QUIC.sendStream strm bs- case mnext of- Nothing -> return ()- Just next -> sendNext strm next+ -- As HTTP/3 does: 2048 octets at a time was a 'sendStream' each.+ fp <- BS.mallocByteString 16384+ Next len _reqflush mnext <- withForeignPtr fp $ \buf -> action buf 16384+ -- Nothing this time is not the end: a builder fills nothing before a+ -- large chunk. The body used to end here, and went out empty.+ when (len /= 0) $ QUIC.sendStream strm $ PS fp 0 len+ forM_ mnext $ sendNext strm -sendStreaming :: Stream -> ((Builder -> IO ()) -> IO () -> IO ()) -> IO ()-sendStreaming strm strmbdy = do- strmbdy write flush+sendStreaming :: Stream -> (OutBodyIface -> IO ()) -> IO ()+sendStreaming strm strmbdy =+ strmbdy+ OutBodyIface+ { outBodyUnmask = id+ , outBodyPush = write+ , outBodyPushFinal = write+ , outBodyFlush = return ()+ , outBodyCancel = cancel+ } where- flush = return ()+ -- As HTTP/3 does: the reset stays when the stream is closed.+ cancel merr =+ QUIC.resetStream strm $ maybe H3RequestCancelled (const H3InternalError) merr write builder = do newByteStringAndSend strm (B.runBuilder builder) >>= loop where
Network/HTTP3/Client.hs view
@@ -7,7 +7,7 @@ -- * Runner run, - -- * Client configration+ -- * Client configuration ClientConfig, defaultClientConfig, scheme,@@ -32,7 +32,6 @@ module Network.HTTP.Semantics.Client, ) where -import Control.Concurrent import qualified Control.Exception as E import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.UTF8 as UTF8@@ -129,10 +128,7 @@ then loop (n + 1) else do QUIC.resetStream strm H3ExcessiveLoad- E.throwIO $- QUIC.ApplicationProtocolErrorIsSent- H3ExcessiveLoad- "too many informational responses"+ E.throwIO $ StreamResetIsSent H3ExcessiveLoad _ -> return mvt informational status = C8.length status == 3 && C8.head status == '1' @@ -149,13 +145,16 @@ -- the one told. checkHeaderSize ctx hdr' sent <- newIORef False+ refuseIfGoingAway ctx E.bracket (newStream ctx) (done sent) $ \strm -> do+ ans <- startRequest ctx strm forkManagedTimeout ctx "H3 client: sendRequest" $ \th -> ( do sendHeader ctx strm th hdr'- sendBody ctx strm th outobj- QUIC.shutdownStream strm- writeIORef sent True+ whole <- sendBody ctx strm th outobj+ when whole $ do+ QUIC.shutdownStream strm+ writeIORef sent True ) -- What goes wrong here is thrown away with the thread, and -- the request would be left half sent, with the response@@ -176,29 +175,25 @@ let sid = QUIC.streamId strm (`E.finally` cancelUnlessReadToEnd ctx sid src) $ do mvt <- recvFinalHeader ctx strm src+ -- A request the GOAWAY rejected had its stream reset to get here.+ answered ans 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.+ -- Reset before answering: the code goes to the application,+ -- which may retry H3_REQUEST_REJECTED (RFC 9114, 4.1.1). mreset <- QUIC.resetReceived strm- forM_ mreset $ \aerr -> do- threadDelay 100000- E.throwIO $ StreamResetIsReceived aerr+ forM_ mreset $ E.throwIO . StreamResetIsReceived+ -- Ended with no response: malformed, a stream error only. QUIC.resetStream strm H3MessageError- threadDelay 100000- -- just for type inference- E.throwIO $ QUIC.ApplicationProtocolErrorIsSent H3MessageError ""+ E.throwIO $ StreamResetIsSent H3MessageError Just vt -- Malformed (RFC 9114, section 4.2). | Just name <- connectionSpecificField vt -> do QUIC.resetStream strm H3MessageError E.throwIO $ ConnectionSpecificField name+ | Just v <- invalidContentLength (snd vt) -> do+ QUIC.resetStream strm H3MessageError+ E.throwIO $ InvalidContentLength v Just vt@(_, valtbl) -> do (readB, refH) <- newBodyReader ctx sid src valtbl $ noContent valtbl@@ -225,6 +220,7 @@ -- took a request body cut short for a whole one. The sender, if it is -- still at it, finds the stream closed and stops. done sent strm = do+ endRequest ctx strm complete <- readIORef sent if complete then QUIC.closeStreamWith strm H3RequestCancelled
Network/HTTP3/Config.hs view
@@ -56,6 +56,6 @@ defaultPositionReadMaker <$> T.initialize (30 * 1000000) --- | Freeing a simple configration.+-- | Freeing a simple configuration. freeSimpleConfig :: Config -> IO () freeSimpleConfig conf = T.killManager $ confTimeoutManager conf
Network/HTTP3/Context.hs view
@@ -30,6 +30,11 @@ requestDone, goAway, goAwayAll,+ Answer,+ refuseIfGoingAway,+ startRequest,+ answered,+ endRequest, waitPTO, drained, ) where@@ -37,9 +42,11 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.STM import qualified Control.Exception as E-import Control.Monad (forM_, void)+import Control.Monad (forM, forM_, void, when) import Data.IORef import Data.Maybe (isJust)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Network.ByteOrder (withWriteBuffer)@@ -76,10 +83,10 @@ -- ^ What we told the peer we would accept, and so the most of any one -- frame we are willing to hold in memory while it arrives. , ctxCancelStream :: StreamId -> IO ()+ -- ^ Sending a Stream Cancellation on our QPACK decoder stream , ctxPeerMaxFieldSectionSize :: IO Int -- ^ The peer's SETTINGS_MAX_FIELD_SECTION_SIZE, or 'maxBound' until its -- SETTINGS have arrived- -- ^ Sending a Stream Cancellation on our QPACK decoder stream , ctxSendControl :: [H3Frame] -> IO () , ctxGoAway :: TVar (Maybe StreamId) -- ^ Server only: the ID of our GOAWAY, from which no request is taken.@@ -87,8 +94,15 @@ -- ^ Server only: the largest request stream taken. , ctxInFlight :: TVar IntSet -- ^ Server only: the request streams taken and not yet done with.+ , ctxPeerGoAway :: TVar (Maybe StreamId)+ -- ^ Client only: the ID of the server's last GOAWAY.+ , ctxRequests :: TVar (IntMap (Stream, TVar Answer))+ -- ^ Client only: the requests sent and not yet done with. } +-- | Where a request of a client stands with its response.+data Answer = Waiting | Answered | Rejected deriving (Eq)+ -- | Running an action with a context, and seeing this connection's own -- threads out before returning: they are using the connection, which -- the caller tears down once this returns.@@ -110,6 +124,12 @@ stopTimeout :: Int stopTimeout = 5000000 +-- | The most of a frame on the peer's control stream held while it arrives.+-- SETTINGS_MAX_FIELD_SECTION_SIZE was used, which is about field sections+-- and set by the user: set low, it refused an ordinary large SETTINGS.+maxControlFrameSize :: Int+maxControlFrameSize = 65536+ newContext :: Connection -> Config -> IO Context newContext conn conf = do (sendEI, sendDI, ctxSendControl) <- setupUnidirectional conn conf@@ -117,8 +137,13 @@ -- newQDecoder passes dyntbl for decoder to handleEI internally (ctxQDecoder, handleEI) <- newQDecoder (confQDecoderConfig conf) sendDI let ctxMaxFieldSectionSize = dcMaxFieldSectionSize $ confQDecoderConfig conf- cst <- newControlState- ctl <- controlStream conn ctxMaxFieldSectionSize dyntblE cst <$> newIORef IInit+ ctxPeerGoAway <- newTVarIO Nothing+ ctxRequests <- newTVarIO IntMap.empty+ let onGoaway+ | isClient conn = rejectAbove ctxPeerGoAway ctxRequests . fromIntegral+ | otherwise = \_ -> return ()+ cst <- newControlState onGoaway+ ctl <- controlStream conn maxControlFrameSize dyntblE cst <$> newIORef IInit let ctxPeerMaxFieldSectionSize = getHeaderSize dyntblE seen <- newIORef [] info <- getConnectionInfo conn@@ -366,3 +391,61 @@ drained Context{..} = do readTVar ctxGoAway >>= check . isJust readTVar ctxInFlight >>= check . IntSet.null++----------------------------------------------------------------+-- GOAWAY of the server's (RFC 9114, section 5.2)++-- | No new request after the server's GOAWAY: "Endpoints MUST NOT initiate+-- new requests or promises on the connection after receipt of a GOAWAY".+refuseIfGoingAway :: Context -> IO ()+refuseIfGoingAway Context{..} = do+ goingaway <- isJust <$> readTVarIO ctxPeerGoAway+ when goingaway $ E.throwIO goneAway++-- | Taking a request stream on, or refusing it: no request is made after+-- the server's GOAWAY, and one at or above its ID will not be processed.+-- 'ConnectionIsClosed' says the request may be retried elsewhere.+startRequest :: Context -> Stream -> IO (TVar Answer)+startRequest Context{..} strm = do+ mans <- atomically $ do+ lim <- readTVar ctxPeerGoAway+ if maybe False (streamId strm >=) lim+ then return Nothing+ else do+ ans <- newTVar Waiting+ modifyTVar' ctxRequests $ IntMap.insert (streamId strm) (strm, ans)+ return $ Just ans+ maybe (E.throwIO goneAway) return mans++-- | The response has begun; or, if the GOAWAY rejected the request,+-- 'ConnectionIsClosed'.+answered :: TVar Answer -> IO ()+answered ans = atomically $ do+ a <- readTVar ans+ when (a == Rejected) $ throwSTM goneAway+ writeTVar ans Answered++endRequest :: Context -> Stream -> IO ()+endRequest Context{..} strm =+ atomically $ modifyTVar' ctxRequests $ IntMap.delete $ streamId strm++-- | Requests at or above the GOAWAY's ID still waiting for a response are+-- rejected, and their streams reset so that the wait ends.+rejectAbove+ :: TVar (Maybe StreamId)+ -> TVar (IntMap (Stream, TVar Answer))+ -> StreamId+ -> IO ()+rejectAbove peerGoAway requests lim = do+ strms <- atomically $ do+ modifyTVar' peerGoAway $ Just . maybe lim (min lim)+ (_, above) <- IntMap.split (lim - 1) <$> readTVar requests+ fmap concat $ forM (IntMap.elems above) $ \(strm, ans) -> do+ a <- readTVar ans+ if a == Waiting+ then [strm] <$ writeTVar ans Rejected+ else return []+ forM_ strms $ \strm -> resetStream strm H3RequestCancelled++goneAway :: QUICException+goneAway = ConnectionIsClosed "GOAWAY"
Network/HTTP3/Control.hs view
@@ -91,14 +91,16 @@ abortConnection conn aerr "" E.throwIO $ ApplicationProtocolErrorIsSent aerr "" --- | The last GOAWAY and MAX_PUSH_ID the peer sent on its control stream.+-- | The last GOAWAY and MAX_PUSH_ID the peer sent on its control stream,+-- and what to do with a GOAWAY. data ControlState = ControlState { lastGoaway :: IORef (Maybe Int64) , lastMaxPushId :: IORef (Maybe Int64)+ , onGoaway :: Int64 -> IO () } -newControlState :: IO ControlState-newControlState = ControlState <$> newIORef Nothing <*> newIORef Nothing+newControlState :: (Int64 -> IO ()) -> IO ControlState+newControlState hook = ControlState <$> newIORef Nothing <*> newIORef Nothing <*> pure hook -- DynamicTable for Encoder controlStream@@ -179,12 +181,12 @@ 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)+ onGoaway cst 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
Network/HTTP3/Error.hs view
@@ -3,7 +3,10 @@ module Network.HTTP3.Error ( ContentLengthMismatch (..), ConnectionSpecificField (..),+ InvalidContentLength (..), StreamResetIsReceived (..),+ StreamResetIsSent (..),+ UnsupportedRequest (..), ApplicationProtocolError ( H3NoError, H3GeneralProtocolError,@@ -52,6 +55,15 @@ instance E.Exception ConnectionSpecificField +-- | A message whose content-length, given here, is not a number of octets,+-- which makes it malformed (RFC 9114, section 4.1.2).+--+-- @since 0.1.12+newtype InvalidContentLength = InvalidContentLength ByteString+ deriving (Eq, Show)++instance E.Exception InvalidContentLength+ -- | The peer reset the stream, with this error code, before the body came to -- its end: what has been read of the body is not the whole of it. --@@ -61,6 +73,25 @@ deriving (Eq, Show) instance E.Exception StreamResetIsReceived++-- | We reset the stream with this error code: the peer's message on it was+-- not one we could take. A stream error, unlike 'ApplicationProtocolErrorIsSent',+-- which says the connection was closed.+--+-- @since 0.1.12+newtype StreamResetIsSent = StreamResetIsSent ApplicationProtocolError+ deriving (Eq, Show)++instance E.Exception StreamResetIsSent++-- | A request HTTP/0.9 cannot carry: a method other than GET, or no path.+-- The HQ client throws it before opening a stream.+--+-- @since 0.1.12+newtype UnsupportedRequest = UnsupportedRequest String+ deriving (Eq, Show)++instance E.Exception UnsupportedRequest {- FOURMOLU_DISABLE -} pattern H3NoError :: ApplicationProtocolError
Network/HTTP3/Recv.hs view
@@ -10,6 +10,7 @@ newBodyReader, cancelUnlessReadToEnd, connectionSpecificField,+ invalidContentLength, ) where import qualified Control.Exception as E@@ -131,6 +132,26 @@ -- No tokens of their own. byName = ["keep-alive", "proxy-connection", "upgrade"] +-- | The content-length of a message, if it has a valid one: digits alone+-- (RFC 9110, section 8.6), few enough not to overflow. 'C8.readInt' was+-- used, which took "12abc" for 12, and let a sign or an overflow through.+contentLength :: ValueTable -> Maybe Int+contentLength vt = getFieldValue tokenContentLength vt >>= parse+ where+ parse v+ | not (BS.null v)+ , BS.length v <= 18+ , BS.all (\w -> w >= 0x30 && w <= 0x39) v =+ fst <$> C8.readInt v+ | otherwise = Nothing++-- | The content-length of a message, when it is not a valid one: the+-- message is malformed (RFC 9114, section 4.1.2).+invalidContentLength :: ValueTable -> Maybe ByteString+invalidContentLength vt = case getFieldValue tokenContentLength vt of+ Just v | isNothing (contentLength vt) -> Just v+ _ -> Nothing+ -- | A body reader for one message, and the place its trailers will appear. -- -- The reader counts what it hands out and checks the total against@@ -159,7 +180,7 @@ refL <- newIORef 0 let mcl | noContent = Just 0- | otherwise = fst <$> (getFieldValue tokenContentLength vt >>= C8.readInt)+ | otherwise = contentLength vt return (recvBody ctx sid src refI refH mcl refL, refH) recvBody
Network/HTTP3/Send.hs view
@@ -5,6 +5,7 @@ sendHeader, checkHeaderSize, sendBody,+ closeSentinel, ) where import qualified Control.Exception as E@@ -20,6 +21,7 @@ import Imports import Network.HTTP3.Context+import Network.HTTP3.Error import Network.HTTP3.Frame import Network.QPACK @@ -46,16 +48,19 @@ sendStreamMany strm bss T.tickle th -sendBody :: Context -> Stream -> T.Handle -> OutObj -> IO ()+-- | Sending the body and its trailers. 'False' when the application+-- cancelled the stream ('outBodyCancel'), which has reset it: the caller+-- must not end it with a FIN.+sendBody :: Context -> Stream -> T.Handle -> OutObj -> IO Bool sendBody ctx strm th outobj = case outObjBody outobj of- OutBodyNone -> return ()+ OutBodyNone -> return True OutBodyFile (FileSpec path fileoff bytecount) -> do (pread, sentinel) <- pReadMaker ctx path let next = fillFileBodyGetNext pread fileoff bytecount sentinel- sendNext ctx strm th next tlrmkr+ True <$ sendNext ctx strm th next tlrmkr `E.onException` closeSentinel sentinel OutBodyBuilder builder -> do let next = fillBuilderBodyGetNext builder- sendNext ctx strm th next tlrmkr+ True <$ sendNext ctx strm th next tlrmkr OutBodyStreaming strmbdy -> sendStreaming ctx@@ -84,8 +89,8 @@ newByteStringWith :: TrailersMaker -> DynaNext -> IO (ByteString, Maybe DynaNext, TrailersMaker) newByteStringWith tlrmkr0 action = do- fp <- BS.mallocByteString 2048- Next len _reqflush mnext1 <- withForeignPtr fp $ \buf -> action buf 2048+ fp <- BS.mallocByteString fileChunkSize+ Next len _reqflush mnext1 <- withForeignPtr fp $ \buf -> action buf fileChunkSize if len == 0 -- Nothing this time, but not necessarily the end: there may be a -- next. This used to end the body here.@@ -95,6 +100,18 @@ tlrmkr1 <- nextMaker <$> tlrmkr0 (Just bs) return (bs, mnext1, tlrmkr1) +-- | Closing a file whose body was not sent to its end. Only the end closed+-- it, so a failure or a reset partway left the descriptor open. 'hClose',+-- which the default closer is, may be called again.+closeSentinel :: Sentinel -> IO ()+closeSentinel (Closer close) = close+closeSentinel (Refresher _) = return ()++-- | The most of a file or builder body put in one DATA frame. It was 2048,+-- so a large body went out in many small frames, one 'sendStream' each.+fileChunkSize :: Int+fileChunkSize = 16384+ -- | 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.@@ -128,9 +145,10 @@ -> T.Handle -> TrailersMaker -> (OutBodyIface -> IO ())- -> IO ()+ -> IO Bool sendStreaming ctx strm th tlrmkr0 strmbdy = do ref <- newIORef tlrmkr0+ cancelled <- newIORef False E.mask $ \unmask -> do let iface = OutBodyIface@@ -138,19 +156,27 @@ , outBodyPush = write ref , outBodyPushFinal = write ref -- fixme , outBodyFlush = flush- , outBodyCancel = cancel+ , outBodyCancel = cancel cancelled } strmbdy iface- tlrmkr <- readIORef ref- tm <- tlrmkr Nothing- let trailers = case tm of- Trailers t -> t- _ -> []- unless (null trailers) $ sendHeader ctx strm th trailers+ done <- not <$> readIORef cancelled+ when done $ do+ tlrmkr <- readIORef ref+ tm <- tlrmkr Nothing+ let trailers = case tm of+ Trailers t -> t+ _ -> []+ unless (null trailers) $ sendHeader ctx strm th trailers+ return done where- -- fixme: how to implement flush and cancel?+ -- fixme: how to implement flush? flush = return ()- cancel _ = return ()+ -- The stream is reset, with H3_INTERNAL_ERROR for an exception and+ -- H3_REQUEST_CANCELLED otherwise, as HTTP/2 does with RST_STREAM.+ -- It did nothing, and the body cut short was ended with a FIN.+ cancel cancelled merr = do+ writeIORef cancelled True+ resetStream strm $ maybe H3RequestCancelled (const H3InternalError) merr write ref builder = do tlrmkr1 <- readIORef ref tlrmkr2 <- newByteStringAndSend strm th tlrmkr1 (B.runBuilder builder) >>= loop
Network/HTTP3/Server.hs view
@@ -7,7 +7,7 @@ run, runWith, - -- * Common configration+ -- * Common configuration Config (..), defaultConfig, allocSimpleConfig,@@ -37,6 +37,7 @@ import qualified Control.Exception as E import qualified Control.Monad.STM as STM import Data.IORef+import qualified Data.IntMap.Strict as IntMap import GHC.Conc.Sync import Network.HTTP.Semantics import Network.HTTP.Semantics.Server@@ -72,14 +73,23 @@ runServer mstop conn conf server = withContext conn conf $ \ctx -> do myThreadId >>= \t -> labelThread t "H3 server: run" let serve = readerServer ctx $ \strm -> do- started <- newIORef False+ state <- newIORef NotStarted -- 'processRequest' handles its own exceptions; only asynchronous ones- -- leave it, and the thread manager takes those that it threw.+ -- and a connection error leave it, and the thread manager takes the+ -- asynchronous ones that it threw. forkManagedTimeoutFinally ctx "H3 server: processRequest"- (\th -> writeIORef started True >> processRequest ctx server strm th)- (finish ctx strm started)+ ( \th -> do+ writeIORef state Started+ processRequest ctx server strm th+ `E.catch` \e -> case e of+ QUIC.ApplicationProtocolErrorIsSent _ _ -> do+ writeIORef state ConnectionClosed+ E.throwIO e+ _ -> E.throwIO e+ )+ (finish ctx strm state) maybe serve (\stop -> race_ (goingAway ctx (True <$ stop)) serve) mstop where -- A thread stopped before it began, as the connection goes, has not@@ -87,16 +97,26 @@ -- 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. --+ -- A thread that closed the connection leaves the stream alone: a FIN+ -- could reach the client before the CONNECTION_CLOSE, as an empty response.+ -- -- 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 =+ finish ctx strm state = ( do- s <- readIORef started- unless s $ QUIC.resetStream strm H3RequestRejected- QUIC.closeStreamWith strm H3NoError+ s <- readIORef state+ case s of+ NotStarted -> do+ QUIC.resetStream strm H3RequestRejected+ QUIC.closeStreamWith strm H3NoError+ Started -> QUIC.closeStreamWith strm H3NoError+ ConnectionClosed -> return () ) `E.finally` requestDone ctx (QUIC.streamId strm) +-- | How far a request thread of 'run' got.+data RequestState = NotStarted | Started | ConnectionClosed+ -- | Once told: GOAWAY, and the requests taken before it answered. -- -- Told to stop, in two steps (RFC 9114, section 5.2): the largest@@ -133,19 +153,33 @@ info <- getConnectionInfo conn reqq <- newTQueueIO done <- newTVarIO False- let sio =+ -- The bodies of the requests handed over, as 'run' keeps each in its+ -- handler: a Stream Cancellation is owed for one not read to its end+ -- (RFC 9204, section 4.4.2). None was ever sent.+ srcs <- newTVarIO IntMap.empty+ let finish sid msrc = do+ forM_ msrc $ cancelUnlessReadToEnd ctx sid+ requestDone ctx sid+ sio = ServerIO { sioMySockAddr = localSockAddr info , sioPeerSockAddr = remoteSockAddr info , sioReadRequest = atomically $ readTQueue reqq- , sioWriteResponse = \strm rsp ->- sendResponseIO ctx strm rsp- `E.finally` requestDone ctx (QUIC.streamId strm)+ , sioWriteResponse = \strm rsp -> do+ let sid = QUIC.streamId strm+ sendResponseIO ctx strm rsp `E.finally` do+ msrc <- atomically $ do+ m <- readTVar srcs+ writeTVar srcs $ IntMap.delete sid m+ return $ IntMap.lookup sid m+ finish sid msrc , -- 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 = atomically . writeTQueue reqq+ put src (strm, req) = atomically $ do+ modifyTVar' srcs $ IntMap.insert (QUIC.streamId strm) src+ writeTQueue reqq (strm, req) -- 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.@@ -158,8 +192,11 @@ 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+ src <- newSource strm+ handed <-+ processRequestIO ctx (put src) strm src+ `E.onException` finish sid (Just src)+ unless handed $ finish sid (Just src) readerServer :: Context -> (Stream -> IO ()) -> IO () readerServer ctx action = loop@@ -227,7 +264,7 @@ abort ctx QpackDecompressionFailed -- A connection error has been sent: the stream goes with it. | Just (QUIC.ApplicationProtocolErrorIsSent _ _) <- E.fromException se =- return ()+ E.throwIO se -- 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 =@@ -248,13 +285,16 @@ | otherwise = False -- | 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+processRequestIO+ :: Context -> ((Stream, Request) -> IO ()) -> Stream -> Source -> IO Bool+processRequestIO ctx put strm src = E.handle reset $ do emvt <- E.try $ recvHeader ctx sid src case emvt of- Left FieldSectionTooLarge ->- False <$ withHandle ctx (refuseTooLarge ctx strm)+ -- Closed here, as 'run' does in 'finish': only a closed stream is+ -- given back to the client's limit on request streams.+ Left FieldSectionTooLarge -> do+ withHandle ctx (refuseTooLarge ctx strm)+ False <$ QUIC.closeStreamWith strm H3NoError Right Nothing -> False <$ QUIC.resetStream strm H3MessageError Right (Just ht) -> do mreq <- mkRequest ctx strm src ht@@ -313,6 +353,7 @@ return Nothing case (mMethod, mScheme, mAuthority, mPath) of _ | isJust (connectionSpecificField ht) -> malformed+ _ | isJust (invalidContentLength vt) -> malformed (Just "CONNECT", _, Just _, _) -> Just <$> build (Just _, Just _, Just _, Just _) -> Just <$> build _ -> malformed@@ -326,13 +367,14 @@ :: Context -> Stream -> T.Handle -> Response -> [PushPromise] -> IO () sendResponse ctx strm th (Response outobj) _pp = do sendHeader ctx strm th $ outObjHeaders outobj- sendBody ctx strm th outobj- QUIC.shutdownStream strm+ done <- sendBody ctx strm th outobj+ when done $ QUIC.shutdownStream strm sendResponseIO :: Context -> Stream -> Response -> IO () sendResponseIO ctx strm (Response outobj) = void $ withHandle ctx $ \th -> do sendHeader ctx strm th $ outObjHeaders outobj- sendBody ctx strm th outobj+ -- A cancelled body has reset the stream, and this only releases it.+ _ <- sendBody ctx strm th outobj QUIC.closeStreamWith strm H3NoError
Network/QPACK.hs view
@@ -54,6 +54,7 @@ import qualified Data.ByteString as BS import Data.CaseInsensitive hiding (map) import qualified Data.CaseInsensitive as CI+import Data.IORef import Network.ByteOrder import Network.HPACK.Internal ( GCBuffer,@@ -154,9 +155,21 @@ bufsiz2 = ecInstructionBufferSize gcbuf1 <- mallocPlainForeignPtrBytes bufsiz1 gcbuf2 <- mallocPlainForeignPtrBytes bufsiz2- dyntbl <- newDynamicTableForEncoding sendEI+ -- The instructions are queued under the lock, in the order of the+ -- insertions, and sent after it is released. Sending under it used to+ -- stop every encoding and acknowledgement while the encoder stream+ -- waited for flow control.+ pending <- newIORef []+ sendLock <- newMVar ()+ let enqueue bs = atomicModifyIORef' pending $ \bss -> (bs : bss, ())+ flush = do+ none <- null <$> readIORef pending+ unless none $ withMVar sendLock $ \_ -> do+ bss <- atomicModifyIORef' pending $ \bss -> ([], reverse bss)+ unless (null bss) $ sendEI $ BS.concat bss+ dyntbl <- newDynamicTableForEncoding enqueue lock <- newMVar ()- let enc =+ let enc sid ts = qpackEncoder gcbuf1 bufsiz1@@ -165,10 +178,13 @@ ecUseHuffman dyntbl lock+ sid+ ts+ <* flush handler = decoderInstructionHandler dyntbl lock ctl = TableOperation- { setCapacity = \n -> withMVar lock $ \_ -> do+ { setCapacity = \n -> (<* flush) $ withMVar lock $ \_ -> do -- "n" is decoder-proposed size via settings. -- It, not the capacity chosen below, determines -- MaxEntries.@@ -276,7 +292,7 @@ qpackDebug dyntbl $ putStrLn $ "---- Stream " ++ show sid ++ " " ++ "tblsiz: " ++ show siz- setBasePointToInsersionPoint dyntbl+ setBasePointToInsertionPoint dyntbl clearRequiredInsertCount dyntbl let tss = splitThrough (min bufsiz1 bufsiz2) ts his <- mapM (encodeChunk buf1 bufsiz1 buf2 bufsiz2 huff dyntbl) tss@@ -314,7 +330,7 @@ qpackDebug dyntbl $ putStrLn $ "---- Stream " ++ show sid ++ " " ++ "tblsiz: " ++ show siz- setBasePointToInsersionPoint dyntbl+ setBasePointToInsertionPoint dyntbl clearRequiredInsertCount dyntbl let tss = splitThrough (min bufsiz1 bufsiz2) ts his <- mapM (encodeChunk buf1 bufsiz1 buf2 bufsiz2 huff dyntbl) tss@@ -339,7 +355,7 @@ -- Need to emulate InsertCountIncrement since -- SectionAcknowledgement is not returned if -- RequiredInsertCount is 0.- when immAck $ setInsersionPointToKnownReceivedCount dyntbl+ when immAck $ setInsertionPointToKnownReceivedCount dyntbl return section where mk' (k, v) = (t, v)
Network/QPACK/HeaderBlock/Encode.hs view
@@ -44,7 +44,7 @@ -> [Header] -> IO (EncodedFieldSection, EncodedEncoderInstruction) encodeHeader huff dyntbl hs = do- setBasePointToInsersionPoint dyntbl+ setBasePointToInsertionPoint dyntbl clearRequiredInsertCount dyntbl (hb0, insb) <- withWriteBuffer' 2048 $ \wbuf1 -> withWriteBuffer 2048 $ \wbuf2 -> do
Network/QPACK/Table/Dynamic.hs view
@@ -54,11 +54,13 @@ updateKnownReceivedCount, wouldSectionBeBlocked, wouldInstructionBeBlocked,+ setInsertionPointToKnownReceivedCount, setInsersionPointToKnownReceivedCount, updateReported, -- * Points getBasePoint,+ setBasePointToInsertionPoint, setBasePointToInsersionPoint, getInsertionPoint, getInsertionPointSTM,@@ -635,8 +637,8 @@ where DecodeInfo{..} = codeInfo -setInsersionPointToKnownReceivedCount :: DynamicTable -> IO ()-setInsersionPointToKnownReceivedCount dyntbl@DynamicTable{..} = do+setInsertionPointToKnownReceivedCount :: DynamicTable -> IO ()+setInsertionPointToKnownReceivedCount dyntbl@DynamicTable{..} = do InsertionPoint ai <- getInsertionPoint dyntbl atomically $ writeTVar knownReceivedCount ai where@@ -647,10 +649,18 @@ getBasePoint :: DynamicTable -> IO BasePoint getBasePoint DynamicTable{..} = readIORef basePoint -setBasePointToInsersionPoint :: DynamicTable -> IO ()-setBasePointToInsersionPoint DynamicTable{..} = do+setBasePointToInsertionPoint :: DynamicTable -> IO ()+setBasePointToInsertionPoint DynamicTable{..} = do InsertionPoint ip <- readTVarIO insertionPoint writeIORef basePoint $ BasePoint ip++{-# DEPRECATED setInsersionPointToKnownReceivedCount "Use setInsertionPointToKnownReceivedCount" #-}+setInsersionPointToKnownReceivedCount :: DynamicTable -> IO ()+setInsersionPointToKnownReceivedCount = setInsertionPointToKnownReceivedCount++{-# DEPRECATED setBasePointToInsersionPoint "Use setBasePointToInsertionPoint" #-}+setBasePointToInsersionPoint :: DynamicTable -> IO ()+setBasePointToInsersionPoint = setBasePointToInsertionPoint getInsertionPoint :: DynamicTable -> IO InsertionPoint getInsertionPoint DynamicTable{..} = readTVarIO insertionPoint
http3.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: http3-version: 0.1.11+version: 0.1.12 license: BSD-3-Clause license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -196,11 +196,13 @@ build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: test util other-modules:+ HQ.ClientSpec HQ.ServerSpec HTTP3.ClientSpec HTTP3.Config HTTP3.Error HTTP3.ErrorSpec+ HTTP3.FileSpec HTTP3.FrameSpec HTTP3.GoAwaySpec HTTP3.HandlerSpec
+ test/HQ/ClientSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module HQ.ClientSpec where++import qualified Control.Exception as E+import Data.ByteString (ByteString)+import qualified Network.HQ.Client as HQ+import Network.HTTP.Semantics (OutObj (..))+import Network.HTTP.Semantics.Client (requestNoBody)+import Network.HTTP.Semantics.Client.Internal (Request (..))+import Network.HTTP.Types+import qualified Network.QUIC.Client as QUICC+import System.Timeout (timeout)+import Test.Hspec++import HQ.ServerSpec (setupHQ)+import HTTP3.Config+import HTTP3.Server (teardown)++spec :: Spec+spec = beforeAll setupHQ $+ afterAll teardown $+ describe "HQ client" $ do+ it "sends a GET request" $ \_ ->+ timeout 3000000 (send $ requestNoBody methodGet "/" [])+ `shouldReturn` Just "hello"+ -- It was sent as GET.+ it "refuses a request that is not GET" $ \_ ->+ send (requestNoBody methodPost "/" []) `shouldThrow` unsupported+ -- It failed in 'fromJust'.+ it "refuses a request without a path" $ \_ -> do+ let Request outobj = requestNoBody methodGet "/" []+ noPath = filter ((/= ":path") . fst) $ outObjHeaders outobj+ send (Request outobj{outObjHeaders = noPath}) `shouldThrow` unsupported++send :: HQ.Request -> IO ByteString+send req = QUICC.run testClientConfig $ \conn ->+ E.bracket HQ.allocSimpleConfig HQ.freeSimpleConfig $ \conf ->+ HQ.run conn HQ.defaultClientConfig conf $ \sendRequest _aux ->+ sendRequest req HQ.getResponseBodyChunk++unsupported :: Selector HQ.UnsupportedRequest+unsupported = const True
test/HQ/ServerSpec.hs view
@@ -7,10 +7,13 @@ import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder, byteString) import qualified Network.HQ.Server as HQ+import Network.HTTP.Semantics (OutBodyIface (..))+import Network.HTTP.Semantics.Server (responseStreamingIface) 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.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec @@ -23,6 +26,17 @@ describe "HQ server" $ do it "answers a request" $ \_ -> request "GET /\r\n" `shouldReturn` Just ("hello", Nothing)+ it "sends a body whose first chunk fills nothing" $ \_ ->+ fmap (BS.length . fst) <$> request "GET /large\r\n"+ `shouldReturn` Just largeSize+ it "stops a handler once the connection is gone" $ \_ -> do+ _ <- tryTakeMVar stallStopped+ QUICC.run testClientConfig $ \conn -> do+ strm <- QUIC.stream conn+ QUIC.sendStream strm "GET /stall\r\n"+ QUIC.shutdownStream strm+ threadDelay 200000+ timeout 2000000 (takeMVar stallStopped) `shouldReturn` Just () 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" $ \_ ->@@ -31,6 +45,11 @@ 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 "sends a response with a streaming interface" $ \_ ->+ request "GET /iface\r\n" `shouldReturn` Just ("hello", Nothing)+ it "resets the stream of a response its handler cancels" $ \_ ->+ fmap snd <$> request "GET /cancel\r\n"+ `shouldReturn` Just (Just cancelCode) it "resets the stream of a request line that goes on and on" $ \_ -> fmap snd <$> request (BS.replicate 100000 0x61) `shouldReturn` Just (Just resetCode)@@ -38,6 +57,9 @@ resetCode :: QUIC.ApplicationProtocolError resetCode = QUIC.ApplicationProtocolError 0x102 +cancelCode :: QUIC.ApplicationProtocolError+cancelCode = QUIC.ApplicationProtocolError 0x10c+ setupHQ :: IO ThreadId setupHQ = do sc <- makeTestServerConfig@@ -47,12 +69,34 @@ 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.+-- | Large enough for 'byteString' to insert it as a chunk of its own: the+-- builder then fills nothing in its first step.+largeSize :: Int+largeSize = 20000++-- | "/" and "/iface" answer hello, "/fail" fails after part of its response,+-- "/cancel" cancels it, "/large" answers 'largeSize' octets, "/stall" never answers, 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 "/stall" ->+ threadDelay 10000000 `E.onException` putMVar stallStopped ()+ -- 'OutBodyStreamingIface' used to be refused with 'error'.+ Just "/iface" ->+ sendResponse (responseStreamingIface ok200 [] $ \iface -> outBodyPush iface "hello") []+ Just "/cancel" ->+ sendResponse+ ( responseStreamingIface ok200 [] $ \iface -> do+ outBodyPush iface "partial"+ outBodyCancel iface Nothing+ )+ []+ Just "/large" ->+ sendResponse+ (HQ.responseBuilder ok200 [] (byteString (BS.replicate largeSize 0x62)))+ [] Just path -> sendResponse (HQ.responseBuilder ok200 [] (byteString path)) [] Nothing -> sendResponse (HQ.responseNoBody badRequest400 []) [] where@@ -61,6 +105,11 @@ write "partial" flush E.throwIO $ userError "failing"++-- | Filled when the handler of "/stall" is stopped.+{-# NOINLINE stallStopped #-}+stallStopped :: MVar ()+stallStopped = unsafePerformIO newEmptyMVar -- | Sending the octets as a request, and reading the response: what came, -- and the code of a reset if there was one.
test/HTTP3/ClientSpec.hs view
@@ -1,15 +1,20 @@+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} module HTTP3.ClientSpec where import Control.Concurrent import qualified Control.Exception as E import Control.Monad+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec) import Network.HTTP.Types import qualified Network.HTTP3.Client as C import Network.HTTP3.Internal ( ApplicationProtocolError (..), StreamResetIsReceived (..),+ StreamResetIsSent (..), ) import qualified Network.QUIC as QUIC import qualified Network.QUIC.Client as QUICC@@ -22,28 +27,47 @@ spec :: Spec spec =- describe "H3 client" $+ describe "H3 client" $ do it "tells the application of a request the server rejected" $- E.bracket setupRejecting teardown $ \_ ->- timeout 3000000 rejectedRequest+ E.bracket (setupWith rejecting) teardown $ \_ ->+ fmap fst <$> timeout 3000000 (request @StreamResetIsReceived) `shouldReturn` Just (Left (StreamResetIsReceived H3RequestRejected))+ it "tells the application of a rejection at once" $+ E.bracket (setupWith rejecting) teardown $ \_ -> do+ r <- timeout 3000000 (request @StreamResetIsReceived)+ fmap snd r `shouldSatisfy` maybe False (< 50_000_000)+ it "resets a stream that ends with no response, as a stream error" $+ E.bracket (setupWith ending) teardown $ \_ ->+ fmap fst <$> timeout 3000000 (request @StreamResetIsSent)+ `shouldReturn` Just (Left (StreamResetIsSent H3MessageError)) --- | 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+-- | A plain QUIC server doing this to every request stream.+setupWith :: (QUIC.Stream -> IO ()) -> IO ThreadId+setupWith act = 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+ act strm 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 ->+-- | Reset with H3_REQUEST_REJECTED, which says the request may be retried+-- (RFC 9114, section 4.1.1).+rejecting :: QUIC.Stream -> IO ()+rejecting strm = QUIC.resetStream strm H3RequestRejected++-- | Ended with no response at all.+ending :: QUIC.Stream -> IO ()+ending = QUIC.shutdownStream++-- | The outcome of a request, and how long it took in nanoseconds. It used+-- to be a connection error, and to come a tenth of a second late.+request :: E.Exception e => IO (Either e (), Word64)+request = 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 ()+ C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+ t0 <- getMonotonicTimeNSec+ r <- E.try $ sendRequest (C.requestNoBody methodGet "/" []) $ \_ -> return ()+ t1 <- getMonotonicTimeNSec+ return (r, t1 - t0)
test/HTTP3/Error.hs view
@@ -62,9 +62,9 @@ -> 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.+-- | With 'True', a test that expects a connection error: a stream error on+-- the request does not end it, since a server closing the connection may+-- end its streams first. runCWith :: Bool -> H3.Request@@ -85,7 +85,12 @@ client :: H3.Client () client sendRequest _aux | expectError = do- _ <- E.try @StreamResetIsReceived $ sendRequest req $ \_rsp -> return ()+ -- A stream error, ours or the server's, comes before the+ -- connection error when the server ends the stream first.+ sendRequest req (\_rsp -> return ())+ `E.catches` [ E.Handler $ \(StreamResetIsReceived _) -> return ()+ , E.Handler $ \(StreamResetIsSent _) -> return ()+ ] threadDelay us | otherwise = do ret <- sendRequest req $ \_rsp -> return ()@@ -168,6 +173,19 @@ refusedNotServed (served x) $ runCReq req qcc' cconf conf0 ms `shouldThrow` applicationProtocolErrorsIn [H3MessageError]+ forM_ invalidContentLengths $ \v ->+ itH3+ ( "MUST treat a request with content-length "+ ++ show v+ ++ " as malformed [HTTP/3 4.1.2]"+ )+ $ \x -> do+ -- It used to be read by its leading digits, if any.+ let req = H3.requestNoBody methodGet "/" [("content-length", v)]+ qcc' = throwOnReset qcc+ refusedNotServed (served x) $+ runCReq req qcc' cconf conf0 ms+ `shouldThrow` applicationProtocolErrorsIn [H3MessageError] itH3 "MUST accept TE with trailers [HTTP/3 4.2]" $ \_ -> do let req = H3.requestNoBody methodGet "/" [("te", "trailers")] runCReqOk req qcc cconf conf0 ms `shouldReturn` Just ()@@ -661,6 +679,10 @@ , ("upgrade", "websocket") , ("te", "gzip") ]++-- | Values of content-length that are not a number of octets.+invalidContentLengths :: [BS.ByteString]+invalidContentLengths = ["0x", "-1", "+0", "", "99999999999999999999"] -- | Trailers of a single Connection field. connectionTrailer :: H3.TrailersMaker
+ test/HTTP3/FileSpec.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTP3.FileSpec where++import Control.Concurrent+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 QUIC+import System.Timeout (timeout)+import Test.Hspec++import HTTP3.Config+import HTTP3.Server (setupWith, teardown)++spec :: Spec+spec =+ describe "H3 server sending a file" $+ it "closes the file when the client stops reading it" $ do+ closed <- newEmptyMVar+ E.bracket (setupWith (endless closed) fileServer 4096) teardown $ \_ -> do+ QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+ sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->+ -- One chunk, and the stream is given up on.+ () <$ C.getResponseBodyChunk rsp+ -- It was closed only at the end of the file, which this+ -- one never reaches: the descriptor was left open.+ timeout 2000000 (takeMVar closed) `shouldReturn` Just ()++-- | A file of 100 MB, whatever its name, whose closing fills the 'MVar'.+endless :: MVar () -> Config -> Config+endless closed conf = conf{confPositionReadMaker = mk}+ where+ mk _ = return (\_ n _ -> return n, Closer $ () <$ tryPutMVar closed ())++fileServer :: Server+fileServer _req _aux sendResponse =+ sendResponse (responseFile ok200 [] (FileSpec "endless" 0 100000000)) []
test/HTTP3/GoAwaySpec.hs view
@@ -7,9 +7,11 @@ import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Exception as E+import Control.Monad (forever, when) 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)@@ -19,7 +21,13 @@ import HTTP3.Server (teardown) spec :: Spec-spec =+spec = do+ describe "H3 client told to go away" $+ -- RFC 9114, section 5.2: a request at or above the GOAWAY's ID will+ -- not be processed, and none is to be made after it.+ it "fails a request the server will not process, and refuses new ones" $+ E.bracket setupIgnoring teardown $ \_ ->+ timeout 3000000 ignoredRequests `shouldReturn` Just (True, True) 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.@@ -29,7 +37,8 @@ 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 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.@@ -73,3 +82,32 @@ fast <- E.try $ get "/" s <- wait slow return (s, either (\(_ :: E.SomeException) -> False) (const True) fast)++-- | A bare HTTP/3 server: SETTINGS, and a GOAWAY with ID 0 for each request,+-- which it never answers.+setupIgnoring :: IO ThreadId+setupIgnoring = do+ sc <- makeTestServerConfig+ tid <- forkIO $ QUICS.run sc $ \conn -> do+ ctl <- QUIC.unidirectionalStream conn+ -- Control stream, then SETTINGS with no parameters.+ QUIC.sendStream ctl "\x00\x04\x00"+ forever $ do+ strm <- QUIC.acceptStream conn+ when (QUIC.isClientInitiatedBidirectional $ QUIC.streamId strm) $+ QUIC.sendStream ctl "\x07\x01\x00"+ threadDelay 500000 -- give enough time to the server+ return tid++-- | Whether a request the GOAWAY came after, and one made after it, each+-- ended in 'QUIC.ConnectionIsClosed'. The first used to wait for ever.+ignoredRequests :: IO (Bool, Bool)+ignoredRequests = QUICC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+ let get = E.try $ sendRequest (C.requestNoBody methodGet "/" []) $ \_ -> return ()+ gone (Left (QUIC.ConnectionIsClosed _)) = True+ gone _ = False+ r1 <- get+ r2 <- get+ return (gone r1, gone r2)
test/HTTP3/InformationalSpec.hs view
@@ -10,9 +10,9 @@ ApplicationProtocolError (..), H3Frame (..), H3FrameType (..),+ StreamResetIsSent (..), ) import Network.HTTP3.Server-import qualified Network.QUIC as Q import qualified Network.QUIC.Client as QUIC import System.Timeout (timeout) import Test.Hspec@@ -45,11 +45,13 @@ -- them for ever. r <- get case r of- Just (Left (Q.ApplicationProtocolErrorIsSent H3ExcessiveLoad _)) ->- return ()+ -- A stream error: the connection goes on.+ Just (Left se)+ | Just (StreamResetIsSent H3ExcessiveLoad) <- E.fromException se ->+ return () _ -> expectationFailure $ "unexpected: " ++ show r where- get :: IO (Maybe (Either Q.QUICException (Maybe Status, B.ByteString)))+ get :: IO (Maybe (Either E.SomeException (Maybe Status, B.ByteString))) get = timeout 3000000 $ E.try $ QUIC.run testClientConfig $ \conn -> E.bracket allocSimpleConfig freeSimpleConfig $ \conf -> C.run conn testH3ClientConfig conf $ \sendRequest _aux ->
test/HTTP3/LimitSpec.hs view
@@ -4,10 +4,12 @@ import qualified Control.Exception as E import qualified Data.ByteString as B+import Data.Bits (shiftR, (.&.), (.|.)) import Network.HTTP.Types import qualified Network.HTTP3.Client as C import Network.HTTP3.Internal (H3Frame (..), H3FrameType (..)) import Network.HTTP3.Server+import Network.QPACK (QDecoderConfig (..)) import qualified Network.QUIC.Client as QUIC import Test.Hspec @@ -22,7 +24,7 @@ -- us. Such a section has to be sent all the same to see what the server -- does with it, and a client that has not been told of a limit sends it. spec :: Spec-spec =+spec = do 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 $@@ -30,16 +32,48 @@ it "answers 431 to a HEADERS frame longer than its limit" $ E.bracket (setupWith hideLimit server 4096) teardown $ \_ -> runTooLongFrameClient+ describe "H3 server with a small field section limit" $+ it "takes SETTINGS longer than that limit" $+ E.bracket (setupWith smallLimit server 4096) teardown $+ \_ -> runLargeSettingsClient --- | SETTINGS with the dynamic table as the test server has it, and without--- SETTINGS_MAX_FIELD_SECTION_SIZE: QPACK_MAX_TABLE_CAPACITY 4096 and--- QPACK_BLOCKED_STREAMS 100.-hideLimit :: Config -> Config-hideLimit conf = conf{confHooks = (confHooks conf){onControlFrameCreated = map replace}}+-- | A server taking field sections of 300 octets at most, and a client whose+-- SETTINGS come to 450 octets or so. The cap on control frames was the+-- field section limit, and the server closed the connection with+-- H3_EXCESSIVE_LOAD.+runLargeSettingsClient :: IO ()+runLargeSettingsClient = QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf0 -> do+ let conf =+ conf0+ { confHooks =+ (confHooks conf0){onControlFrameCreated = map grease}+ }+ C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+ let hello =+ sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->+ C.responseStatus rsp `shouldBe` Just ok200+ -- The first is answered before the server reads our SETTINGS.+ hello+ waitForSettings+ hello where- replace (H3Frame H3FrameSettings _) =- H3Frame H3FrameSettings "\x01\x50\x00\x07\x40\x64"- replace frame = frame+ -- 150 reserved settings (RFC 9114, section 7.2.4.1), of two-octet IDs+ -- and the value 0.+ grease (H3Frame H3FrameSettings payload) =+ H3Frame H3FrameSettings $ payload <> B.concat (map reserved [0 .. 149])+ grease frame = frame+ reserved :: Int -> B.ByteString+ reserved n =+ let i = 0x1f * n + 0x21+ in B.pack [fromIntegral (0x40 .|. (i `shiftR` 8)), fromIntegral (i .&. 0xff), 0]++smallLimit :: Config -> Config+smallLimit conf =+ conf+ { confQDecoderConfig =+ (confQDecoderConfig conf){dcMaxFieldSectionSize = 300}+ } -- | 150 copies of one field with a 300-octet value. After the first two, -- each is a reference to the dynamic table of an octet or so, so the HEADERS
test/HTTP3/RunIOSpec.hs view
@@ -5,17 +5,21 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad+import qualified Data.ByteString as B+import Data.IORef import Network.HTTP.Types import qualified Network.HTTP3.Client as C import Network.HTTP3.Server import qualified Network.QUIC as QUIC import qualified Network.QUIC.Client as QUICC+import qualified Network.QUIC.Internal as QUIC import qualified Network.QUIC.Server as QUICS+import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec hiding (runIO) import HTTP3.Config-import HTTP3.Server (teardown)+import HTTP3.Server (hideLimit, teardown) spec :: Spec spec =@@ -30,6 +34,18 @@ -- answered, and only then does runIO return. timeout 3000000 oneRequest `shouldReturn` Just () timeout 3000000 (takeMVar returned) `shouldReturn` Just ()+ it "cancels a stream whose request it does not read to the end" $+ E.bracket setupCancel teardown $ \_ -> do+ timeout 3000000 twoRequests `shouldReturn` Just ()+ -- Time for the cancellation to go out.+ threadDelay 100000+ bs <- B.concat <$> readIORef sentOnDecoderStream+ -- Stream Cancellation is 01 and then the stream ID in six bits.+ B.elem 0x40 bs `shouldBe` False+ B.elem 0x44 bs `shouldBe` True+ it "gives back the stream of a request refused with 431" $+ E.bracket setupFewStreams teardown $ \_ ->+ timeout 5000000 tooLongRequests `shouldReturn` Just () setupIO :: IO ThreadId setupIO = do@@ -75,3 +91,84 @@ C.run conn testH3ClientConfig conf $ \sendRequest _aux -> sendRequest (C.requestNoBody methodGet "/" []) $ \rsp -> C.responseStatus rsp `shouldBe` Just ok200++-- | A server allowing 'fewStreams' request streams at a time, and keeping to+-- a SETTINGS_MAX_FIELD_SECTION_SIZE it does not announce.+setupFewStreams :: IO ThreadId+setupFewStreams = do+ sc0 <- makeTestServerConfig+ let sc =+ sc0+ { QUIC.scParameters =+ (QUIC.scParameters sc0){QUIC.initialMaxStreamsBidi = fewStreams}+ }+ tid <- forkIO $ QUICS.run sc $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ runIO conn (hideLimit 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++fewStreams :: Int+fewStreams = 3++-- | More requests refused with 431 than 'fewStreams', one after another: each+-- needs the stream of an earlier one given back.+tooLongRequests :: IO ()+tooLongRequests = QUICC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+ replicateM_ (fewStreams * 3) $ do+ let req = C.requestNoBody methodGet "/" [("x-a", B.replicate 40000 0x7e)]+ sendRequest req $ \rsp ->+ C.responseStatus rsp `shouldBe` Just requestHeaderFieldsTooLarge431++-- | RFC 9204, section 4.4.2: a decoder that gives up on a stream sends a+-- Stream Cancellation. The application reads the body of the request on+-- stream 0 to its end, and not that on stream 4.+setupCancel :: IO ThreadId+setupCancel = do+ writeIORef sentOnDecoderStream []+ sc0 <- makeTestServerConfig+ let sc = sc0{QUIC.scHooks = (QUIC.scHooks sc0){QUIC.onPlainCreated = recordDecoderStream}}+ tid <- forkIO $ QUICS.run sc $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ runIO conn conf $ \sio -> return $ forever $ do+ (strm, req) <- sioReadRequest sio+ when (QUIC.streamId strm == 0) $ do+ let drain = do+ bs <- getRequestBodyChunk req+ unless (B.null bs) drain+ drain+ sioWriteResponse sio strm $ responseBuilder ok200 [] "hello"+ threadDelay 500000 -- give enough time to the server+ return tid++twoRequests :: IO ()+twoRequests = QUICC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux ->+ replicateM_ 2 $+ sendRequest (C.requestNoBody methodGet "/" []) $ \rsp ->+ C.responseStatus rsp `shouldBe` Just ok200++-- | The server's QPACK decoder stream: its control, encoder and decoder+-- streams are 3, 7 and 11.+serverDecoderStream :: QUIC.StreamId+serverDecoderStream = 11++{-# NOINLINE sentOnDecoderStream #-}+sentOnDecoderStream :: IORef [B.ByteString]+sentOnDecoderStream = unsafePerformIO $ newIORef []++-- | The hook is pure, so this is the only way to see what goes out.+{-# NOINLINE recordDecoderStream #-}+recordDecoderStream :: QUIC.EncryptionLevel -> QUIC.Plain -> QUIC.Plain+recordDecoderStream _ plain = unsafePerformIO $ do+ forM_ (QUIC.plainFrames plain) $ \frame -> case frame of+ QUIC.StreamF sid _ dats _+ | sid == serverDecoderStream ->+ atomicModifyIORef' sentOnDecoderStream $ \xs -> (xs ++ dats, ())+ _ -> return ()+ return plain
test/HTTP3/Server.hs view
@@ -5,6 +5,7 @@ setup, setupWith, setupShortTimeout,+ hideLimit, server, countingServer, recordedBody,@@ -30,6 +31,7 @@ import Data.IP () import Network.HPACK import Network.HTTP.Types+import Network.HTTP3.Internal (H3Frame (..), H3FrameType (..)) import Network.HTTP3.Server import qualified Network.QUIC.Server as QUIC import Network.Socket ()@@ -39,6 +41,16 @@ import HTTP3.Config +-- | SETTINGS with the dynamic table as the test server has it, and without+-- SETTINGS_MAX_FIELD_SECTION_SIZE: QPACK_MAX_TABLE_CAPACITY 4096 and+-- QPACK_BLOCKED_STREAMS 100.+hideLimit :: Config -> Config+hideLimit conf = conf{confHooks = (confHooks conf){onControlFrameCreated = map replace}}+ where+ replace (H3Frame H3FrameSettings _) =+ H3Frame H3FrameSettings "\x01\x50\x00\x07\x40\x64"+ replace frame = frame+ setup :: Server -> Int -> IO ThreadId setup = setupWith id @@ -92,6 +104,9 @@ -- frames: the body throws, and the stream is reset. Just "/reset" -> sendResponse (responseStreaming ok200 [] resetAfterOne) []+ -- The same, but the handler cancels the stream itself.+ Just "/cancel" ->+ sendResponse (responseStreamingIface ok200 [] cancelAfterOne) [] -- No content, and a content-length describing content it does not -- have: allowed for a 304 (RFC 9114, section 4.1.2). Just "/not-modified" ->@@ -165,6 +180,14 @@ -- then the client sees neither HEADERS nor DATA. Let them arrive first. threadDelay 200000 E.throwIO $ userError "reset after one DATA frame"++cancelAfterOne :: OutBodyIface -> IO ()+cancelAfterOne iface = do+ outBodyPush iface $ byteString "partial"+ outBodyFlush iface+ -- As in 'resetAfterOne'.+ threadDelay 200000+ outBodyCancel iface Nothing responseHello :: Response responseHello = responseBuilder ok200 header body
test/HTTP3/ServerSpec.hs view
@@ -53,10 +53,14 @@ runSockAddrClient it "reads a body past a DATA frame that is empty" $ \_ -> runEmptyDataClient+ it "sends nothing on a stream it closes the connection for" $ \_ ->+ runAbortClient it "cancels a stream whose response it does not read to the end" $ \_ -> runCancelClient it "cancels a stream reset between two frames" $ \_ -> runResetCancelClient+ it "resets a response whose handler cancels it" $ \_ ->+ runHandlerCancelClient it "tells the handler of a request body cut short by a reset" $ \_ -> runResetRequestClient it "resets a request interrupted before its body is sent" $ \_ ->@@ -136,6 +140,22 @@ where emptyData = H3Frame H3FrameData "" +-- | DATA before HEADERS on a request stream is a connection error of type+-- H3_FRAME_UNEXPECTED (RFC 9114, section 4.1). The stream used to be ended+-- with a FIN, which could reach the client before the CONNECTION_CLOSE: an+-- empty response.+runAbortClient :: IO ()+runAbortClient = do+ r <- E.try $ QUIC.run testClientConfig $ \conn -> do+ strm <- Q.stream conn+ Q.sendStream strm "\x00\x00"+ Q.shutdownStream strm+ timeout 2000000 $ Q.recvStream strm 1024+ case r of+ Left (Q.ApplicationProtocolErrorIsReceived aerr _) ->+ aerr `shouldBe` H3FrameUnexpected+ _ -> expectationFailure $ "not the connection error: " ++ show r+ -- | RFC 9204, section 4.4.2: a decoder that gives up on a stream sends a -- Stream Cancellation, so that the encoder stops keeping the entries the -- field sections it will never hear about refer to. None was ever sent.@@ -310,6 +330,23 @@ threadDelay 100000 bs <- B.concat <$> readIORef sentOnDecoderStream B.elem 0x40 bs `shouldBe` True++-- | A response the handler cancels after a DATA frame ('outBodyCancel'):+-- the stream is reset, not ended with a FIN as though the body were whole.+runHandlerCancelClient :: IO ()+runHandlerCancelClient =+ QUIC.run testClientConfig $ \conn ->+ E.bracket allocSimpleConfig freeSimpleConfig $ \conf ->+ C.run conn testH3ClientConfig conf $ \sendRequest _aux -> do+ let req = C.requestNoBody methodGet "/cancel" []+ r <- E.try $ sendRequest req $ \rsp -> do+ let drain = do+ bs <- C.getResponseBodyChunk rsp+ unless (B.null bs) drain+ drain+ case r of+ Left (StreamResetIsReceived e) -> e `shouldBe` H3RequestCancelled+ Right () -> expectationFailure "the cancelled body was taken as whole" -- | A request body that throws part-way, so that the client resets the -- stream: the handler must not take what it read for the whole body.
test/QPACK/HeaderBlockSpec.hs view
@@ -2,7 +2,7 @@ module QPACK.HeaderBlockSpec where -import Control.Concurrent (threadDelay)+import Control.Concurrent (newEmptyMVar, putMVar, readMVar, threadDelay) import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Exception as E@@ -10,7 +10,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import Data.IORef-import Data.Maybe (isNothing)+import Data.Maybe (isJust, isNothing) import Network.HPACK.Token (toToken) import Network.QPACK import Network.QPACK.Internal (@@ -228,6 +228,49 @@ writeIORef diRef [di] drain diRef handleDI inserts 7 `shouldReturn` True++ it "goes on while the encoder stream waits" $ do+ -- The encoder stream stops, as when flow control holds it, in+ -- the middle of sending an insertion. An encoding with nothing+ -- to insert and the decoder's instructions used to wait for it.+ stuck <- newIORef False+ gate <- newEmptyMVar+ let sendEI _ = do+ s <- readIORef stuck+ when s $ readMVar gate+ (enc, handleDI, tblop) <- newQEncoder defaultQEncoderConfig sendEI+ setCapacity tblop 4096+ setBlockedStreams tblop 100+ let hdr = [(toToken "x-foo", "bar")]+ -- Inserted the second time it is seen.+ _ <- enc 0 hdr+ writeIORef stuck True+ inserting <- async $ enc 4 hdr+ threadDelay 10000+ timeout 1000000 (enc 8 [(toToken ":method", "GET")])+ >>= (`shouldSatisfy` isJust)+ diRef <- newIORef []+ di <- encodeDecoderInstructions [InsertCountIncrement 1]+ writeIORef diRef [di]+ timeout 1000000 (drain diRef handleDI) `shouldReturn` Just ()+ putMVar gate ()+ void $ wait inserting++ it "sends the insertions in order from encoders at once" $ do+ -- Sending outside the encoder's lock must not reorder them.+ eiRef <- newIORef []+ let sendEI bs = do+ threadDelay 100+ atomicModifyIORef' eiRef $ \bss -> (bss ++ [bs], ())+ (enc, _, tblop) <- newQEncoder defaultQEncoderConfig sendEI+ (dec, handleEI) <- newQDecoder defaultQDecoderConfig (\_ -> return ())+ setCapacity tblop 4096+ setBlockedStreams tblop 100+ let hdr i = [(toToken (C8.pack ("x-foo-" ++ show (i `mod` 20 :: Int))), "bar")]+ blks <- forConcurrently [0 .. 199] $ \i -> enc (i * 4) (hdr i)+ drain eiRef handleEI+ forM_ (zip [0 ..] blks) $ \(i, blk) ->+ fst <$> dec (i * 4) blk `shouldReturn` hdr i it "releases the sections of a stream the decoder cancels" $ do -- One blocked stream allowed, and nothing acknowledged. Stream 4