diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,52 @@ # ChangeLog +## 0.3.14 + +A buffer overrun on many streams at once, 0-RTT sent against no limit at +all, and two frames a receiver was taking on trust. + +* Count the frame headers when packing many streams into one packet. + `sendStreamSmall` fills a packet from the send queue up to 1040 octets + and was counting only the stream data, but every stream whose turn + comes needs a STREAM frame of its own and nineteen octets of header + with it. Hundreds of streams writing a byte or two each therefore + built a packet far larger than the buffer it is encoded into, and the + sender died of `BufferOverrun`. Seen in Cloud Haskell, where one + connection carries hundreds of processes. + [#153](https://github.com/kazu-yamamoto/quic/pull/153) + +* Hold a client sending 0-RTT to the limits the previous connection gave + it. RFC 9000 Sec 7.4.1 holds it to those until the server's own + arrive. `sendStreamMany` had a second road for 0-RTT that put the data + straight on the queue and told the flow control window about it + afterwards, so a resuming client could spend a connection window it had + not been given -- and a server that counts answers that with + FLOW_CONTROL_ERROR before the handshake has finished. Both roads go + through the check now, and the connection's own send limit is seeded + from the remembered parameters so that 0-RTT still carries data. It is + seeded beside the two stream counts that were already seeded there and + were being taken from `defaultParameters` -- 64 streams and ten + unidirectional, where a server may have allowed fewer, and since these + limits only ever rise one set too high stayed too high for the rest of + the connection. + [#156](https://github.com/kazu-yamamoto/quic/pull/156) + +* Refuse a NEW_CONNECTION_ID that contradicts an earlier one. RFC 9000 + Sec 19.15 leaves to the receiver a connection ID repeated with a + different stateless reset token or a different sequence number, and a + sequence number used for a different connection ID. Ours looked the + connection ID up, found it, and took the frame for a retransmission + without comparing what had come with it. A retransmission says exactly + what it said before, so it still passes. + [#157](https://github.com/kazu-yamamoto/quic/pull/157) + +* Refuse a RETIRE_CONNECTION_ID for the connection ID the packet carrying + it arrived on, which RFC 9000 Sec 19.16 also leaves to the receiver. + An endpoint has to stop using a connection ID before retiring it, so + the packet that retires one is addressed to another and nothing correct + is caught by this. + [#158](https://github.com/kazu-yamamoto/quic/pull/158) + ## 0.3.13 One line of debug output that could end the connection it described, and diff --git a/Network/QUIC/Client/Run.hs b/Network/QUIC/Client/Run.hs --- a/Network/QUIC/Client/Run.hs +++ b/Network/QUIC/Client/Run.hs @@ -72,9 +72,20 @@ handshaker <- handshakeClient conf' conn myAuthCIDs let client = do -- For 0-RTT, the following variables should be initialized - -- in advance. - setTxMaxStreams conn $ initialMaxStreamsBidi defaultParameters - setTxUniMaxStreams conn $ initialMaxStreamsUni defaultParameters + -- in advance -- from the parameters the previous connection + -- gave, which is what RFC 9000 Sec 7.4.1 holds a client + -- sending 0-RTT to, and not from 'defaultParameters'. Those + -- are 64 bidi streams and 10 uni where a server may have + -- allowed fewer, and since each of these setters only ever + -- raises, a limit too high here stayed too high for the rest + -- of the connection. The connection's own send limit + -- belongs with them and was missing altogether: it starts at + -- zero and nothing raised it before the handshake, so 0-RTT + -- stream data went out against no connection limit at all. + params <- getPeerParameters conn + setTxMaxData conn $ initialMaxData params + setTxMaxStreams conn $ initialMaxStreamsBidi params + setTxUniMaxStreams conn $ initialMaxStreamsUni params if ccUse0RTT conf then wait0RTTReady conn else wait1RTTReady conn diff --git a/Network/QUIC/Connection/Migration.hs b/Network/QUIC/Connection/Migration.hs --- a/Network/QUIC/Connection/Migration.hs +++ b/Network/QUIC/Connection/Migration.hs @@ -17,6 +17,7 @@ retireMyCID, isMyCIDSeqNumIssued, addPeerCID, + isPeerCIDConsistent, waitPeerCID, choosePeerCIDForPrivacy, setPeerStatelessResetToken, @@ -88,6 +89,30 @@ atomicModifyIORef' myCIDDB $ new cid srt ---------------------------------------------------------------- + +-- | Does this NEW_CONNECTION_ID agree with what the peer has already said? +-- +-- RFC 9000 Sec 19.15: a connection ID repeated with a different stateless +-- reset token or a different sequence number, or a sequence number used for +-- a different connection ID, MAY be treated as a connection error of type +-- PROTOCOL_VIOLATION. +-- +-- A retransmission says exactly what it said before and is not caught here, +-- which is the point of comparing the whole 'CIDInfo' rather than noting +-- that we have seen the connection ID. One that has since been retired is +-- no longer in the table and is not caught either; that is the lenient side +-- of a MAY, and the alternative is remembering every sequence number the +-- peer has ever used. +isPeerCIDConsistent :: Connection -> CIDInfo -> IO Bool +isPeerCIDConsistent Connection{..} cidInfo = agree <$> readTVarIO peerCIDDB + where + agree CIDDB{..} = ok bySeqNum && ok byCID + where + ok = maybe True (== cidInfo) + bySeqNum = IntMap.lookup (cidInfoSeq cidInfo) cidInfos + byCID = + flip IntMap.lookup cidInfos + =<< Map.lookup (cidInfoCID cidInfo) revInfos -- | Receiving NewConnectionID addPeerCID :: Connection -> CIDInfo -> IO Bool diff --git a/Network/QUIC/Connection/Types.hs b/Network/QUIC/Connection/Types.hs --- a/Network/QUIC/Connection/Types.hs +++ b/Network/QUIC/Connection/Types.hs @@ -18,7 +18,6 @@ import qualified Data.Map.Strict as Map import Data.X509 (CertificateChain) import Foreign.Marshal.Alloc -import Foreign.Ptr (nullPtr) import Network.Control ( Rate, RxFlow, diff --git a/Network/QUIC/IO.hs b/Network/QUIC/IO.hs --- a/Network/QUIC/IO.hs +++ b/Network/QUIC/IO.hs @@ -51,19 +51,18 @@ sendStreamMany s dats0 = do sclosed <- isTxStreamClosed s when sclosed $ E.throwIO StreamIsClosed - -- fixme: size check for 0RTT - let len = totalLen dats0 - ready <- isConnection1RTTReady conn - if not ready - then do - -- 0-RTT - putSendStreamQ conn $ TxStreamData s dats0 len False - addTx conn s len - else flowControl dats0 len False + flowControl dats0 (totalLen dats0) False where conn = streamConnection s + -- 0-RTT goes through here too. It used to take the other road: the + -- data went straight onto the queue and the window was told about it + -- afterwards, so a resuming client spent a connection window it had not + -- been given, and a server that counts answers that with + -- FLOW_CONTROL_ERROR. RFC 9000 Sec 7.4.1 holds a client sending 0-RTT + -- to the limits the previous connection gave, and those are in the + -- peer's parameters by the time anything is sent, so one check serves + -- both. flowControl dats len wait = do - -- 1-RTT -- FLOW CONTROL: MAX_STREAM_DATA: send: respecting peer's limit -- FLOW CONTROL: MAX_DATA: send: respecting peer's limit eblocked <- checkBlocked s len wait @@ -78,8 +77,14 @@ addTx conn s n flowControl dats2 (len - n) False Left blocked -> do - -- fixme: RTT0Level? - sendBlocked conn RTT1Level blocked + -- Read each time round rather than once: the handshake may + -- finish while we are waiting for the window, and a BLOCKED + -- frame at a level we have no keys for goes nowhere. + ready <- isConnection1RTTReady conn + let lvl + | ready = RTT1Level + | otherwise = RTT0Level + sendBlocked conn lvl blocked flowControl dats len True sendBlocked :: Connection -> EncryptionLevel -> Blocked -> IO () diff --git a/Network/QUIC/Receiver.hs b/Network/QUIC/Receiver.hs --- a/Network/QUIC/Receiver.hs +++ b/Network/QUIC/Receiver.hs @@ -192,6 +192,7 @@ when (nkp /= ckp && plainPacketNumber > cpn) $ do setCurrentKeyPhase conn nkp plainPacketNumber updateCoder1RTT conn ckp -- ckp is now next + checkRetireOfArrivalCID conn hdr plainFrames mapM_ (processFrame conn lvl) plainFrames when ackEli $ do case lvl of @@ -288,6 +289,38 @@ deliverStream conn found strm = when (isNothing found) $ putInput conn $ InpStream strm +-- | Refusing a RETIRE_CONNECTION_ID that retires the connection ID the +-- packet carrying it was addressed to. +-- +-- RFC 9000 Sec 19.16: "The sequence number specified in a +-- RETIRE_CONNECTION_ID frame MUST NOT refer to the Destination Connection +-- ID field of the packet in which the frame is contained. The peer MAY +-- treat this as a connection error of type PROTOCOL_VIOLATION." +-- +-- Here rather than in 'processFrame', which is handed the level and one +-- frame and not the header the sequence number has to be read against. +-- Giving all twenty-eight of its equations an argument for the sake of this +-- one is a worse trade than reading the frames twice. +-- +-- A peer with nothing wrong with it cannot trip this: it has to stop using +-- a connection ID before retiring it, so the packet that retires one is +-- addressed to another. A retransmission cannot either -- it goes to a +-- connection ID we still have, and the retired one we no longer answer on +-- at all. +checkRetireOfArrivalCID :: Connection -> Header -> [Frame] -> IO () +checkRetireOfArrivalCID conn hdr frames = do + mseq <- myCIDsInclude conn $ headerMyCID hdr + case mseq of + Nothing -> return () + Just sn -> + when (sn `elem` retired) $ + closeConnection + conn + ProtocolViolation + "RETIRE_CONNECTION_ID for the CID it arrived on" + where + retired = [n | RetireConnectionID n <- frames] + processFrame :: Connection -> EncryptionLevel -> Frame -> IO () processFrame _ _ Padding{} = return () processFrame conn lvl Ping = do @@ -348,8 +381,8 @@ -- by the tail of every stream it resets, until it has none left. unarrived <- takeRxUncounted strm when (unarrived > 0) $ do - ok <- checkRxMaxData conn unarrived - unless ok $ + ok' <- checkRxMaxData conn unarrived + unless ok' $ closeConnection conn FlowControlError "Flow control error for connection" mx <- updateFlowRx conn unarrived forM_ mx $ \newMax -> do @@ -565,6 +598,19 @@ seqNum = cidInfoSeq cidInfo when (cidlen < 1 || 20 < cidlen || retirePriorTo > seqNum) $ closeConnection conn FrameEncodingError "NEW_CONNECTION_ID parameter error" + -- RFC 9000 Sec 19.15 says: + -- If an endpoint receives a NEW_CONNECTION_ID frame that repeats a + -- previously issued connection ID with a different Stateless Reset + -- Token field value or a different Sequence Number field value, or + -- if a sequence number is used for different connection IDs, the + -- endpoint MAY treat that receipt as a connection error of type + -- PROTOCOL_VIOLATION. + -- + -- Before the retirement below: a frame that contradicts what the + -- peer has already said is not one to act on. + consistent <- isPeerCIDConsistent conn cidInfo + unless consistent $ + closeConnection conn ProtocolViolation "NEW_CONNECTION_ID repeated differently" -- Retiring CIDs first then add a new CID. -- -- RFC 9000 Sec 5.1.1 says: @@ -611,11 +657,9 @@ issued <- isMyCIDSeqNumIssued conn sn unless issued $ closeConnection conn ProtocolViolation "RETIRE_CONNECTION_ID never issued" - -- FIXME: CID is necessary here - -- The sequence number specified in a RETIRE_CONNECTION_ID frame - -- MUST NOT refer to the Destination Connection ID field of the - -- packet in which the frame is contained. The peer MAY treat this - -- as a connection error of type PROTOCOL_VIOLATION. + -- The sequence number it must not refer to is the one the packet was + -- addressed to, and the header is not here. See + -- 'checkRetireOfArrivalCID'. mcidInfo <- retireMyCID conn sn case mcidInfo of Nothing -> return () diff --git a/Network/QUIC/Sender.hs b/Network/QUIC/Sender.hs --- a/Network/QUIC/Sender.hs +++ b/Network/QUIC/Sender.hs @@ -485,6 +485,16 @@ limitation :: Int limitation = 1040 +-- | Upper bound on what a stream frame takes on top of its data +streamFrameMaxOverhead :: Int +streamFrameMaxOverhead + = sum + [ 1 -- type + , 8 -- stream ID + , 8 -- offset + , 2 -- length + ] + packFin :: Connection -> Stream -> Bool -> IO Bool packFin _ _ True = return True packFin conn s False = do @@ -509,7 +519,7 @@ let sid0 = streamId s0 frame0 = StreamF sid0 off0 dats0 fin0 sb = if fin0 then (s0 :) else id - (frames, streams) <- loop s0 frame0 len0 id sb + (frames, streams) <- loop s0 frame0 (len0 + streamFrameMaxOverhead) id sb ready <- isConnection1RTTReady conn let lvl | ready = RTT1Level @@ -536,7 +546,12 @@ case mx of Nothing -> return (build [frame], sb []) Just (TxStreamData s1 dats1 len1 fin1) -> do - let total1 = len1 + total + -- Entries of the same stream are merged into one frame, + -- any other stream needs a frame of its own. + let cost + | streamId s1 == streamId s = len1 + | otherwise = len1 + streamFrameMaxOverhead + total1 = cost + total if total1 < limitation then do _ <- takeSendStreamQ conn -- cf tryPeek diff --git a/Network/QUIC/Server/Reader.hs b/Network/QUIC/Server/Reader.hs --- a/Network/QUIC/Server/Reader.hs +++ b/Network/QUIC/Server/Reader.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -34,11 +33,6 @@ import qualified Network.Socket.ByteString as NSB import qualified System.IO.Error as E import System.Log.FastLogger -#if MIN_VERSION_random(1,3,0) -import System.Random (getStdRandom, randomRIO, uniformByteString) -#else -import System.Random (getStdRandom, randomRIO, genByteString) -#endif import Network.QUIC.Common import Network.QUIC.Config diff --git a/quic.cabal b/quic.cabal --- a/quic.cabal +++ b/quic.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: quic -version: 0.3.13 +version: 0.3.14 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -5,9 +5,13 @@ import Control.Concurrent import Control.Monad (forever, void) import Data.ByteString () +import qualified System.Timeout as Timeout +import Test.Hspec + import Network.QUIC +import qualified Network.QUIC.Client as C +import Network.QUIC.Internal import Network.QUIC.Server -import Test.Hspec import Config import TransportError @@ -38,5 +42,72 @@ teardown = killThread spec :: Spec -spec = - beforeAll setup $ afterAll teardown $ transportErrorSpec testClientConfig 2000 -- 2 seconds +spec = beforeAll setup $ afterAll teardown $ do + transportErrorSpec testClientConfig 2000 -- 2 seconds + -- RFC 9000 Sec 19.15 leaves these to the receiver -- "MAY treat that + -- receipt as a connection error" -- so they live here and not in + -- TransportError, which is the MUSTs and is run against other + -- implementations. + describe "NEW_CONNECTION_ID" $ do + it "refuses one connection ID offered under two sequence numbers" $ \_ -> + runQuietly (hooked oneCIDTwoSeqNums) `shouldThrow` protocolViolation + it "refuses one sequence number offered for two connection IDs" $ \_ -> + runQuietly (hooked oneSeqNumTwoCIDs) `shouldThrow` protocolViolation + -- RFC 9000 Sec 19.16, also a MAY. + describe "RETIRE_CONNECTION_ID" $ + it "refuses one for the connection ID it arrived on" $ \_ -> + runQuietly (hooked retireArrivalCID) + `shouldThrow` violationSaying "RETIRE_CONNECTION_ID for the CID it arrived on" + +-- | A client that connects, says nothing, and waits to be closed. +runQuietly :: ClientConfig -> IO (Maybe ()) +runQuietly cc = Timeout.timeout 2000000 $ C.run cc $ \conn -> do + waitEstablished conn + threadDelay 2000000 + +hooked :: (EncryptionLevel -> Plain -> Plain) -> ClientConfig +hooked f = cc{ccHooks = (ccHooks cc){onPlainCreated = f}} + where + cc = testClientConfig + +protocolViolation :: QUICException -> Bool +protocolViolation (TransportErrorIsReceived te _) = te == ProtocolViolation +protocolViolation _ = False + +-- | The reason phrase matters here: a sequence number that was never issued +-- is a PROTOCOL_VIOLATION too, and that check would answer for this one. +violationSaying :: ReasonPhrase -> QUICException -> Bool +violationSaying want (TransportErrorIsReceived te got) = + te == ProtocolViolation && got == want +violationSaying _ _ = False + +srt1, srt2 :: StatelessResetToken +srt1 = StatelessResetToken "0123456789abcdef" +srt2 = StatelessResetToken "fedcba9876543210" + +cid1, cid2 :: CID +cid1 = makeCID "\x01\x01\x01\x01\x01\x01\x01\x01" +cid2 = makeCID "\x02\x02\x02\x02\x02\x02\x02\x02" + +-- | Two frames in one packet, the second contradicting the first. Both go +-- out together so that the peer has no chance to retire the first. +contradict :: CIDInfo -> CIDInfo -> EncryptionLevel -> Plain -> Plain +contradict a b lvl plain + | lvl == RTT1Level = plain{plainFrames = frames ++ plainFrames plain} + | otherwise = plain + where + frames = [NewConnectionID a 0, NewConnectionID b 0] + +-- | Retiring sequence number 0, which is the connection ID the server first +-- gave and the one a client is still using. +retireArrivalCID :: EncryptionLevel -> Plain -> Plain +retireArrivalCID lvl plain + | lvl == RTT1Level = + plain{plainFrames = RetireConnectionID 0 : plainFrames plain} + | otherwise = plain + +oneCIDTwoSeqNums :: EncryptionLevel -> Plain -> Plain +oneCIDTwoSeqNums = contradict (newCIDInfo 10 cid1 srt1) (newCIDInfo 11 cid1 srt1) + +oneSeqNumTwoCIDs :: EncryptionLevel -> Plain -> Plain +oneSeqNumTwoCIDs = contradict (newCIDInfo 10 cid1 srt1) (newCIDInfo 10 cid2 srt2) diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module HandshakeSpec where @@ -46,7 +47,9 @@ it "can request and accept a client certificate" $ do let TLS.Credentials credentials = scCredentials sc0 credential <- case credentials of - [] -> expectationFailure "test server has no credentials" >> fail "missing credentials" + [] -> + expectationFailure "test server has no credentials" + >> fail "missing credentials" cred : _ -> pure cred let clientHooks = (ccTlsHooks testClientConfig) @@ -80,6 +83,21 @@ let cc = testClientConfig sc = sc0{scUse0RTT = True} testHandshake2 cc sc waitS (FullHandshake, RTT0) True + it "keeps 0-RTT within the limits the previous connection gave" $ do + let cc = testClientConfig + sc = + sc0 + { scUse0RTT = True + , scParameters = + (scParameters sc0) + { initialMaxData = limit + , initialMaxStreamDataBidiRemote = limit + } + } + test0RTTFlowControl cc sc waitS + it "sends 0-RTT data without waiting for the handshake" $ do + let sc = sc0{scUse0RTT = True} + test0RTTSendsEarly sc waitS it "fails with unknown server certificate" $ do let cc1 = testClientConfig @@ -146,6 +164,101 @@ sendStream s content shutdownStream s void $ recvStream s 1024 + +-- | The limit the server gives, which the second connection sends more than. +limit :: Int +limit = 1024 + +-- | A client sending 0-RTT is held to the limits the previous connection +-- gave it (RFC 9000 Sec 7.4.1). +-- +-- 0-RTT stream data used to bypass the flow control check altogether: it +-- went onto the send queue and the window was told about it afterwards, so +-- a resuming client spent a connection window it had not been given. A +-- server that counts -- ours does -- answers that with FLOW_CONTROL_ERROR +-- before the handshake has even finished. +-- +-- The data has to be written before the handshake completes for any of this +-- to be exercised, so this does not go through 'query', which waits for the +-- connection to be established first. +test0RTTFlowControl :: ClientConfig -> ServerConfig -> IO () -> IO () +test0RTTFlowControl cc1 sc waitS = do + mvar <- newEmptyMVar + E.bracket (forkIO $ server mvar) killThread $ \_ -> client mvar + where + content = BS.replicate (limit * 4) 97 + client mvar = do + waitS + res <- C.run cc1 $ \conn -> do + query "first" conn + threadDelay 50000 + getResumptionInfo conn + threadDelay 50000 + let cc2 = cc1{ccResumption = res, ccUse0RTT = True} + C.run cc2 $ \conn -> do + s <- stream conn + sendStream s content + shutdownStream s + void $ recvStream s 1024 + takeMVar mvar + server mvar = S.run sc serv + where + serv conn = do + s <- acceptStream conn + bs <- recvAll s id + sendStream s "bye" + closeStream s + when (bs == content) $ putMVar mvar () + recvAll s build = do + bs <- recvStream s 1024 + if BS.null bs + then return $ BS.concat $ build [] + else recvAll s (build . (bs :)) + +-- | The remembered limits are what let 0-RTT carry anything at all. +-- +-- The connection's own send limit starts at zero and the handshake is what +-- raises it, so a client that checks the connection window before the +-- handshake -- which it has to, see above -- has nothing to spend until the +-- handshake is over, and 0-RTT carries no data. What it may spend is what +-- the previous connection gave it. +-- +-- Every packet from the server is dropped here, so the handshake cannot +-- finish and a send that waits for it waits for good. +test0RTTSendsEarly :: ServerConfig -> IO () -> IO () +test0RTTSendsEarly sc waitS = + E.bracket (forkIO server) killThread $ \_ -> do + waitS + resVar <- newEmptyMVar + withPipe (DropServerPacket []) $ do + res <- C.run testClientConfigR $ \conn -> do + query "first" conn + threadDelay 50000 + getResumptionInfo conn + putMVar resVar res + res <- takeMVar resVar + threadDelay 50000 + let cc = + testClientConfigR + { ccResumption = res + , ccUse0RTT = True + } + sent <- newEmptyMVar + withPipe (DropServerPacket [0 .. 50]) $ do + void $ forkIO $ void $ ignoreQUIC $ C.run cc $ \conn -> do + s <- stream conn + sendStream s $ BS.replicate limit 97 + putMVar sent () + threadDelay 5000000 + Timeout.timeout 2000000 (takeMVar sent) `shouldReturn` Just () + where + server = S.run sc $ \conn -> do + s <- acceptStream conn + void $ recvStream s 1024 + sendStream s "bye" + closeStream s + ignoreQUIC :: IO () -> IO () + ignoreQUIC act = act `E.catch` \(_ :: E.SomeException) -> return () testHandshake2 :: ClientConfig diff --git a/test/IOSpec.hs b/test/IOSpec.hs --- a/test/IOSpec.hs +++ b/test/IOSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -156,9 +157,43 @@ describe "concurrency" $ do it "can handle multiple clients" $ do withPipe (Randomly 20) $ testMultiSendRecv cc sc waitS 500 + describe "packing" $ do + it "fits the frames of many streams with tiny writes into a packet" $ do + withPipe (DropClientPacket []) $ testTinyWrites cc sc waitS describe "abortConnection" $ do it "can abort connection" $ do withPipe (Randomly 20) $ testAbort cc sc waitS + +-- | Writing data to many, many streams doesn't cause a buffer overrun +testTinyWrites :: C.ClientConfig -> ServerConfig -> IO () -> IO () +testTinyWrites cc sc0 waitS = do + doneVar <- newChan + withAsync (server doneVar) $ \_ -> client doneVar + where + nStreams = 400 + sc = + sc0 + { scParameters = + (scParameters sc0){initialMaxStreamsBidi = 2 * nStreams} + } + + client doneVar = do + waitS + C.run cc $ \conn -> do + strms <- replicateM nStreams (stream conn) + forM_ strms $ \strm -> sendStream strm "a" + threadDelay 200_000 + forM_ strms $ \strm -> sendStream strm "b" + -- Wait for the server to have read both bytes of every stream + -- before closing the connection. + mres <- Timeout.timeout 10_000_000 $ replicateM_ nStreams $ readChan doneVar + mres `shouldBe` Just () + + server doneVar = run sc $ \conn -> forever $ do + strm <- acceptStream conn + void $ forkIO $ do + consumeBytes strm 2 + writeChan doneVar () consumeBytes :: Stream -> Int -> IO () consumeBytes _ 0 = return () diff --git a/test/SetupSpec.hs b/test/SetupSpec.hs --- a/test/SetupSpec.hs +++ b/test/SetupSpec.hs @@ -15,7 +15,7 @@ -- hung every CI job on the former. module SetupSpec where -import Control.Concurrent (threadDelay) +import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as E import System.Directory @@ -42,10 +42,18 @@ let qdir = dir "qlog" createDirectory qdir sc0 <- makeTestServerConfig + -- Waiting for the port to be bound. Without this the + -- client can start first, hear nothing, and give up on its + -- idle timeout having never made the server open a qlog at + -- all: the directory is then empty and the test fails + -- saying so rather than saying anything about handles. One + -- run in five on a busy machine. + ready <- newEmptyMVar let sc = sc0 { scQLog = Just qdir , scDebugLog = Just (dir "not-a-directory") + , scHooks = (scHooks sc0){onServerReady = putMVar ready ()} } cc = testClientConfig @@ -54,7 +62,8 @@ { maxIdleTimeout = Milliseconds 1000 } } - withAsync (run sc $ \_ -> return ()) $ \_ -> + withAsync (run sc $ \_ -> return ()) $ \_ -> do + takeMVar ready C.run cc (\_ -> return ()) `shouldThrow` (\(_ :: QUICException) -> True) -- If the handle is still open, GHC's own lock on the file