quic 0.3.20 → 0.3.21

raw patch · 29 files changed

+655/−139 lines, 29 filesdep ~asyncdep ~tlsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: async, tls

API changes (from Hackage documentation)

Files

• ChangeLog.md +37/−0
• Network/QUIC/Client/Reader.hs +4/−4
• Network/QUIC/Connection/Migration.hs +63/−17
• Network/QUIC/Connection/Misc.hs +18/−10
• Network/QUIC/Connection/State.hs +8/−1
• Network/QUIC/Connection/Stream.hs +13/−0
• Network/QUIC/Connection/StreamTable.hs +12/−0
• Network/QUIC/Connection/Types.hs +15/−4
• Network/QUIC/Handshake.hs +29/−18
• Network/QUIC/Packet/Decode.hs +4/−1
• Network/QUIC/Packet/Frame.hs +11/−7
• Network/QUIC/Receiver.hs +10/−0
• Network/QUIC/Recovery.hs +3/−0
• Network/QUIC/Recovery/LossRecovery.hs +12/−8
• Network/QUIC/Recovery/Timer.hs +17/−10
• Network/QUIC/Recovery/Utils.hs +14/−3
• Network/QUIC/Sender.hs +26/−11
• Network/QUIC/Stream.hs +2/−0
• Network/QUIC/Stream/Misc.hs +7/−0
• Network/QUIC/Stream/Table.hs +5/−0
• Network/QUIC/TLS.hs +50/−2
• quic.cabal +5/−5
• test/DatagramSpec.hs +37/−2
• test/FrameSpec.hs +9/−0
• test/HandshakeSpec.hs +109/−8
• test/IOSpec.hs +66/−26
• test/MigrationSpec.hs +21/−1
• test/PacketSpec.hs +8/−1
• test/RecoverySpec.hs +40/−0

@@ -1,5 +1,42 @@ # ChangeLog +## 0.3.21++Requires tls 2.5.1 and async 2.2, and allows iproute 1.8 and unix-time+0.6.  A server now keeps the limits 0-RTT is held to in the session+(`sessionAppData`, which it overwrites) and refuses 0-RTT if it allows less+now; a session saved without them, e.g. by tls 2.5.0, gets no 0-RTT.  A+client whose 0-RTT is not accepted drops the limits it remembered, but+what it already sent in 0-RTT is still resent as 1-RTT.  In+`Network.QUIC.Internal`, `connAbortRequest` holds an exception, `Output`+has `OutPathProbe`, and `SendChallenge` keeps a list of payloads.++* Release lost candidates only on a 1-RTT ACK+  [#204](https://github.com/kazu-yamamoto/quic/pull/204)+* Follow RFC 9002 A.8 in choosing the PTO space+  [#205](https://github.com/kazu-yamamoto/quic/pull/205)+* Decode ACK_ECN as ACK+  [#206](https://github.com/kazu-yamamoto/quic/pull/206)+* Refuse an empty NEW_TOKEN+  [#207](https://github.com/kazu-yamamoto/quic/pull/207)+* Do not check the QUIC bit of Version Negotiation+  [#208](https://github.com/kazu-yamamoto/quic/pull/208)+* Go back to the old path as soon as the peer is heard there+  [#209](https://github.com/kazu-yamamoto/quic/pull/209)+* Challenge the old path too on a migration+  [#210](https://github.com/kazu-yamamoto/quic/pull/210)+* Ask the protocol threads to end instead of throwing to the main thread+  [#211](https://github.com/kazu-yamamoto/quic/pull/211)+* Reset the remembered limits when 0-RTT is rejected+  [#212](https://github.com/kazu-yamamoto/quic/pull/212)+* Refuse 0-RTT when the server allows less than it did+  [#213](https://github.com/kazu-yamamoto/quic/pull/213)+* Require async 2.2+  [#214](https://github.com/kazu-yamamoto/quic/pull/214)+* Reset the remembered limits whenever 0-RTT is not accepted+  [#215](https://github.com/kazu-yamamoto/quic/pull/215)+* Send the path challenge again with a new payload until answered+  [#216](https://github.com/kazu-yamamoto/quic/pull/216)  ## 0.3.20 

@@ -12,10 +12,10 @@  import Control.Concurrent import Control.Concurrent.STM-import Data.Functor (($>))-import qualified Control.Monad.STM as STM import qualified Control.Exception as E+import qualified Control.Monad.STM as STM import qualified Data.ByteString as BS+import Data.Functor (($>)) import Data.List (intersect) import Network.Socket (Socket, getSocketName) import qualified Network.Socket.ByteString as NSB@@ -120,7 +120,7 @@                 nextVerInfo = case myVers `intersect` peerVers of                     vers@(ver : _) -> VersionInfo ver vers                     _ -> brokenVersionInfo-            E.throwTo (mainThreadId conn) $ VerNego nextVerInfo+            requestEnd conn $ VerNego nextVerInfo     putQ t (PacketIC pkt@(CryptPacket hdr crypt) lvl siz) = do         let cid = headerMyCID hdr         included <- myCIDsInclude conn cid@@ -137,7 +137,7 @@                     when isStatelessReset $ do                         qlogReceived conn StatelessReset t                         connDebugLog conn "debug: connection is reset statelessly"-                        E.throwTo (mainThreadId conn) ConnectionIsReset+                        requestEnd conn ConnectionIsReset                 _ -> return () -- really invalid, just ignore     putQ t (PacketIR pkt@(RetryPacket ver dCID sCID token ex)) = do         qlogReceived conn pkt t

@@ -23,6 +23,7 @@     setPeerStatelessResetToken,     isStatelessRestTokenValid,     claimMigration,+    abandonMigration,     checkResponse,     validatePath,     getMyRetirePriorTo,@@ -355,8 +356,8 @@ validatePath conn pathInfo Nothing = do     pdat <- newPathData     setChallenges conn pathInfo pdat-    putOutput conn $ OutControl RTT1Level [PathChallenge pdat]-    waitResponse conn+    putOutput conn $ challengeOutput conn pathInfo [PathChallenge pdat]+    waitResponse conn pathInfo validatePath conn pathInfo (Just cidInfo) = do     pdat <- newPathData     setChallenges conn pathInfo pdat@@ -375,12 +376,20 @@             else                 return []     let frames = extra ++ [PathChallenge pdat, RetireConnectionID retiredSeqNum]-    putOutput conn $ OutControl RTT1Level frames-    waitResponse conn+    putOutput conn $ challengeOutput conn pathInfo frames+    waitResponse conn pathInfo +-- | A server sends the challenge to the path it is for, which may not be+--   the one in use by the time it leaves.  A client's socket may be+--   connected, and so cannot be given an address.+challengeOutput :: Connection -> PathInfo -> [Frame] -> Output+challengeOutput conn pathInfo frames+    | isServer conn = OutPathProbe pathInfo frames+    | otherwise = OutControl RTT1Level frames+ setChallenges :: Connection -> PathInfo -> PathData -> IO () setChallenges Connection{..} pathInfo pdat =-    atomically $ writeTVar migrationState $ SendChallenge pathInfo pdat+    atomically $ writeTVar migrationState $ SendChallenge pathInfo [pdat]  -- | Take on the migration, if no one has it. --@@ -406,24 +415,61 @@ -- | Waiting for the PATH_RESPONSE, for three times the larger of the PTO --   and the PTO of a new path (RFC 9000 Sec 8.2.4).  It used to wait for --   ever, and no other migration could start meanwhile.-waitResponse :: Connection -> IO Bool-waitResponse Connection{..} = do+--+-- A challenge is sent again, with a new payload, every one of those+--   periods (Sec 8.2.1): a lost one is not resent, and with only one a+--   single loss failed the validation.+waitResponse :: Connection -> PathInfo -> IO Bool+waitResponse conn@Connection{..} pathInfo = do     pto <- getPTO connLDCC-    let Microseconds us = 3 * max pto (calcPTO initialRTT Nothing)-    expired <- registerDelay us-    atomically $ do-        state <- readTVar migrationState-        timedOut <- readTVar expired-        check (state == RecvResponse || timedOut)-        writeTVar migrationState NonMigration-        return (state == RecvResponse)+    let period = max pto (calcPTO initialRTT Nothing)+        Microseconds total = 3 * period+        Microseconds every = period+    expired <- registerDelay total+    let loop = do+            again <- registerDelay every+            r <- atomically $ do+                state <- readTVar migrationState+                timedOut <- readTVar expired+                resend <- readTVar again+                if state == RecvResponse || state == MigrationAbandoned || timedOut+                    then do+                        writeTVar migrationState NonMigration+                        return $ Just (state == RecvResponse)+                    else if resend then return Nothing else retry+            case r of+                Just ok -> return ok+                Nothing -> do+                    pdat <- newPathData+                    sent <- atomically $ do+                        state <- readTVar migrationState+                        case state of+                            SendChallenge p pdats -> do+                                writeTVar migrationState $ SendChallenge p (pdat : pdats)+                                return True+                            _ -> return False+                    when sent $+                        putOutput conn $+                            challengeOutput conn pathInfo [PathChallenge pdat]+                    loop+    loop +-- | RFC 9000 Sec 9.3.2: a newer packet from the last validated address+--   ends the validation of the new one, which then fails at once and+--   sends us back there.+abandonMigration :: Connection -> IO ()+abandonMigration Connection{..} = atomically $ do+    s <- readTVar migrationState+    case s of+        SendChallenge{} -> writeTVar migrationState MigrationAbandoned+        _ -> return ()+ checkResponse :: Connection -> PathData -> IO () checkResponse Connection{..} pdat = do     state <- readTVarIO migrationState     case state of-        SendChallenge pathInfo pdat'-            | pdat == pdat' -> atomically $ do+        SendChallenge pathInfo pdats+            | pdat `elem` pdats -> atomically $ do                 writeTVar migrationState RecvResponse                 writeTVar (addressValidated pathInfo) True         _ -> return ()

