quic 0.3.13 → 0.3.14

raw patch · 13 files changed

+406/−38 lines, 13 files

Files

• ChangeLog.md +47/−0
• Network/QUIC/Client/Run.hs +14/−3
• Network/QUIC/Connection/Migration.hs +25/−0
• Network/QUIC/Connection/Types.hs +0/−1
• Network/QUIC/IO.hs +17/−12
• Network/QUIC/Receiver.hs +51/−7
• Network/QUIC/Sender.hs +17/−2
• Network/QUIC/Server/Reader.hs +0/−6
• quic.cabal +1/−1
• test/ErrorSpec.hs +74/−3
• test/HandshakeSpec.hs +114/−1
• test/IOSpec.hs +35/−0
• test/SetupSpec.hs +11/−2

@@ -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

@@ -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

@@ -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

@@ -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,

@@ -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 ()

@@ -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 ()

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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 ()

@@ -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