@@ -38,6 +38,7 @@     sendFrames,     closeConnection,     abortConnection,+    requestEnd,     watchAbortRequest,     abortRequested, ) where@@ -141,7 +142,10 @@  -- | Going back to a path, forgetting the one in use. restorePathInfo :: Connection -> PathInfo -> IO ()-restorePathInfo Connection{..} oldpi = writeIORef peerInfo $ PeerInfo oldpi Nothing+restorePathInfo Connection{..} oldpi = do+    PeerInfo failed _ <- readIORef peerInfo+    writeIORef peerInfo $ PeerInfo oldpi Nothing+    atomically $ writeTVar (pathAbandoned failed) True  findPathInfo :: Connection -> SockAddr -> IO (Maybe PathInfo) findPathInfo Connection{..} sa = do@@ -314,10 +318,16 @@ -- just never looks.  The first request is the one acted on. abortConnection     :: Connection -> ApplicationProtocolError -> ReasonPhrase -> IO ()-abortConnection Connection{..} err desc =-    atomically $ modifyTVar' connAbortRequest $ \r -> r <|> Just (err, desc)+abortConnection conn err desc = requestEnd conn $ Abort err desc --- | A connection's ending, as 'abortConnection' asked for it if it did.+-- | Asking the connection's protocol threads to end it with this+--   exception, as 'abortConnection' does.  For threads outside them, such+--   as a reader, which used to throw to the connection's main thread.+requestEnd :: E.Exception e => Connection -> e -> IO ()+requestEnd Connection{..} e =+    atomically $ modifyTVar' connAbortRequest $ \r -> r <|> Just (E.toException e)++-- | A connection's ending, as 'requestEnd' asked for it if it did. --   An application that asks and returns at once can see the protocol --   threads end before they have acted on it; it is what it asked for all --   the same.@@ -325,15 +335,13 @@     :: Connection -> Either E.SomeException a -> IO (Either E.SomeException a) abortRequested Connection{..} ex@(Right _) = do     req <- readTVarIO connAbortRequest-    return $ case req of-        Nothing -> ex-        Just (err, desc) -> Left $ E.toException $ Abort err desc+    return $ maybe ex Left req abortRequested _ ex = return ex --- | Waiting for 'abortConnection' and raising 'Abort' when it is asked:+-- | Waiting for 'requestEnd' and raising what it was asked with: --   one of a connection's protocol threads, so that it ends the connection --   as any of them failing does. watchAbortRequest :: Connection -> IO () watchAbortRequest Connection{..} = do-    (err, desc) <- atomically $ readTVar connAbortRequest >>= maybe retry return-    E.throwIO $ Abort err desc+    e <- atomically $ readTVar connAbortRequest >>= maybe retry return+    E.throwIO e

@@ -15,6 +15,7 @@     readConnectionFlowTx,     addTxData,     setTxMaxData,+    resetTxMaxData,     getRxMaxData,     updateFlowRx,     checkRxMaxData,@@ -120,6 +121,11 @@         | txfLimit flow < n = flow{txfLimit = n}         | otherwise = flow +-- | 'setTxMaxData' that may lower: only for 0-RTT rejected.+resetTxMaxData :: Connection -> Int -> IO ()+resetTxMaxData Connection{..} n =+    atomically $ modifyTVar' flowTx $ \flow -> flow{txfLimit = n}+ ----------------------------------------------------------------  getRxMaxData :: Connection -> IO Int@@ -171,7 +177,8 @@ checkAntiAmplificationFreeSTM :: PathInfo -> Int -> STM Bool checkAntiAmplificationFreeSTM PathInfo{..} siz = do     validated <- readTVar addressValidated-    if validated+    abandoned <- readTVar pathAbandoned+    if validated || abandoned         then return True         else do             tx <- readTVar pathBytesTx

@@ -8,6 +8,8 @@     waitMyNewUniStreamId,     setTxMaxStreams,     setTxUniMaxStreams,+    resetTxMaxStreams,+    resetTxUniMaxStreams,     checkRxMaxStreams,     updatePeerStreamId,     checkStreamIdRoom,@@ -60,6 +62,17 @@  setTxUniMaxStreams :: Connection -> Int -> IO () setTxUniMaxStreams Connection{..} = set myUniStreamId++-- | Setting the limits on the streams I may open even lower: only for+--   0-RTT rejected.+resetTxMaxStreams :: Connection -> Int -> IO ()+resetTxMaxStreams Connection{..} = reset myStreamId++resetTxUniMaxStreams :: Connection -> Int -> IO ()+resetTxUniMaxStreams Connection{..} = reset myUniStreamId++reset :: TVar Concurrency -> Int -> IO ()+reset tvar mx = atomically $ modifyTVar' tvar $ \conc -> conc{maxStreams = StreamIdBase mx}  -- | Raising the limit on the streams I may open. --

@@ -6,6 +6,7 @@     claimPeerStream,     findStream,     addStream,+    resetTxStreamLimits,     delStream,     departStream,     Arrival (..),@@ -76,6 +77,17 @@                 newStream conn sid txLim rxLim     atomically $ modifyTVar' streamTable $ insertStream sid strm     return strm++-- | 0-RTT rejected (RFC 9001 Sec 4.6.2): the streams the client opened+--   under the remembered limits are held to what the server gives now.+resetTxStreamLimits :: Connection -> Parameters -> IO ()+resetTxStreamLimits Connection{..} serverParams = do+    strms <- tableStreams <$> readTVarIO streamTable+    forM_ strms $ \strm -> do+        let sid = streamId strm+        when (sid >= 0 && isClientInitiated sid) $+            resetTxMaxStreamData strm $+                serverInitial sid serverParams  delStream :: Connection -> Stream -> IO () delStream Connection{..} strm =

@@ -7,6 +7,7 @@  import Control.Concurrent import Control.Concurrent.STM+import qualified Control.Exception as E import qualified Crypto.Token as CT import Data.Array.IO import Data.ByteString.Internal@@ -114,14 +115,17 @@ data MigrationState     = NonMigration     | MigrationStarted-    | SendChallenge PathInfo PathData+    | -- | The challenges sent so far, the latest first.+      SendChallenge PathInfo [PathData]     | RecvResponse+    | MigrationAbandoned  {- FOURMOLU_DISABLE -} instance Eq MigrationState where     NonMigration     == NonMigration     = True     MigrationStarted == MigrationStarted = True     RecvResponse     == RecvResponse     = True+    MigrationAbandoned == MigrationAbandoned = True     _                == _                = False {- FOURMOLU_ENABLE -} @@ -237,6 +241,9 @@     , pathBytesTx :: TVar Int -- TVar for anti amplification     , pathBytesRx :: TVar Int -- TVar for anti amplification     , addressValidated :: TVar Bool+    , pathAbandoned :: TVar Bool+    -- ^ Gone back from: a send waiting for its anti-amplification+    --   credit goes to the path now in use instead.     }  newPathInfo :: SockAddr -> IO PathInfo@@ -244,6 +251,7 @@     pathBytesTx <- newTVarIO 0     pathBytesRx <- newTVarIO 0     addressValidated <- newTVarIO False+    pathAbandoned <- newTVarIO False     return PathInfo{..}  ----------------------------------------------------------------@@ -319,9 +327,9 @@     , bytesTx           :: IORef Int     , bytesRx           :: IORef Int     , connDone          :: TVar Bool-    , connAbortRequest  :: TVar (Maybe (ApplicationProtocolError, ReasonPhrase))-    -- ^ What 'Network.QUIC.Connection.Misc.abortConnection' asked to close-    --   the connection with, for its protocol threads to act on.+    , connAbortRequest  :: TVar (Maybe E.SomeException)+    -- ^ How 'Network.QUIC.Connection.Misc.requestEnd' asked the connection+    --   to end, for its protocol threads to act on.     , -- TLS       pendingQ          :: Array EncryptionLevel (TVar [ReceivedPacket])     , ciphers           :: IOArray EncryptionLevel Cipher@@ -555,6 +563,8 @@     = OutControl EncryptionLevel [Frame]     | OutHandshake [(EncryptionLevel, ByteString)]     | OutRetrans PlainPacket+    | -- | 1-RTT frames for a path other than the one in use.+      OutPathProbe PathInfo [Frame]  -- | The control frames of an output, which 'queuedControls' counts. --   Not data, which flow control bounds, nor what is never resent.@@ -562,6 +572,7 @@ countControls (OutControl _ frames) = length $ filter isControl frames countControls (OutRetrans (PlainPacket _ plain)) = length $ filter isControl $ plainFrames plain countControls OutHandshake{} = 0+countControls (OutPathProbe _ frames) = length $ filter isControl frames  isControl :: Frame -> Bool isControl Padding{} = False

@@ -321,25 +321,19 @@                 _ -> sendCCVNError      setParams params = do-        when (isClient conn) $ do-            is0RTT <- isConnection0RTTReady conn-            when is0RTT $ do-                storedParams <- getPeerParameters conn-                let storedMaxDatagram = maxDatagramFrameSize storedParams-                    newMaxDatagram = maxDatagramFrameSize params-                when (storedMaxDatagram > 0 && newMaxDatagram < storedMaxDatagram) $-                    E.throwIO WrongDatagramSizeParameter-                -- RFC 9000 Sec 7.4.1: "If 0-RTT data is accepted by the-                -- server, the server MUST NOT reduce any limits".  The limits-                -- only ever rise here, so one lowered all the same was kept-                -- at the old value, and the server closed the connection over-                -- what it had itself allowed before.-                minfo <- TLS.contextGetInformation ctx-                let accepted = (minfo >>= TLS.infoTLS13HandshakeMode) == Just TLS.RTT0-                when (accepted && lowered storedParams params) $-                    E.throwIO Wrong0RTTLimitParameter-+        -- Also without 0-RTT sent: the limits remembered for it were set+        -- all the same, and tls may not send it, e.g. with a ticket expired.+        rejected <- if isClient conn then check0RTT params else return False         setPeerParameters conn params+        -- RFC 9001 Sec 4.6.2: a client whose 0-RTT is rejected resets what+        -- it set up for it.  What it sent is resent as 1-RTT; the limits it+        -- remembered go, lower or not, for those the server gives now.+        -- Nothing has raised them before these parameters.+        when rejected $ do+            resetTxMaxData conn $ initialMaxData params+            resetTxMaxStreams conn $ initialMaxStreamsBidi params+            resetTxUniMaxStreams conn $ initialMaxStreamsUni params+            resetTxStreamLimits conn params         case statelessResetToken params of             Nothing -> return ()             Just srt -> setPeerStatelessResetToken conn srt@@ -350,6 +344,23 @@         setMaxAckDaley (connLDCC conn) $ milliToMicro $ maxAckDelay params         setTxMaxStreams conn $ initialMaxStreamsBidi params         setTxUniMaxStreams conn $ initialMaxStreamsUni params++    -- True unless 0-RTT was accepted.+    check0RTT params = do+        minfo <- TLS.contextGetInformation ctx+        let accepted = (minfo >>= TLS.infoTLS13HandshakeMode) == Just TLS.RTT0+        when accepted $ do+            storedParams <- getPeerParameters conn+            -- RFC 9221 Sec 3, for 0-RTT accepted only.+            let storedMaxDatagram = maxDatagramFrameSize storedParams+                newMaxDatagram = maxDatagramFrameSize params+            when (storedMaxDatagram > 0 && newMaxDatagram < storedMaxDatagram) $+                E.throwIO WrongDatagramSizeParameter+            -- RFC 9000 Sec 7.4.1: "If 0-RTT data is accepted by the+            -- server, the server MUST NOT reduce any limits".+            when (lowered storedParams params) $+                E.throwIO Wrong0RTTLimitParameter+        return $ not accepted      lowered old new =         or

@@ -45,7 +45,7 @@ decodePacket bs checkQuicBit = E.handle handler $ withReadBuffer bs $ \rbuf -> do     save rbuf     proFlags <- Flags <$> read8 rbuf-    if checkQuicBit && not (isQuic proFlags)+    if checkQuicBit && not (isQuic proFlags) && not isVN         then             return (PacketIB BrokenPacket len, "")         else do@@ -87,6 +87,9 @@                     return $ PacketIC crypt HandshakeLevel siz     handler BufferOverrun = return (PacketIB BrokenPacket len, "")     len = BS.length bs+    -- RFC 9000 Sec 17.2.1: all but the first bit of a Version Negotiation+    -- packet are arbitrary, so it has no QUIC bit to check.+    isVN = isLong (BS.head bs) && BS.take 4 (BS.drop 1 bs) == "\0\0\0\0"  makeShortCrypt :: ByteString -> ReadBuffer -> IO Crypt makeShortCrypt bs rbuf = do

@@ -183,8 +183,8 @@     case ftyp :: FrameType of         0x00 -> decodePadding rbuf         0x01 -> return Ping-        0x02 -> decodeAck rbuf-        -- 0x03 -> Ack with ECN Counts+        0x02 -> decodeAck rbuf False+        0x03 -> decodeAck rbuf True         0x04 -> decodeResetStream rbuf         0x05 -> decodeStopSending rbuf         0x06 -> decodeCrypto rbuf@@ -264,13 +264,16 @@     cdata <- extractByteString rbuf len     return $ CryptoF off cdata -decodeAck :: ReadBuffer -> IO Frame-decodeAck rbuf = do+-- | ACK, or ACK with ECN counts (type 0x03).  The counts are skipped:+--   no packet is sent ECN-capable, so there is nothing to validate.+decodeAck :: ReadBuffer -> Bool -> IO Frame+decodeAck rbuf ecn = do     largest <- fromIntegral <$> decodeInt' rbuf     delay <- decodeDelay rbuf     count <- fromIntegral <$> decodeInt' rbuf     range1 <- fromIntegral <$> decodeInt' rbuf     ranges <- getRanges count id+    when ecn $ replicateM_ 3 $ void $ decodeInt' rbuf     return $ Ack (AckInfo largest range1 ranges) delay   where     getRanges 0 build = return $ build []@@ -384,7 +387,8 @@  decodeDatagram :: ReadBuffer -> Bool -> IO Frame decodeDatagram rbuf hasLen = do-    len <- if hasLen-             then fromIntegral <$> decodeInt' rbuf-             else remainingSize rbuf+    len <-+        if hasLen+            then fromIntegral <$> decodeInt' rbuf+            else remainingSize rbuf     Datagram hasLen <$> extractByteString rbuf len

@@ -316,7 +316,10 @@ checkMigration :: Connection -> CID -> SockAddr -> Bool -> IO () checkMigration conn dCID peersa cidChanged = do     mPathInfo <- findPathInfo conn peersa+    current <- peerSockAddr <$> getPathInfo conn     case mPathInfo of+        -- The previous path: the peer is still there.+        Just _ | peersa /= current -> abandonMigration conn         Just _ -> return ()         Nothing -> do             -- Claimed before the thread rather than inside it, so that a@@ -350,6 +353,10 @@     pathInfo <- newPathInfo peersa     -- assumed that this PathInfo is not stored in PeerInfo     addPathInfo conn pathInfo+    -- RFC 9000 Sec 9.3.3: a challenge on the old path too.  A peer still+    -- there answers from it and so ends a spurious migration at once.+    oldChallenge <- newPathData+    putOutput conn $ OutPathProbe oldPathInfo [PathChallenge oldChallenge]     ok <- validatePath conn pathInfo mcidinfo     -- RFC 9000 Sec 9.3.2: back to the last validated address.  The one     -- that failed is forgotten, so that a packet from it starts afresh.@@ -606,6 +613,9 @@ processFrame conn lvl (NewToken token) = do     when (isServer conn || lvl /= RTT1Level) $         closeConnection conn ProtocolViolation "NEW_TOKEN for server or in 1-RTT"+    -- RFC 9000 Sec 19.7: an empty token is a FRAME_ENCODING_ERROR.+    when (BS.null token) $+        closeConnection conn FrameEncodingError "empty NEW_TOKEN"     when (isClient conn) $ setNewToken conn token processFrame conn RTT0Level (StreamF sid off (dat : _) fin) = do     when (off == 0) $ updatePeerStreamId conn sid

@@ -26,6 +26,7 @@     -- Persistent     findDuration,     getPTO,+    getPtoTimeAndSpace,     -- Release     releaseByRetry,     releaseOldest,@@ -45,6 +46,8 @@     fixSentPacket,     LDCC,     newLDCC,+    lostCandidates,+    SentPackets (..),     qlogSent, ) where 

@@ -136,14 +136,18 @@  releaseLostCandidates     :: LDCC -> EncryptionLevel -> (SentPacket -> Bool) -> IO (Seq SentPacket)-releaseLostCandidates ldcc@LDCC{..} lvl predicate = do-    packets <- atomically $ do-        SentPackets db <- readTVar lostCandidates-        let (pkts, db') = Seq.partition predicate db-        writeTVar lostCandidates $ SentPackets db'-        return pkts-    removePacketNumbers ldcc lvl packets-    return packets+releaseLostCandidates ldcc@LDCC{..} lvl predicate+    -- Lost candidates are 1-RTT packets; an ACK in another space+    -- shares their packet numbers but does not acknowledge them.+    | lvl /= RTT1Level = return Seq.empty+    | otherwise = do+        packets <- atomically $ do+            SentPackets db <- readTVar lostCandidates+            let (pkts, db') = Seq.partition predicate db+            writeTVar lostCandidates $ SentPackets db'+            return pkts+        removePacketNumbers ldcc lvl packets+        return packets  onPacketsAcked :: LDCC -> Seq SentPacket -> IO () onPacketsAcked ldcc@LDCC{..} ackedPackets = metricsUpdated ldcc $ do

@@ -64,7 +64,7 @@                     return Nothing                 else do                     rtt <- readIORef recoveryRTT-                    lvl <- getEncryptionLevel ldcc+                    lvl <- antiDeadlockLevel ldcc                     let pto = backOff (calcPTO rtt $ Just lvl) (ptoCount rtt)                     ptoTime <- getFutureTimeMicrosecond pto                     return $ Just (ptoTime, lvl)@@ -73,24 +73,31 @@             let lvls                     | completed = [InitialLevel, HandshakeLevel, RTT1Level]                     | otherwise = [InitialLevel, HandshakeLevel]-            loop lvls+            loop lvls Nothing   where-    loop :: [EncryptionLevel] -> IO (Maybe (TimeMicrosecond, EncryptionLevel))-    loop [] = return Nothing-    loop (l : ls) = do+    -- RFC 9002 A.8: the space whose PTO expires first, not the first+    -- space with packets in flight.+    loop+        :: [EncryptionLevel]+        -> Maybe (TimeMicrosecond, EncryptionLevel)+        -> IO (Maybe (TimeMicrosecond, EncryptionLevel))+    loop [] r = return r+    loop (l : ls) r = do         notInFlight <- noInFlightPacket ldcc l         if notInFlight-            then loop ls+            then loop ls r             else do                 LossDetection{..} <- readIORef (lossDetection ! l)                 if timeOfLastAckElicitingPacket == timeMicrosecond0-                    then loop ls+                    then loop ls r                     else do                         rtt <- readIORef recoveryRTT                         let pto0 = backOff (calcPTO rtt $ Just l) (ptoCount rtt)                             pto = max pto0 kGranularity                             ptoTime = timeOfLastAckElicitingPacket `addMicroseconds` pto-                        return $ Just (ptoTime, l)+                        case r of+                            Just (t0, _) | t0 <= ptoTime -> loop ls r+                            _ -> loop ls $ Just (ptoTime, l)  ---------------------------------------------------------------- @@ -235,8 +242,8 @@                         -- to earn more anti-amplification credit,                         -- a Handshake packet proves address ownership.                         validated <- peerCompletedAddressValidation ldcc-                        when validated $ qlogDebug ldcc $ Debug "onLossDetectionTimeout: RTT1"-                        lvl' <- getEncryptionLevel ldcc -- fixme+                        when validated $ qlogDebug ldcc $ Debug "onLossDetectionTimeout: validated"+                        lvl' <- antiDeadlockLevel ldcc                         sendPing ldcc lvl'                  metricsUpdated ldcc $

@@ -6,6 +6,7 @@     mergeLostCandidates,     mergeLostCandidatesAndClear,     peerCompletedAddressValidation,+    antiDeadlockLevel,     countAckEli,     inFlightBytes,     inCongestionRecovery,@@ -77,9 +78,19 @@ -- For servers: assume clients validate the server's address implicitly. peerCompletedAddressValidation ldcc     | isServer ldcc = return True--- For clients: servers complete address validation when a protected--- packet is received.-peerCompletedAddressValidation ldcc = isConnectionEstablished ldcc+-- For clients: a Handshake ACK or the confirmed handshake (RFC 9002 A.8).+peerCompletedAddressValidation ldcc@LDCC{..} = do+    confirmed <- isConnectionEstablished ldcc+    if confirmed+        then return True+        else (>= 0) . largestAckedPacket <$> readIORef (lossDetection ! HandshakeLevel)++-- | The level of an anti-deadlock probe: Handshake if its keys are+-- available, Initial otherwise (RFC 9002 A.8).+antiDeadlockLevel :: LDCC -> IO EncryptionLevel+antiDeadlockLevel ldcc = do+    lvl <- getEncryptionLevel ldcc+    return $ if lvl >= HandshakeLevel then HandshakeLevel else InitialLevel  ---------------------------------------------------------------- 

@@ -11,6 +11,7 @@ import qualified Control.Exception as E import qualified Data.ByteString as BS import Foreign.Ptr (plusPtr)+import qualified Network.Socket as NS  import Network.QUIC.Config import Network.QUIC.Connection@@ -39,9 +40,18 @@ ----------------------------------------------------------------  sendPacket :: Connection -> [SentPacket] -> IO ()-sendPacket _ [] = return ()-sendPacket conn spkts0 = getMaxPacketSize conn >>= go+sendPacket conn = sendPacketTo conn Nothing++-- | Sending to the path in use, or to the one given.+sendPacketTo :: Connection -> Maybe PathInfo -> [SentPacket] -> IO ()+sendPacketTo _ _ [] = return ()+sendPacketTo conn mdst spkts0 = getMaxPacketSize conn >>= go   where+    send pathInfo buf bytes = case mdst of+        Nothing -> connSend conn buf bytes+        Just _ -> do+            (s, _) <- readIORef $ connSocket conn+            void $ NS.sendBufTo s buf bytes $ peerSockAddr pathInfo     SizedBuffer buf0 bufsiz0 = encryptRes conn     ldcc = connLDCC conn     -- RFC 9002 section 7: "packets containing only ACK frames do not count@@ -98,14 +108,14 @@                 when (isJust mx) $ qlogDebug conn $ Debug "probe new"                 (sentPackets, leftsiz) <- buildPackets buf0 bufsiz0 maxSiz spkts0 id                 let bytes = bufsiz0 - leftsiz-                pathInfo <- getPathInfo conn+                pathInfo <- maybe (getPathInfo conn) return mdst                 when (isServer conn) $                     waitAntiAmplificationFree conn pathInfo bytes                 -- If the secret of this level (e.g. HandshakeLevel)                 -- is already dropped, bytes is 0.                 when (bytes > 0) $ do                     now <- getTimeMicrosecond-                    connSend conn buf0 bytes+                    send pathInfo buf0 bytes                     addTxBytes conn bytes                     addPathTxBytes pathInfo bytes                     forM_ sentPackets $ \sentPacket0 -> do@@ -414,6 +424,8 @@     sendCryptoFragments conn lcs     when (any (\(l, _) -> l == HandshakeLevel) lcs) $         discardClientInitialPacketNumberSpace conn+sendOutput conn (OutPathProbe pathInfo frames) =+    construct conn RTT1Level frames False >>= sendPacketTo conn (Just pathInfo) sendOutput conn (OutRetrans (PlainPacket hdr0 plain0)) = do     frames <- adjustForRetransmit conn $ plainFrames plain0     let lvl = levelFromHeader hdr0@@ -449,6 +461,9 @@ -- frames are sent just once."  The peer sends a new PATH_CHALLENGE if -- it needs one.  Resent, a PATH_RESPONSE flood would never leave us. adjustForRetransmit conn (PathResponse{} : xs) = adjustForRetransmit conn xs+-- RFC 9000 Sec 13.3: a new payload each time, so never resent.  Resent, it+-- also went to the path in use, whichever path it was for.+adjustForRetransmit conn (PathChallenge{} : xs) = adjustForRetransmit conn xs adjustForRetransmit conn (x : xs) = do     rs <- adjustForRetransmit conn xs     return (x : rs)@@ -506,13 +521,13 @@  -- | 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-    ]+streamFrameMaxOverhead =+    sum+        [ 1 -- type+        , 8 -- stream ID+        , 8 -- offset+        , 2 -- length+        ]  packFin :: Connection -> Stream -> Bool -> IO Bool packFin _ _ True = return True

@@ -39,6 +39,7 @@     readStreamFlowTx,     addTxStreamData,     setTxMaxStreamData,+    resetTxMaxStreamData,     getRxMaxStreamData,     updateStreamFlowRx, @@ -53,6 +54,7 @@     StreamTable,     emptyStreamTable,     lookupStream,+    tableStreams,     insertStream,     deleteStream,     insertCryptoStreams,

@@ -27,6 +27,7 @@     readStreamFlowTx,     addTxStreamData,     setTxMaxStreamData,+    resetTxMaxStreamData,     --     getRxMaxStreamData,     addRxStreamData,@@ -127,6 +128,12 @@     set flow         | txfLimit flow < n = flow{txfLimit = n}         | otherwise = flow++-- | Setting the limit even lower: only for 0-RTT rejected, when the+--   remembered limit goes (RFC 9001 Sec 4.6.2).+resetTxMaxStreamData :: Stream -> Int -> IO ()+resetTxMaxStreamData Stream{..} n =+    atomically $ modifyTVar' streamFlowTx $ \flow -> flow{txfLimit = n}  ---------------------------------------------------------------- 

@@ -2,6 +2,7 @@     StreamTable,     emptyStreamTable,     lookupStream,+    tableStreams,     insertStream,     deleteStream,     insertCryptoStreams,@@ -27,6 +28,10 @@  lookupStream :: StreamId -> StreamTable -> Maybe Stream lookupStream sid (StreamTable tbl) = Map.lookup sid tbl++-- | The streams in the table, the crypto streams included.+tableStreams :: StreamTable -> [Stream]+tableStreams (StreamTable tbl) = Map.elems tbl  insertStream :: StreamId -> Stream -> StreamTable -> StreamTable insertStream sid strm (StreamTable tbl) = StreamTable $ Map.insert sid strm tbl

@@ -75,6 +75,38 @@             { debugKeyLogger = ccKeyLog             } +-- | The parameters a server accepting 0-RTT must not lower (RFC 9000+--   Sec 7.4.1, and RFC 9221 Sec 3 for max_datagram_frame_size).+zeroRTTLimits :: Parameters -> Parameters+zeroRTTLimits p =+    baseParameters+        { activeConnectionIdLimit = activeConnectionIdLimit p+        , initialMaxData = initialMaxData p+        , initialMaxStreamDataBidiLocal = initialMaxStreamDataBidiLocal p+        , initialMaxStreamDataBidiRemote = initialMaxStreamDataBidiRemote p+        , initialMaxStreamDataUni = initialMaxStreamDataUni p+        , initialMaxStreamsBidi = initialMaxStreamsBidi p+        , initialMaxStreamsUni = initialMaxStreamsUni p+        , maxDatagramFrameSize = maxDatagramFrameSize p+        }++-- | Whether the parameters now keep to those remembered.+keeps0RTTLimits :: Parameters -> Parameters -> Bool+keeps0RTTLimits remembered now =+    and+        [ f now >= f remembered+        | f <-+            [ activeConnectionIdLimit+            , initialMaxData+            , initialMaxStreamDataBidiLocal+            , initialMaxStreamDataBidiRemote+            , initialMaxStreamDataUni+            , initialMaxStreamsBidi+            , initialMaxStreamsUni+            , maxDatagramFrameSize+            ]+        ]+ parametersToExtensionRaw :: Version -> Parameters -> [ExtensionRaw] parametersToExtensionRaw ver params = [ExtensionRaw tpId eParams]   where@@ -105,11 +137,27 @@     sshared =         defaultShared             { sharedCredentials = scCredentials-            , sharedSessionManager = scSessionManager+            , sharedSessionManager = mgr             }+    -- RFC 9000 Sec 7.4.1: what 0-RTT is held to is kept with the session,+    -- and 0-RTT is refused if the server now allows less.+    mgr =+        scSessionManager+            { sessionEstablish = \sid sdata -> do+                remembered <- zeroRTTLimits <$> getParams+                sessionEstablish scSessionManager sid $+                    sdata{sessionAppData = Just $ encodeParameters remembered}+            }+    accept0RTT sdata = do+        ok <- onAccept0RTT scTlsHooks sdata+        now <- getParams+        return $ case sessionAppData sdata >>= decodeParameters of+            Just remembered -> ok && keeps0RTTLimits remembered now+            Nothing -> False     hook =         scTlsHooks-            { onALPNClientSuggest = case scALPN of+            { onAccept0RTT = accept0RTT+            , onALPNClientSuggest = case scALPN of                 Nothing -> onALPNClientSuggest scTlsHooks                 Just io -> Just $ io ver             , onEncryptedExtensionsCreating = \exts0 -> do

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               quic-version:            0.3.20+version:            0.3.21 license:            BSD3 license-file:       LICENSE maintainer:         kazu@iij.ad.jp@@ -127,7 +127,7 @@     build-depends:         base >=4.9 && <5,         array >=0.5 && <0.6,-        async,+        async >=2.2,         base16-bytestring >=1.0 && <1.1,         bytestring >=0.10,         containers,@@ -139,7 +139,7 @@         crypton-x509-validation >=1.9.0 && <1.11,         fast-logger >=3.2.8 && <3.3,         filepath,-        iproute >=1.7.12 && <1.8,+        iproute >=1.7.12 && <1.9,         network >=3.2.12,         network-byte-order >=0.1.7 && <0.2,         network-control >=0.1.5 && <0.2,@@ -148,8 +148,8 @@         serialise,         stm >=2.5 && <2.6,         time-manager >=0.5 && <0.6,-        tls >=2.4.0 && <2.6,-        unix-time >=0.4.12 && <0.6+        tls >=2.5.1 && <2.6,+        unix-time >=0.4.12 && <0.7      if os(linux)         cc-options: -DOS_Linux

@@ -49,10 +49,18 @@         -- "If a client stores the value of the max_datagram_frame_size transport parameter with their 0-RTT state, they MUST validate that the new value of the max_datagram_frame_size transport parameter sent by the server in the handshake is greater than or equal to the stored value; if not, the client MUST terminate the connection with error PROTOCOL_VIOLATION."         it "Client MUST reject 0-RTT downgrade server parameters" $ do             let scInit = sc0 { scMaxDatagramFrameSize = 1024 }-                scDowngrade = sc0 { scMaxDatagramFrameSize = 500 }+                scDowngrade = lowerSentDatagramSize sc0 { scMaxDatagramFrameSize = 1024 }                 cc0RTT = testClientConfig { ccMaxDatagramFrameSize = 1024 }             testDatagram0RTTDowngrade cc0RTT scInit scDowngrade +        -- The check above is for 0-RTT accepted only.  Rejected, the+        -- client takes the value the server gives now (RFC 9001 Sec 4.6.2).+        it "Client takes a lower max_datagram_frame_size when 0-RTT is rejected" $ do+            let scInit = sc0 { scMaxDatagramFrameSize = 1024 }+                scLower = sc0 { scMaxDatagramFrameSize = 500, scUse0RTT = False }+                cc0RTT = testClientConfig { ccMaxDatagramFrameSize = 1024 }+            testDatagram0RTTRejected cc0RTT scInit scLower+         -- "An endpoint MUST NOT send DATAGRAM frames until it has received the max_datagram_frame_size transport parameter with a non-zero value"         it "Endpoint MUST NOT send DATAGRAM if not negotiated" $ do             let scDtgm = sc0 { scMaxDatagramFrameSize = 0 }@@ -88,7 +96,7 @@         -- "When servers decide to accept 0-RTT data, they MUST send a max_datagram_frame_size transport parameter greater than or equal to the value they sent to the client..."         it "Server MUST NOT downgrade max_datagram_frame_size on 0-RTT" $ do             let scInit = sc0 { scMaxDatagramFrameSize = 1024 }-                scDowngrade = sc0 { scMaxDatagramFrameSize = 500 }+                scDowngrade = lowerSentDatagramSize sc0 { scMaxDatagramFrameSize = 1024 }                 cc0RTT = testClientConfig { ccMaxDatagramFrameSize = 1024 }              mvar <- newEmptyMVar@@ -280,6 +288,33 @@         when (handshakeMode info == RTT0) $ do             recv <- recvDatagram conn             recv `shouldBe` "0rtt_client_data"++-- | A server that keeps max_datagram_frame_size and so accepts 0-RTT, but+--   sends a lower one: what the client is to catch (RFC 9221 Sec 3).+lowerSentDatagramSize :: ServerConfig -> ServerConfig+lowerSentDatagramSize sc =+    sc { scHooks = (scHooks sc) { onTransportParametersCreated = \p -> p { maxDatagramFrameSize = 500 } } }++testDatagram0RTTRejected :: ClientConfig -> ServerConfig -> ServerConfig -> IO ()+testDatagram0RTTRejected cc1 scInit scLower = do+    mvar <- newEmptyMVar+    smgr <- newSessionManager+    let scInit' = scInit { scSessionManager = smgr, scUse0RTT = True, scHooks = (scHooks scInit) { onServerReady = putMVar mvar () } }+    res <- E.bracket (forkIO $ S.run scInit' (\c -> waitEstablished c >> threadDelay 100000)) killThread $ \_ -> do+        takeMVar mvar+        C.run cc1 $ \conn -> do+            waitEstablished conn+            threadDelay 50000+            getResumptionInfo conn+    let cc2 = cc1 { ccResumption = res, ccUse0RTT = True }+    mvar2 <- newEmptyMVar+    let scLower' = scLower { scSessionManager = smgr, scHooks = (scHooks scLower) { onServerReady = putMVar mvar2 () } }+    E.bracket (forkIO $ E.handle (\(E.SomeException _) -> return ()) $ S.run scLower' (\c -> waitEstablished c >> threadDelay 2000000)) killThread $ \_ -> do+        takeMVar mvar2+        C.run cc2 (\conn -> do+            waitEstablished conn+            sendDatagram conn (BS.replicate 400 0x41)+            handshakeMode <$> getConnectionInfo conn) `shouldReturn` PreSharedKey  testDatagram0RTTDowngrade :: ClientConfig -> ServerConfig -> ServerConfig -> IO () testDatagram0RTTDowngrade cc1 scInit scDowngrade = do

@@ -1,6 +1,7 @@ module FrameSpec where  import qualified Control.Exception as E+import qualified Data.ByteString as BS import Data.Word import Foreign.Marshal.Alloc import Foreign.Marshal.Utils (fillBytes)@@ -12,6 +13,14 @@  spec :: Spec spec = do+    describe "ACK_ECN" $ do+        it "is decoded as ACK with its ECN counts skipped" $ do+            let ack = Ack (AckInfo 5 2 [(1, 0)]) noDelay+            bs <- encodeFrames [ack, Ping]+            -- Type 0x03, then the three ECN counts after the ranges.+            let (body, ping) = BS.splitAt (BS.length bs - 2) $ BS.drop 1 bs+                ecn = BS.concat [BS.singleton 0x03, body, BS.pack [1, 2, 0x40, 3], ping]+            decodeFramesBS ecn `shouldReturn` Just [ack, Ping]     describe "countZero" $ do         it "counts 0 correctly" $ do             let siz = 512

@@ -101,9 +101,33 @@         it "keeps a resumed connection to the limits the server gives now" $ do             testLoweredLimits testClientConfig sc0 waitS                 `shouldReturn` (PreSharedKey, 3)+        it "drops the remembered limits when 0-RTT is rejected" $ do+            testRejected0RTTLimits testClientConfig sc0 waitS+                `shouldReturn` (PreSharedKey, 3)+        it "drops the remembered limits when no 0-RTT is sent" $ do+            testExpired0RTTLimits testClientConfig sc0 waitS+                `shouldReturn` (FullHandshake, 3)+        it "refuses 0-RTT when the server allows less than it did" $ do+            let lower sc = sc{scParameters = (scParameters sc){initialMaxStreamsBidi = 50}}+            testLowered0RTT testClientConfig sc0{scUse0RTT = True} waitS lower+                `shouldReturn` PreSharedKey         it "refuses 0-RTT accepted with the limits lowered" $ do-            testLowered0RTT testClientConfig sc0{scUse0RTT = True} waitS+            -- Lowered in what is sent only, so that the server accepts.+            let lower sc =+                    sc+                        { scHooks =+                            (scHooks sc)+                                { onTransportParametersCreated = \p -> p{initialMaxStreamsBidi = 50}+                                }+                        }+            testLowered0RTT testClientConfig sc0{scUse0RTT = True} waitS lower                 `shouldThrow` protocolViolation+        it "MUST send FRAME_ENCODING_ERROR on an empty NEW_TOKEN [Transport 19.7]" $ do+            let sc = sc0{scHooks = (scHooks sc0){onPlainCreated = emptyNewToken}}+            E.bracket (forkIO $ S.run sc $ \_ -> threadDelay 2000000) killThread $ \_ -> do+                waitS+                C.run testClientConfig (\_ -> threadDelay 1000000)+                    `shouldThrow` frameEncodingErrorSent         it "sends 0-RTT data without waiting for the handshake" $ do             let sc = sc0{scUse0RTT = True}             test0RTTSendsEarly sc waitS@@ -128,6 +152,13 @@                         te == cryptoError TLS.HandshakeFailure                     | otherwise = False             testHandshake3 cc1 cc2 sc waitS handshakeFailure+        it "reconnects with the version a Version Negotiation offers" $ do+            let cc = testClientConfig{ccVersion = Version2, ccVersions = [Version2, Version1]}+                sc = sc0{scVersions = [Version1]}+            E.bracket (forkIO $ S.run sc $ \_ -> threadDelay 2000000) killThread $ \_ -> do+                waitS+                C.run cc (\conn -> waitEstablished conn >> getVersion conn)+                    `shouldReturn` Version1         it "fails with no version in common" $ do             let cc1 = testClientConfig{ccVersion = Version1, ccVersions = [Version1]}                 cc2 = testClientConfig@@ -412,12 +443,70 @@     sc2 = sc{scParameters = (scParameters sc){initialMaxStreamsBidi = 3}}     serv conn = forever $ void $ acceptStream conn --- | As above, but with 0-RTT, which the server accepts with fifty streams---   where it gave a hundred before: RFC 9000 Sec 7.4.1 says it MUST NOT.---   The client opens one stream, within either, so that it is the client---   that notices.-testLowered0RTT :: ClientConfig -> ServerConfig -> IO () -> IO ()-testLowered0RTT cc1 sc waitS = do+-- | As above, but the client sends 0-RTT, which the server rejects.  RFC+--   9001 Sec 4.6.2: the client then resets what it set up for 0-RTT.  It+--   kept the hundred streams it remembered and the server closed it with+--   STREAM_LIMIT_ERROR.+testRejected0RTTLimits+    :: ClientConfig -> ServerConfig -> IO () -> IO (HandshakeMode13, Int)+testRejected0RTTLimits cc1 sc waitS = do+    res <- resumeFrom cc1 sc{scUse0RTT = True} waitS+    threadDelay 100000+    E.bracket (forkIO $ S.run sc2 serv) killThread $ \_ -> do+        waitS+        C.run cc1{ccResumption = res, ccUse0RTT = True} $ \conn -> do+            waitEstablished conn+            opened <- newIORef (0 :: Int)+            _ <- Timeout.timeout 1500000 $ forever $ do+                s <- stream conn+                sendStream s "x"+                atomicModifyIORef' opened $ \x -> (x + 1, ())+            (,) <$> (handshakeMode <$> getConnectionInfo conn) <*> readIORef opened+  where+    sc2 =+        sc+            { scUse0RTT = False+            , scParameters = (scParameters sc){initialMaxStreamsBidi = 3}+            }+    serv conn = forever $ void $ acceptStream conn++-- | As above, but the ticket has expired, so tls sends no 0-RTT while the+--   client has set the limits it remembered for 0-RTT all the same.+testExpired0RTTLimits+    :: ClientConfig -> ServerConfig -> IO () -> IO (HandshakeMode13, Int)+testExpired0RTTLimits cc1 sc waitS = do+    res <- resumeFrom cc1 sc{scUse0RTT = True, scTicketLifetime = 1} waitS+    threadDelay 2000000+    E.bracket (forkIO $ S.run sc2 serv) killThread $ \_ -> do+        waitS+        C.run cc1{ccResumption = res, ccUse0RTT = True} $ \conn -> do+            waitEstablished conn+            opened <- newIORef (0 :: Int)+            _ <- Timeout.timeout 1500000 $ forever $ do+                s <- stream conn+                sendStream s "x"+                atomicModifyIORef' opened $ \x -> (x + 1, ())+            (,) <$> (handshakeMode <$> getConnectionInfo conn) <*> readIORef opened+  where+    sc2 =+        sc+            { scUse0RTT = True+            , scParameters = (scParameters sc){initialMaxStreamsBidi = 3}+            }+    serv conn = forever $ void $ acceptStream conn++-- | As above, but with 0-RTT and fifty streams where the server gave a+--   hundred before, lowered as 'lower' says.  RFC 9000 Sec 7.4.1: a+--   server that lowers them MUST NOT accept 0-RTT, and a client MAY close+--   on one that does.  The client opens one stream, within either.+--   Answers how the connection went.+testLowered0RTT+    :: ClientConfig+    -> ServerConfig+    -> IO ()+    -> (ServerConfig -> ServerConfig)+    -> IO HandshakeMode13+testLowered0RTT cc1 sc waitS lower = do     res <- resumeFrom cc1 sc waitS     threadDelay 100000     E.bracket (forkIO $ S.run sc2 serv) killThread $ \_ -> do@@ -426,9 +515,21 @@             s <- stream conn             sendStream s "x"             threadDelay 1000000+            handshakeMode <$> getConnectionInfo conn   where-    sc2 = sc{scParameters = (scParameters sc){initialMaxStreamsBidi = 50}}+    -- The hundred streams 'resumeFrom' allows, lowered.+    sc2 = lower sc{scParameters = (scParameters sc){initialMaxStreamsBidi = 100}}     serv conn = forever $ void $ acceptStream conn++emptyNewToken :: EncryptionLevel -> Plain -> Plain+emptyNewToken _ plain = plain{plainFrames = map empty $ plainFrames plain}+  where+    empty (NewToken _) = NewToken ""+    empty f = f++frameEncodingErrorSent :: QUICException -> Bool+frameEncodingErrorSent (TransportErrorIsSent FrameEncodingError _) = True+frameEncodingErrorSent _ = False  protocolViolation :: QUICException -> Bool protocolViolation (TransportErrorIsSent ProtocolViolation _) = True

@@ -17,6 +17,8 @@ import GHC.Conc (getUncaughtExceptionHandler, setUncaughtExceptionHandler) import qualified Network.Socket as NS import qualified Network.Socket.ByteString as NSB+import System.Directory (listDirectory)+import System.FilePath ((</>)) import qualified System.Timeout as Timeout import Test.Hspec @@ -59,6 +61,9 @@             testInjected cc sc waitS $ \dcid scid ->                 encodeRetryPacket $                     RetryPacket Version2 dcid (toCID "forged") "token" (Left scid)+    describe "a stateless reset to the client" $+        it "ends the connection with ConnectionIsReset" $+            testStatelessResetReceived cc sc waitS     describe "max_udp_payload_size" $ do         it "bounds the datagrams each side sends" $ do             let small p = p{maxUdpPayloadSize = 1200}@@ -180,7 +185,14 @@                         ]         it "follows a client that rebinds" $ testRebindPath cc sc waitS         it "goes back when the new one is not validated" $-            testSpuriousMigration cc sc waitS+            testSpuriousMigration cc sc waitS 1500000+        -- RFC 9000 Sec 9.3.3.  The new path answers nothing, so a+        -- PATH_CHALLENGE in the client's qlog came on the old one.+        it "challenges the old path too" $+            withTempDir "quic-old-path-qlog" $ \dir -> do+                testSpuriousMigration cc{ccQLog = Just dir} sc waitS 1500000+                logs <- listDirectory dir >>= mapM (BS.readFile . (dir </>))+                any ("path_challenge" `BS.isInfixOf`) logs `shouldBe` True     describe "a stateless reset" $ do         it "is smaller than the packet it answers" $ do             withAsync (run sc $ \_ -> return ()) $ \_ -> do@@ -520,12 +532,12 @@             _ <- recvStream strm 1             closeStream strm         let departed = IntMap.size <$> readTVarIO (departedStreams conn)-            wait :: Int -> IO Int-            wait 0 = departed-            wait k = do+            settle :: Int -> IO Int+            settle 0 = departed+            settle k = do                 d <- departed-                if d == 0 then return 0 else threadDelay 10000 >> wait (k - 1)-        wait 300 >>= putMVar left+                if d == 0 then return 0 else threadDelay 10000 >> settle (k - 1)+        settle 300 >>= putMVar left  -- | As above, but the client does not hear the STOP_SENDING.  The streams --   it leaves unfinished are not given back to its limit, so the server@@ -590,12 +602,12 @@             _ <- recvStream strm 1             closeStream strm         let departed = IntMap.size <$> readTVarIO (departedStreams conn)-            wait :: Int -> IO Int-            wait 0 = departed-            wait k = do+            settle :: Int -> IO Int+            settle 0 = departed+            settle k = do                 d <- departed-                if d == 0 then return 0 else threadDelay 10000 >> wait (k - 1)-        wait 300 >>= putMVar left+                if d == 0 then return 0 else threadDelay 10000 >> settle (k - 1)+        settle 300 >>= putMVar left  -- | The server closes the first unidirectional stream and keeps the rest. -- The client may then have initial_max_streams_uni plus one.  The limit was@@ -756,6 +768,32 @@         assertEndOfStream strm         putMVar mvar () +-- | A stateless reset with the token the server gave.  The client's reader+--   threw 'ConnectionIsReset' to the connection's main thread; it now asks+--   the protocol threads to end with it.+testStatelessResetReceived :: C.ClientConfig -> ServerConfig -> IO () -> IO ()+testStatelessResetReceived cc sc waitS = do+    trigger <- newEmptyMVar+    tokenVar <- newEmptyMVar+    let mk _ _ = readMVar tokenVar >>= makeStatelessReset 64+    withPipe (InjectToClient trigger mk) $+        withAsync (run sc $ \_ -> threadDelay 5_000_000) $ \_ -> do+            waitS+            noUncaught $+                C.run cc (go trigger tokenVar) `shouldThrow` isReset+  where+    go trigger tokenVar conn = do+        waitEstablished conn+        mtoken <- statelessResetToken <$> getPeerParameters conn+        case mtoken of+            Nothing -> expectationFailure "no stateless_reset_token"+            Just token -> do+                putMVar tokenVar token+                putMVar trigger ()+                threadDelay 3_000_000+    isReset ConnectionIsReset = True+    isReset _ = False+ -- | The server asks the client to stop sending on @n@ streams at once. testStopMany :: C.ClientConfig -> ServerConfig -> IO () -> Int -> IO () testStopMany cc sc waitS n = do@@ -1420,7 +1458,7 @@             C.run cc $ \conn -> do                 strm <- stream conn                 echo strm "ping1" `shouldReturn` Just "ping1"-                before <- takeMVar paths+                original <- takeMVar paths                 ver <- getVersion conn                 dcid <- getPeerCID conn                 addr : _ <-@@ -1432,7 +1470,7 @@                     void $ NSB.sendTo s (forge ver dcid) $ NS.addrAddress addr                 threadDelay 300000                 echo strm "ping2" `shouldReturn` Just "ping2"-                takeMVar paths `shouldReturn` before+                takeMVar paths `shouldReturn` original  -- | A client that moves to a new port is still followed, now that the move --   is taken from decrypted packets.@@ -1446,25 +1484,27 @@         C.run cc' $ \conn -> do             strm <- stream conn             echo strm "ping1" `shouldReturn` Just "ping1"-            before <- takeMVar paths+            original <- takeMVar paths             void $ controlConnection conn NATRebinding             -- The first echo may still go out on the old path, while the             -- new one is being validated.-            let wait (0 :: Int) = expectationFailure "the server never moved"-                wait n = do+            let untilMoved (0 :: Int) = expectationFailure "the server never moved"+                untilMoved n = do                     echo strm "ping" `shouldReturn` Just "ping"                     p <- takeMVar paths-                    when (p == before) $ do+                    when (p == original) $ do                         threadDelay 100000-                        wait (n - 1)-            wait 20+                        untilMoved (n - 1)+            untilMoved 20  -- | RFC 9000 Sec 9.3.2: a packet of the client's, forwarded from another --   address, moves the server there, and the validation of that address --   fails.  The server waited for the PATH_RESPONSE for ever and went on---   sending to the address that never answered.-testSpuriousMigration :: C.ClientConfig -> ServerConfig -> IO () -> IO ()-testSpuriousMigration cc sc waitS = do+--   sending to the address that never answered.  Then it waited for the+--   validation to time out (about 3 s), though the client's next packets+--   came from the old address; they now send it back at once.+testSpuriousMigration :: C.ClientConfig -> ServerConfig -> IO () -> Int -> IO ()+testSpuriousMigration cc sc waitS within = do     paths <- newEmptyMVar     trigger <- newEmptyMVar     withPipe (ForwardAside trigger) $@@ -1473,13 +1513,13 @@             C.run cc $ \conn -> do                 strm <- stream conn                 echo strm "ping1" `shouldReturn` Just "ping1"-                before <- takeMVar paths+                original <- takeMVar paths                 putMVar trigger ()                 -- Answered on the spurious path, and so not heard until-                -- the server has given up on it.+                -- the server is back on the old one.                 sendStream strm "ping2"-                Timeout.timeout 8000000 (recvStream strm 1024)+                Timeout.timeout within (recvStream strm 1024)                     `shouldReturn` Just "ping2"                 _ <- takeMVar paths                 echo strm "ping3" `shouldReturn` Just "ping3"-                takeMVar paths `shouldReturn` before+                takeMVar paths `shouldReturn` original

@@ -1,10 +1,11 @@ module MigrationSpec where  import Control.Concurrent-import Control.Concurrent.Async (mapConcurrently)+import Control.Concurrent.Async (mapConcurrently, wait, withAsync) import Control.Concurrent.STM import Control.Monad (void) import Network.Socket (connect, getSocketName, withFdSocket)+import qualified System.Timeout as T import Test.Hspec  import Network.QUIC.Internal@@ -22,6 +23,25 @@     -- -- which asks no spoofing of it -- is therefore unknown on every     -- packet it sends.  One of those packets is a migration; the rest are     -- nothing.  See #167.+    -- RFC 9000 Sec 8.2.1: a challenge lost was not sent again, so one+    -- loss failed the validation.  It is sent again, each time with a new+    -- payload, and a late answer to an earlier one still counts.+    describe "validatePath" $+        it "sends the challenge again with a new payload until answered" $ do+            (_, serverConn) <- makeConnections serverConf Version1+            pathInfo <- getPathInfo serverConn >>= newPathInfo . peerSockAddr+            withAsync (validatePath serverConn pathInfo Nothing) $ \validation -> do+                let challenge = do+                        out <- T.timeout 3000000 $ atomically $ takeOutputSTM serverConn+                        case out of+                            Just (OutPathProbe _ [PathChallenge pdat]) -> return pdat+                            _ -> fail "no challenge"+                p1 <- challenge+                p2 <- challenge+                p2 `shouldNotBe` p1+                checkResponse serverConn p1+                wait validation `shouldReturn` True+     describe "claimMigration" $ do         it "gives the migration to one caller and refuses the rest" $ do             (_, serverConn) <- makeConnections serverConf Version1

@@ -12,14 +12,21 @@ import Foreign.Ptr (plusPtr) import Test.Hspec -import Network.QUIC.Internal import Control.Concurrent.STM+import Network.QUIC.Internal  import Config  spec :: Spec spec = do     serverConf <- runIO makeTestServerConfig+    describe "Version Negotiation" $ do+        it "is decoded without its QUIC bit even when the bit is checked" $ do+            let vn = VersionNegotiationPacket (toCID "dcid") (toCID "scid") [Version1]+            bs0 <- encodeVersionNegotiationPacket vn+            let bs = BS.cons (BS.head bs0 .&. 0xbf) $ BS.tail bs0+            pkts <- decodePackets bs True+            [p | PacketIV p <- pkts] `shouldBe` [vn]     describe "test vector" $ do         it "describes example of Client Initial version 1" $ do             conns <- makeConnections serverConf Version1

@@ -2,6 +2,7 @@  module RecoverySpec where +import Control.Concurrent.STM import Data.ByteString.Short () import qualified Data.Sequence as Seq import Data.UnixTime@@ -11,6 +12,45 @@  spec :: Spec spec = do+    describe "lost candidates" $ do+        it "are released only by an ACK in the 1-RTT space" $ do+            cs <- newConnState Client+            ldcc <- newLDCC cs (\_ -> return ()) (\_ -> return ())+            let lost = (sp 1 True $ UnixTime 0 0){spEncryptionLevel = RTT1Level}+                candidates = (\(SentPackets db) -> db) <$> readTVarIO (lostCandidates ldcc)+            atomically $ writeTVar (lostCandidates ldcc) $ SentPackets $ Seq.singleton lost+            -- A Handshake ACK for the same packet number is not for it.+            onAckReceived ldcc HandshakeLevel (AckInfo 1 0 []) 0+            candidates `shouldReturn` Seq.singleton lost+            onAckReceived ldcc RTT1Level (AckInfo 1 0 []) 0+            candidates `shouldReturn` Seq.empty+    describe "PTO" $ do+        it "is armed for the space that expires first" $ do+            cs <- newConnState Server+            ldcc <- newLDCC cs (\_ -> return ()) (\_ -> return ())+            -- Far in the future so that the timer does not fire.+            now <- getTimeMicrosecond+            let at lvl pn s =+                    (sp pn True $ now `addMicroseconds` Microseconds (s * 1000000))+                        { spEncryptionLevel = lvl+                        , spSentBytes = 1200+                        , spPlainPacket = PlainPacket (Short $ toCID "") (Plain (Flags 0) pn [Ping] 0)+                        }+            onPacketSent ldcc $ at HandshakeLevel 0 100+            onPacketSent ldcc $ at InitialLevel 1 200+            fmap snd <$> getPtoTimeAndSpace ldcc `shouldReturn` Just HandshakeLevel+        it "sends an anti-deadlock probe at the Handshake level once it has the keys" $ do+            cs <- newConnState Client+            ldcc <- newLDCC cs (\_ -> return ()) (\_ -> return ())+            fmap snd <$> getPtoTimeAndSpace ldcc `shouldReturn` Just InitialLevel+            atomically $ writeTVar (encryptionLevel cs) RTT1Level+            fmap snd <$> getPtoTimeAndSpace ldcc `shouldReturn` Just HandshakeLevel+        it "needs no anti-deadlock probe once a Handshake ACK arrives" $ do+            cs <- newConnState Client+            ldcc <- newLDCC cs (\_ -> return ()) (\_ -> return ())+            atomically $ writeTVar (encryptionLevel cs) RTT1Level+            onAckReceived ldcc HandshakeLevel (AckInfo 0 0 []) 0+            getPtoTimeAndSpace ldcc `shouldReturn` Nothing     describe "persistent congestion" $ do         it "does not find a pair" $ do             findDuration (Seq.fromList [sp0]) 0 `shouldBe` Nothing