quic 0.3.21 → 0.3.22

raw patch · 22 files changed

+380/−110 lines, 22 filesdep ~crypto-tokendep ~network-controlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: crypto-token, network-control

API changes (from Hackage documentation)

Files

• ChangeLog.md +20/−0
• Network/QUIC/Closer.hs +1/−1
• Network/QUIC/Connection/Migration.hs +53/−1
• Network/QUIC/Connection/Misc.hs +7/−0
• Network/QUIC/Connection/Queue.hs +3/−0
• Network/QUIC/Connection/StreamTable.hs +12/−3
• Network/QUIC/Connection/Types.hs +18/−3
• Network/QUIC/IO.hs +16/−10
• Network/QUIC/Info.hs +1/−1
• Network/QUIC/Internal.hs +2/−0
• Network/QUIC/Receiver.hs +13/−26
• Network/QUIC/Recovery.hs +2/−0
• Network/QUIC/Sender.hs +49/−39
• Network/QUIC/Server/Reader.hs +4/−7
• Network/QUIC/Server/Run.hs +2/−2
• Network/QUIC/Stream/Misc.hs +4/−4
• Network/QUIC/Stream/Types.hs +4/−1
• Network/QUIC/Types/Packet.hs +3/−3
• quic.cabal +3/−2
• test/Config.hs +24/−4
• test/IOSpec.hs +45/−0
• test/MigrationSpec.hs +94/−3

@@ -1,5 +1,25 @@ # ChangeLog +## 0.3.22++Requires crypto-token 0.2.1.  The public API is unchanged.  In+`Network.QUIC.Internal`, `TxStreamData` carries its offset, `OutPathProbe`+carries a CID, `PathInfo` has `pathSocket`, `rpPeerAddr` carries the+socket, and `Connection` has `peerLimitsReset`.++* Send each path's packets on the socket its packets came in on+  [#217](https://github.com/kazu-yamamoto/quic/pull/217)+* Give queued stream data its offset when it is queued+  [#218](https://github.com/kazu-yamamoto/quic/pull/218)+* Keep a CID for each path while a migration is validated+  [#219](https://github.com/kazu-yamamoto/quic/pull/219)+* Leave the PTO probe for the path in use+  [#220](https://github.com/kazu-yamamoto/quic/pull/220)+* Hold a stream added during a reset of the limits to the new ones+  [#221](https://github.com/kazu-yamamoto/quic/pull/221)+* Require crypto-token 0.2.1+  [#222](https://github.com/kazu-yamamoto/quic/pull/222)+ ## 0.3.21  Requires tls 2.5.1 and async 2.2, and allows iproute 1.8 and unix-time

@@ -76,7 +76,7 @@  closure'' :: Connection -> LDCC -> Frame -> IO () closure'' conn ldcc frame = do-    sock <- getSocket conn+    sock <- getPathSocket conn     peersa <- peerSockAddr <$> getPathInfo conn     connected <- getSockConnected conn     -- send

@@ -26,6 +26,7 @@     abandonMigration,     checkResponse,     validatePath,+    validateMigration,     getMyRetirePriorTo,     setMyRetirePriorTo,     getPeerRetirePriorTo,@@ -39,6 +40,7 @@  import Network.QUIC.Connection.Misc import Network.QUIC.Connection.Queue+import Network.QUIC.Connection.Timeout (timeout) import Network.QUIC.Connection.Types import Network.QUIC.Connector import Network.QUIC.Imports@@ -358,6 +360,20 @@     setChallenges conn pathInfo pdat     putOutput conn $ challengeOutput conn pathInfo [PathChallenge pdat]     waitResponse conn pathInfo+validatePath conn pathInfo (Just cidInfo)+    -- RFC 9000 Sec 9.5: the CID of the old path is kept for it until the+    -- new one is validated, so that no CID is sent on both.+    | isServer conn = do+        pdat <- newPathData+        setChallenges conn pathInfo pdat+        putOutput conn $ challengeOutput conn pathInfo [PathChallenge pdat]+        ok <- waitResponse conn pathInfo+        when ok $ retire $ cidInfoSeq cidInfo+        return ok+  where+    retire n = do+        retirePeerCID conn n+        putOutput conn $ OutControl RTT1Level [RetireConnectionID n] validatePath conn pathInfo (Just cidInfo) = do     pdat <- newPathData     setChallenges conn pathInfo pdat@@ -379,12 +395,48 @@     putOutput conn $ challengeOutput conn pathInfo frames     waitResponse conn pathInfo +-- | A server's part in a client's move to the path given, whether the+--   path is validated.  Both paths are challenged (RFC 9000 Sec 9.3.3).  If+--   the client changed its CID, the new path gets a new CID of the client's+--   and the old path keeps its own (Sec 9.5); the one of the path given up+--   is retired.+validateMigration :: Connection -> PathInfo -> Bool -> IO Bool+validateMigration conn pathInfo cidChanged = do+    mold <-+        if cidChanged+            then timeout (Microseconds 100000) "validateMigration" $ waitPeerCID conn+            else return Nothing -- PathChallenge only, no RetireConnectionID+    oldPathInfo <- getPathInfo conn+    -- assumed that this PathInfo is not stored in PeerInfo+    addPathInfo conn pathInfo+    -- A peer still on the old path answers from it and so ends a spurious+    -- migration at once (Sec 9.3.2).+    oldChallenge <- newPathData+    putOutput conn $+        OutPathProbe oldPathInfo (cidInfoCID <$> mold) [PathChallenge oldChallenge]+    ok <- validatePath conn pathInfo mold+    unless ok $ do+        -- Sec 9.3.2: back to the last validated address.  The one that+        -- failed is forgotten, so that a packet from it starts afresh.+        restorePathInfo conn oldPathInfo+        case mold of+            Nothing -> return ()+            Just old -> do+                spurious <- atomically $ do+                    db <- readTVar $ peerCIDDB conn+                    setPeerCID conn old (triggeredByMe db)+                    return $ usedCIDInfo db+                let n = cidInfoSeq spurious+                retirePeerCID conn n+                putOutput conn $ OutControl RTT1Level [RetireConnectionID n]+    return ok+ -- | 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+    | isServer conn = OutPathProbe pathInfo Nothing frames     | otherwise = OutControl RTT1Level frames  setChallenges :: Connection -> PathInfo -> PathData -> IO ()

@@ -8,6 +8,7 @@     getVersion,     getOriginalVersion,     getSocket,+    getPathSocket,     setSocket,     getSocketRetire,     swapSocket,@@ -86,6 +87,12 @@  getSocket :: Connection -> IO Socket getSocket Connection{..} = fst <$> readIORef connSocket++-- | The socket the path in use sends on: a server's path has its own.+getPathSocket :: Connection -> IO Socket+getPathSocket conn = do+    PeerInfo pinfo _ <- readIORef $ peerInfo conn+    maybe (getSocket conn) return $ pathSocket pinfo  -- | Swapping the socket alone, leaving the reader of the old one to be --   retired through the variable they share.

@@ -98,6 +98,9 @@ tryPeekSendStreamQ :: Connection -> IO (Maybe TxStreamData) tryPeekSendStreamQ conn = atomically $ tryPeekTQueue $ sharedSendStreamQ $ shared conn +putSendStreamQSTM :: Connection -> TxStreamData -> STM ()+putSendStreamQSTM conn = writeTQueue (sharedSendStreamQ $ shared conn)+ putSendStreamQ :: Connection -> TxStreamData -> IO () putSendStreamQ conn out = atomically $ writeTQueue (sharedSendStreamQ $ shared conn) out 

@@ -61,6 +61,9 @@  addStream :: Connection -> StreamId -> IO Stream addStream conn@Connection{..} sid = do+    -- Read before the parameters: if a reset runs after the read, the+    -- stream is made again from the parameters it set.+    resets <- readTVarIO peerLimitsReset     strm <-         if isClient conn             then do@@ -75,14 +78,20 @@                     serverParams = getMyParameters conn                     rxLim = serverInitial sid serverParams                 newStream conn sid txLim rxLim-    atomically $ modifyTVar' streamTable $ insertStream sid strm-    return strm+    added <- atomically $ do+        resets' <- readTVar peerLimitsReset+        when (resets' == resets) $ modifyTVar' streamTable $ insertStream sid strm+        return (resets' == resets)+    if added then return strm else addStream conn sid  -- | 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+    -- With the parameters already set.+    strms <- atomically $ do+        modifyTVar' peerLimitsReset (+ 1)+        tableStreams <$> readTVar streamTable     forM_ strms $ \strm -> do         let sid = streamId strm         when (sid >= 0 && isClientInitiated sid) $

@@ -244,10 +244,20 @@     , pathAbandoned :: TVar Bool     -- ^ Gone back from: a send waiting for its anti-amplification     --   credit goes to the path now in use instead.+    , pathSocket :: Maybe Socket+    -- ^ A server's socket for the path, the one its packets came in on.+    --   'Nothing' for a client, which sends on the connection's socket.     }  newPathInfo :: SockAddr -> IO PathInfo-newPathInfo peerSockAddr = do+newPathInfo = newPathInfo' Nothing++-- | A server's path, on the socket its packets came in on.+newPathInfoOn :: Socket -> SockAddr -> IO PathInfo+newPathInfoOn = newPathInfo' . Just++newPathInfo' :: Maybe Socket -> SockAddr -> IO PathInfo+newPathInfo' pathSocket peerSockAddr = do     pathBytesTx <- newTVarIO 0     pathBytesRx <- newTVarIO 0     addressValidated <- newTVarIO False@@ -327,6 +337,9 @@     , bytesTx           :: IORef Int     , bytesRx           :: IORef Int     , connDone          :: TVar Bool+    , peerLimitsReset   :: TVar Int+    -- ^ How many times 'Network.QUIC.Connection.StreamTable.resetTxStreamLimits'+    --   has run, for a stream being added to tell it missed one.     , connAbortRequest  :: TVar (Maybe E.SomeException)     -- ^ How 'Network.QUIC.Connection.Misc.requestEnd' asked the connection     --   to end, for its protocol threads to act on.@@ -443,6 +456,7 @@     bytesTx           <- newIORef 0     bytesRx           <- newIORef 0     connDone          <- newTVarIO False+    peerLimitsReset   <- newTVarIO 0     connAbortRequest  <- newTVarIO Nothing     connRetiredSocks  <- newIORef []     -- TLS@@ -564,7 +578,8 @@     | OutHandshake [(EncryptionLevel, ByteString)]     | OutRetrans PlainPacket     | -- | 1-RTT frames for a path other than the one in use.-      OutPathProbe PathInfo [Frame]+      --   The CID, if given, is the one to send with instead of the one in use.+      OutPathProbe PathInfo (Maybe CID) [Frame]  -- | The control frames of an output, which 'queuedControls' counts. --   Not data, which flow control bounds, nor what is never resent.@@ -572,7 +587,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+countControls (OutPathProbe _ _ frames) = length $ filter isControl frames  isControl :: Frame -> Bool isControl Padding{} = False

@@ -40,11 +40,20 @@     | StrmBlocked Stream Int     deriving (Show) -addTx :: Connection -> Stream -> Int -> IO ()-addTx conn s len = atomically $ do-    addTxStreamData s len+-- | Counting and queueing at once, so that the offset given is the+--   stream's next one and the queue holds a stream's data in order.+queueTx :: Connection -> Stream -> [StreamData] -> Int -> IO ()+queueTx conn s dats len = atomically $ do+    off <- addTxStreamData s len     addTxData conn len+    putSendStreamQSTM conn $ TxStreamData s off dats len False +-- | Queueing the FIN, at the offset the stream has reached.+queueFin :: Stream -> IO ()+queueFin s = atomically $ do+    off <- addTxStreamData s 0+    putSendStreamQSTM (streamConnection s) $ TxStreamData s off [] 0 True+ -- | Sending a list of data in the stream. sendStreamMany :: Stream -> [ByteString] -> IO () sendStreamMany _ [] = return ()@@ -70,13 +79,10 @@             Right n                 -- Counted before queued, so that a reset in between takes                 -- it into the final size.-                | len == n -> do-                    addTx conn s n-                    putSendStreamQ conn $ TxStreamData s dats len False+                | len == n -> queueTx conn s dats len                 | otherwise -> do                     let (dats1, dats2) = split n dats-                    addTx conn s n-                    putSendStreamQ conn $ TxStreamData s dats1 n False+                    queueTx conn s dats1 n                     flowControl dats2 (len - n) False             Left blocked -> do                 -- Read each time round rather than once: the handshake may@@ -142,7 +148,7 @@     sclosed <- isTxStreamClosed s     when sclosed $ E.throwIO StreamIsClosed     setTxStreamClosed s-    putSendStreamQ (streamConnection s) $ TxStreamData s [] 0 True+    queueFin s     waitFinTx s  -- | Closing a stream without an error.@@ -169,7 +175,7 @@     sclosed <- isTxStreamClosed s     unless (receiveOnly || closed || sclosed) $ do         setTxStreamClosed s-        putSendStreamQ conn $ TxStreamData s [] 0 True+        queueFin s         waitFinTx s     stopUnfinished s aerr     -- Outside the guard above: whether or not the FIN goes out, we are done

@@ -12,7 +12,7 @@ -- | Getting information about a connection. getConnectionInfo :: Connection -> IO ConnectionInfo getConnectionInfo conn = do-    sock <- getSocket conn+    sock <- getPathSocket conn     -- fixme: this is undefined     mysa <- NS.getSocketName sock     peersa <- peerSockAddr <$> getPathInfo conn

@@ -16,6 +16,7 @@     module Network.QUIC.Client.Reader,     module Network.QUIC.Client.WatchDog,     module Network.QUIC.Socket,+    sendOutput, ) where  import Network.QUIC.Client.Reader (@@ -35,6 +36,7 @@ import Network.QUIC.QLogger import Network.QUIC.Qlog import Network.QUIC.Recovery+import Network.QUIC.Sender (sendOutput) import Network.QUIC.Socket import Network.QUIC.Stream import Network.QUIC.TLS

@@ -7,7 +7,7 @@  import qualified Control.Exception as E import qualified Data.ByteString as BS-import Network.Socket (SockAddr)+import Network.Socket (SockAddr, Socket) import Network.TLS (AlertDescription (..)) import System.Log.FastLogger @@ -191,9 +191,9 @@             -- flood in particular, must not pile up for good.             enforceQueuedControlLimit conn             case (mcidChanged, rpPeerAddr rpkt) of-                (Just cidChanged, Just peersa)+                (Just cidChanged, Just (sock, peersa))                     | largest && any (not . isProbing) plainFrames ->-                        checkMigration conn (headerMyCID hdr) peersa cidChanged+                        checkMigration conn (headerMyCID hdr) sock peersa cidChanged                 _ -> return ()             when ackEli $ do                 case lvl of@@ -313,8 +313,8 @@ --   carries a non-probing frame and is the largest so far comes from a new --   address.  Nothing before decryption: anyone who has seen the CID can --   send a packet from anywhere.-checkMigration :: Connection -> CID -> SockAddr -> Bool -> IO ()-checkMigration conn dCID peersa cidChanged = do+checkMigration :: Connection -> CID -> Socket -> SockAddr -> Bool -> IO ()+checkMigration conn dCID sock peersa cidChanged = do     mPathInfo <- findPathInfo conn peersa     current <- peerSockAddr <$> getPathInfo conn     case mPathInfo of@@ -328,7 +328,7 @@             claimed <- claimMigration conn             when claimed $                 forkManaged conn "QUIC migration" $-                    onClientMigration conn dCID peersa cidChanged+                    onClientMigration conn dCID sock peersa cidChanged  -- | Frames that do not move the peer (RFC 9000 Sec 9.1). isProbing :: Frame -> Bool@@ -339,30 +339,17 @@ isProbing _ = False  -- | Carry out the migration the caller has claimed with 'claimMigration'.-onClientMigration :: Connection -> CID -> SockAddr -> Bool -> IO ()-onClientMigration conn newdCID peersa cidChanged = handleLogUnit logAction $ do+onClientMigration :: Connection -> CID -> Socket -> SockAddr -> Bool -> IO ()+onClientMigration conn newdCID sock peersa cidChanged = handleLogUnit logAction $ do     -- fixme: should not block-    mcidinfo <--        if cidChanged-            then timeout (Microseconds 100000) "onClientMigration" $ waitPeerCID conn-            else return Nothing -- PathChallenge only, no RetireConnectionID     let msg = "Migration: " <> bhow peersa <> " (" <> bhow newdCID <> ")"     qlogDebug conn $ Debug $ toLogStr msg     connDebugLog conn $ "debug: onClientMigration: " <> msg-    oldPathInfo <- getPathInfo conn-    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.-    unless ok $ do-        connDebugLog conn $ "debug: onClientMigration: no response from " <> bhow peersa-        restorePathInfo conn oldPathInfo+    pathInfo <- newPathInfoOn sock peersa+    ok <- validateMigration conn pathInfo cidChanged+    unless ok $+        connDebugLog conn $+            "debug: onClientMigration: no response from " <> bhow peersa   where     logAction msg = connDebugLog conn ("debug: onClientMigration: " <> msg) 

@@ -3,6 +3,7 @@     checkWindowOpenSTM,     isEmptyPingSTM,     takePingSTM,+    sendPing,     speedup,     resender,     -- LossRecovery.hs@@ -60,3 +61,4 @@ import Network.QUIC.Recovery.Release import Network.QUIC.Recovery.Timer import Network.QUIC.Recovery.Types+import Network.QUIC.Recovery.Utils (sendPing)

@@ -4,6 +4,7 @@     sender,     mkHeader,     sendFinal,+    sendOutput, ) where  import Control.Concurrent@@ -50,7 +51,7 @@     send pathInfo buf bytes = case mdst of         Nothing -> connSend conn buf bytes         Just _ -> do-            (s, _) <- readIORef $ connSocket conn+            s <- maybe (getSocket conn) return $ pathSocket pathInfo             void $ NS.sendBufTo s buf bytes $ peerSockAddr pathInfo     SizedBuffer buf0 bufsiz0 = encryptRes conn     ldcc = connLDCC conn@@ -71,14 +72,16 @@     -- timeout ends it.     ackOnly = all (not . spAckEliciting) spkts0     go maxSiz = do-        mx <--            if ackOnly-                then return Nothing-                else-                    atomically-                        ( (Just <$> takePingSTM ldcc)-                            `orElse` (Nothing <$ checkWindowOpenSTM ldcc maxSiz)-                        )+        mx <- case mdst of+            _ | ackOnly -> return Nothing+            -- For another path: the PTO probe is for the path in use, so+            -- it is left for that and only the window is waited for.+            Just _ -> Nothing <$ atomically (checkWindowOpenSTM ldcc maxSiz)+            Nothing ->+                atomically+                    ( (Just <$> takePingSTM ldcc)+                        `orElse` (Nothing <$ checkWindowOpenSTM ldcc maxSiz)+                    )         case mx of             -- A PTO probe is the one packet allowed past a full congestion             -- window.  Normally sendPingPacket is the right way to spend it:@@ -424,8 +427,14 @@     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 (OutPathProbe pathInfo mcid frames) =+    construct conn RTT1Level frames False+        >>= sendPacketTo conn (Just pathInfo) . map withCID+  where+    withCID spkt = case (mcid, spPlainPacket spkt) of+        (Just cid, PlainPacket Short{} plain) ->+            spkt{spPlainPacket = PlainPacket (Short cid) plain}+        _ -> spkt sendOutput conn (OutRetrans (PlainPacket hdr0 plain0)) = do     frames <- adjustForRetransmit conn $ plainFrames plain0     let lvl = levelFromHeader hdr0@@ -534,14 +543,14 @@ packFin conn s False = do     mx <- tryPeekSendStreamQ conn     case mx of-        Just (TxStreamData s1 [] 0 True)+        Just (TxStreamData s1 _ [] 0 True)             | streamId s == streamId s1 -> do                 _ <- takeSendStreamQ conn                 return True         _ -> return False  sendTxStreamData :: Connection -> TxStreamData -> IO ()-sendTxStreamData conn (TxStreamData s dats len fin0) = do+sendTxStreamData conn (TxStreamData s off dats len fin0) = do     reset <- isTxStreamReset s     -- RFC 9000 Sec 3.3: no STREAM frame for a stream in "Reset Sent".     if reset@@ -549,12 +558,12 @@         else do             fin <- packFin conn s fin0             if len < limitation-                then sendStreamSmall conn s dats fin len-                else sendStreamLarge conn s dats fin+                then sendStreamSmall conn s off dats fin len+                else sendStreamLarge conn s off dats fin -sendStreamSmall :: Connection -> Stream -> [StreamData] -> Bool -> Int -> IO ()-sendStreamSmall conn s0 dats0 fin0 len0 = do-    off0 <- getTxStreamOffset s0 len0+sendStreamSmall+    :: Connection -> Stream -> Offset -> [StreamData] -> Bool -> Int -> IO ()+sendStreamSmall conn s0 off0 dats0 fin0 len0 = do     let sid0 = streamId s0         frame0 = StreamF sid0 off0 dats0 fin0         sb = if fin0 then (s0 :) else id@@ -575,7 +584,7 @@             Just _ -> dropReset mx     -- What a reset stream has queued goes nowhere; see 'sendTxStreamData'.     dropReset mx = case mx of-        Just (TxStreamData s1 _ _ fin1) -> do+        Just (TxStreamData s1 _ _ _ fin1) -> do             reset <- isTxStreamReset s1             if reset                 then do@@ -595,26 +604,27 @@         mx <- tryPeek         case mx of             Nothing -> return (build [frame], sb [])-            Just (TxStreamData s1 dats1 len1 fin1) -> do+            Just (TxStreamData s1 off1 dats1 len1 fin1) -> do                 -- 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+                -- Merged only where it follows on.+                let sid = streamId s+                    sid1 = streamId s1+                    (off, dats) = case frame of+                        StreamF _ o d _ -> (o, d)+                        _ -> error "sendStreamSmall"+                    merged = sid == sid1 && off + totalLen dats == off1+                    cost+                        | merged = len1                         | otherwise = len1 + streamFrameMaxOverhead                     total1 = cost + total                 if total1 < limitation                     then do                         _ <- takeSendStreamQ conn -- cf tryPeek                         fin1' <- packFin conn s1 fin1 -- must be after takeSendStreamQ-                        off1 <- getTxStreamOffset s1 len1-                        let sid = streamId s-                            sid1 = streamId s1-                        if sid == sid1+                        if merged                             then do-                                let (off, dats) = case frame of-                                        StreamF _ o d _ -> (o, d)-                                        _ -> error "sendStreamSmall"-                                    frame1 = StreamF sid off (dats ++ dats1) fin1'+                                let frame1 = StreamF sid off (dats ++ dats1) fin1'                                     sb1 = if fin1' then sb . (s1 :) else sb                                 loop s1 frame1 total1 build sb1                             else do@@ -624,20 +634,20 @@                                 loop s1 frame1 total1 build1 sb1                     else return (build [frame], sb []) -sendStreamLarge :: Connection -> Stream -> [ByteString] -> Bool -> IO ()-sendStreamLarge conn s dats0 fin0 = do-    loop dats0+sendStreamLarge+    :: Connection -> Stream -> Offset -> [ByteString] -> Bool -> IO ()+sendStreamLarge conn s off0 dats0 fin0 = do+    loop off0 dats0     when fin0 $ syncFinTx s   where     sid = streamId s-    loop [] = return ()-    loop dats = do+    loop _ [] = return ()+    loop off dats = do         reset <- isTxStreamReset s-        unless reset $ send dats-    send dats = do+        unless reset $ send off dats+    send off dats = do         let (dats1, dats2) = splitChunks dats             len = totalLen dats1-        off <- getTxStreamOffset s len         let fin = fin0 && null dats2             frame = StreamF sid off dats1 fin         ready <- isConnection1RTTReady conn@@ -645,7 +655,7 @@                 | ready = RTT1Level                 | otherwise = RTT0Level         construct conn lvl [frame] False >>= sendPacket conn-        loop dats2+        loop (off + len) dats2  -- Typical case: [3, 1024, 1024, 1024, 200] splitChunks :: [ByteString] -> ([ByteString], [ByteString])

@@ -25,8 +25,8 @@ ) where  import Control.Concurrent.STM-import qualified Control.Monad.STM as STM import qualified Control.Exception as E+import qualified Control.Monad.STM as STM import qualified Crypto.Token as CT import qualified Data.ByteString as BS import Data.Map.Strict (Map)@@ -35,9 +35,9 @@ import Network.Control (LRUCacheRef, Rate, newRate) import qualified Network.Control as LRUCache import Network.Socket (-    isClosedSocketError,     SockAddr (..),     Socket,+    isClosedSocketError,  ) import qualified Network.Socket.ByteString as NSB import qualified System.ThreadManager as T@@ -487,19 +487,18 @@             Just conn -> do                 alive <- getAlive conn                 when alive $ do-                    void $ setSocket conn mysock -- fixme                     -- Whether the peer has moved is for the receiver to say,                     -- once the packet has decrypted: anyone who has seen the                     -- CID can send one from anywhere.                     let rpkt = mkReceivedPacket cpkt tim siz lvl-                    writeRecvQ (connRecvQ conn) rpkt{rpPeerAddr = Just peersa}+                    writeRecvQ (connRecvQ conn) rpkt{rpPeerAddr = Just (mysock, peersa)} ---------------------------------------------------------------- dispatch     Dispatch{..}     _     _     logAction-    mysock+    _     peersa     _     _@@ -510,8 +509,6 @@         case mconn of             Nothing -> logAction $ "CID no match: " <> bhow dCID <> ", " <> bhow peersa             Just conn -> do-                -- fixme: is this block necessary?-                void $ setSocket conn mysock                 -- No new path from here: this packet has not decrypted, and                 -- the peer may not migrate during the handshake anyway                 -- (RFC 9000 Sec 9).

@@ -344,11 +344,11 @@ createServerConnection conf@ServerConfig{..} dispatch Accept{..} = do     retire0 <- newTVarIO False     sref <- newIORef (accMySocket, retire0)-    pathInfo <- newPathInfo accPeerSockAddr+    pathInfo <- newPathInfoOn accMySocket accPeerSockAddr     piref <- newIORef $ PeerInfo pathInfo Nothing     let send buf siz = void $ do-            (sock, _) <- readIORef sref             PeerInfo pinfo _ <- readIORef piref+            sock <- maybe (fst <$> readIORef sref) return $ pathSocket pinfo             NS.sendBufTo sock buf siz $ peerSockAddr pinfo         recv = recvServer accRecvQ     let myCID = fromJust $ initSrcCID accMyAuthCIDs

@@ -117,10 +117,10 @@  ---------------------------------------------------------------- -addTxStreamData :: Stream -> Int -> STM ()-addTxStreamData Stream{..} n = modifyTVar' streamFlowTx add-  where-    add flow = flow{txfSent = txfSent flow + n}+-- | Counting what is queued, answering the offset it starts at.+addTxStreamData :: Stream -> Int -> STM Offset+addTxStreamData Stream{..} n = stateTVar streamFlowTx $ \flow ->+    (txfSent flow, flow{txfSent = txfSent flow + n})  setTxMaxStreamData :: Stream -> Int -> IO () setTxMaxStreamData Stream{..} n = atomically $ modifyTVar' streamFlowTx set

@@ -110,7 +110,10 @@  type Length = Int -data TxStreamData = TxStreamData Stream [StreamData] Length Fin+-- | Data queued for a stream, with the offset it was given when queued.+--   The offset used to be taken when it was sent, and an entry lost on the+--   way, by a sender cancelled after taking it, gave its offset to the next.+data TxStreamData = TxStreamData Stream Offset [StreamData] Length Fin  data RxStreamData = RxStreamData     { rxstrmData :: StreamData

@@ -7,7 +7,7 @@ import Codec.Serialise import Data.Ix import GHC.Generics-import Network.Socket (SockAddr)+import Network.Socket (SockAddr, Socket) import Network.TLS.QUIC (ExtensionID (EID_QuicTransportParameters, ExtensionID)) import Text.Printf @@ -183,8 +183,8 @@     , rpTimeRecevied :: TimeMicrosecond     , rpReceivedBytes :: Int     , rpEncryptionLevel :: EncryptionLevel-    , rpPeerAddr :: Maybe SockAddr-    -- ^ Where a server received it from+    , rpPeerAddr :: Maybe (Socket, SockAddr)+    -- ^ On which socket a server received it, and from where     }     deriving (Eq, Show) 

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               quic-version:            0.3.21+version:            0.3.22 license:            BSD3 license-file:       LICENSE maintainer:         kazu@iij.ad.jp@@ -131,7 +131,7 @@         base16-bytestring >=1.0 && <1.1,         bytestring >=0.10,         containers,-        crypto-token >=0.2.0 && <0.3,+        crypto-token >=0.2.1 && <0.3,         crypton >=2.1.0 && <2.3,         crypton-x509 >=1.9.0 && <1.11,         crypton-x509-store >=1.9.0 && <1.11,@@ -270,6 +270,7 @@         filepath,         hspec,         network >=3.2.12,+        network-control,         quic,         ram,         stm,

@@ -170,6 +170,9 @@       --   datagram to the server from another socket, which answers       --   nothing: an on-path attacker's spurious migration.       ForwardAside (MVar ())+    | -- | As 'ForwardAside', but from an IPv6 socket to the server's+      --   @[::1]:15003@, a socket of the server other than the client's.+      ForwardAside6 (MVar ())  withPipe :: Scenario -> IO () -> IO () withPipe = withPipeWith False@@ -239,9 +242,19 @@                 -- the bracket has just closed.  That surfaces as "threadWait:                 -- invalid argument (Bad file descriptor)" from a thread nobody is                 -- watching, and buries whatever the test was really failing on.-                E.bracket (startRelay saS sockC sockS sockA irefC irefS) stopRelay $ \_ -> body+                E.bracket aside6 (mapM_ (close . fst)) $ \m6 ->+                    E.bracket (startRelay saS sockC sockS sockA m6 irefC irefS) stopRelay $ \_ -> body   where-    startRelay saS sockC sockS sockA irefC irefS = do+    -- Only for 'ForwardAside6', so that no other test needs IPv6.+    aside6 = case scenario of+        ForwardAside6 _ -> do+            a6 <- NE.head <$> getAddrInfo (Just hints6) (Just "::1") (Just "15003")+            s6 <- openSocket a6+            any6 <- NE.head <$> getAddrInfo (Just hints6) (Just "::1") (Just "0")+            bind s6 $ addrAddress any6+            return $ Just (s6, addrAddress a6)+        _ -> return Nothing+    startRelay saS sockC sockS sockA m6 irefC irefS = do         stop <- newTVarIO False         -- Where to send what comes back from the server.  Set once the client         -- has introduced itself, which is before the server can have anything@@ -301,12 +314,18 @@                                 ForwardAside trigger                                     | BS.head bs1 .&. 0x80 == 0 ->                                         isJust <$> tryTakeMVar trigger+                                ForwardAside6 trigger+                                    | BS.head bs1 .&. 0x80 == 0 ->+                                        isJust <$> tryTakeMVar trigger                                 _ -> return False-                            let sock = if aside then sockA else sockS+                            let (sock, dst) = case (aside, m6) of+                                    (True, Just (s6, sa6)) -> (s6, sa6)+                                    (True, Nothing) -> (sockA, saS)+                                    _ -> (sockS, saS)                             when (isCC || not dropPacket) $                                 delayIf (shouldDelay scenario True n) $                                     void $-                                        sendTo sock bs1 saS+                                        sendTo sock bs1 dst         -- from server         tid1 <- forkIO $ relayLoop stop sockS $ \(bs, _) -> do             mcids <- readIORef cidsRef@@ -369,6 +388,7 @@             , addrFlags = [AI_NUMERICHOST]             , addrFamily = AF_INET             }+    hints6 = hints{addrFamily = AF_INET6}     resolve port =         NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just port)     shouldDrop (Randomly n) _ _ = do

@@ -28,6 +28,7 @@ import Network.QUIC.Server  import Config+import PacketSpec (makeConnections)  spec :: Spec spec = do@@ -61,6 +62,23 @@             testInjected cc sc waitS $ \dcid scid ->                 encodeRetryPacket $                     RetryPacket Version2 dcid (toCID "forged") "token" (Left scid)+    -- The offset of queued data used to be taken when it was sent.  A+    -- sender cancelled after taking an entry from the queue lost it, and+    -- the next entry was then sent at its offset (HTTP/3 got DATA where+    -- its HEADERS were and closed with H3_FRAME_UNEXPECTED).+    describe "queued stream data" $+        it "has its offset from when it was queued" $ do+            scq <- makeTestServerConfig+            (clientConn, _) <- makeConnections scq Version1+            strm <- addStream clientConn 0+            setTxMaxData clientConn 1000+            setTxMaxStreamData strm 1000+            sendStream strm "HEADER"+            sendStream strm $ BS.replicate 16 0+            let offset (TxStreamData _ off _ len _) = (off, len)+            -- The first one taken and lost: the second keeps its offset.+            _ <- takeSendStreamQ clientConn+            offset <$> takeSendStreamQ clientConn `shouldReturn` (6, 16)     describe "a stateless reset to the client" $         it "ends the connection with ConnectionIsReset" $             testStatelessResetReceived cc sc waitS@@ -188,6 +206,12 @@             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.+        -- The server's socket for a path is the one its packets came in+        -- on.  It used to be the last socket any packet came in on, and the+        -- IPv4 old path was then challenged through the IPv6 socket.+        it "sends each path's packets on that path's socket" $ do+            let sc46 = sc{scAddresses = [("127.0.0.1", 15003), ("::1", 15003)]}+            testSpuriousMigration6 cc sc46 waitS         it "challenges the old path too" $             withTempDir "quic-old-path-qlog" $ \dir -> do                 testSpuriousMigration cc{ccQLog = Just dir} sc waitS 1500000@@ -767,6 +791,27 @@         consumeBytes strm 10000         assertEndOfStream strm         putMVar mvar ()++-- | 'testSpuriousMigration', with the client's packet forwarded to the+--   server's IPv6 socket.+testSpuriousMigration6 :: C.ClientConfig -> ServerConfig -> IO () -> IO ()+testSpuriousMigration6 cc sc waitS = do+    paths <- newEmptyMVar+    trigger <- newEmptyMVar+    withPipe (ForwardAside6 trigger) $+        withAsync (pathEchoServer sc paths) $ \_ -> do+            waitS+            C.run cc $ \conn -> do+                strm <- stream conn+                echo strm "ping1" `shouldReturn` Just "ping1"+                original <- takeMVar paths+                putMVar trigger ()+                sendStream strm "ping2"+                Timeout.timeout 1500000 (recvStream strm 1024)+                    `shouldReturn` Just "ping2"+                _ <- takeMVar paths+                echo strm "ping3" `shouldReturn` Just "ping3"+                takeMVar paths `shouldReturn` original  -- | A stateless reset with the token the server gave.  The client's reader --   threw 'ConnectionIsReset' to the connection's main thread; it now asks

@@ -1,9 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}+ module MigrationSpec where  import Control.Concurrent-import Control.Concurrent.Async (mapConcurrently, wait, withAsync)+import Control.Concurrent.Async (concurrently, mapConcurrently, wait, withAsync) import Control.Concurrent.STM-import Control.Monad (void)+import Control.Monad (forM, void)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as Short+import Network.Control (txfLimit) import Network.Socket (connect, getSocketName, withFdSocket) import qualified System.Timeout as T import Test.Hspec@@ -34,13 +39,99 @@                 let challenge = do                         out <- T.timeout 3000000 $ atomically $ takeOutputSTM serverConn                         case out of-                            Just (OutPathProbe _ [PathChallenge pdat]) -> return pdat+                            Just (OutPathProbe _ _ [PathChallenge pdat]) -> return pdat                             _ -> fail "no challenge"                 p1 <- challenge                 p2 <- challenge                 p2 `shouldNotBe` p1                 checkResponse serverConn p1                 wait validation `shouldReturn` True++    -- RFC 9000 Sec 9.5: a client that changed its CID to move gets a new+    -- CID of its own on the new path, while the old path keeps the old+    -- one; the old one was given up at once, and the old path's challenge+    -- went out with the new.+    describe "validateMigration" $ do+        let next conn = do+                out <- T.timeout 4000000 $ atomically $ takeOutputSTM conn+                maybe (fail "no output") return out+            setup = do+                (_, serverConn) <- makeConnections serverConf Version1+                old <- getPeerCID serverConn+                let new = toCID "\1\2\3\4\5\6\7\8"+                    srt = StatelessResetToken $ Short.toShort $ BS.replicate 16 1+                _ <- addPeerCID serverConn $ newCIDInfo 1 new srt+                pathInfo <- getPathInfo serverConn >>= newPathInfo . peerSockAddr+                return (serverConn, old, new, pathInfo)+            challenges conn = do+                o1 <- next conn+                o2 <- next conn+                case (o1, o2) of+                    ( OutPathProbe _ mcid [PathChallenge _]+                        , OutPathProbe _ Nothing [PathChallenge pdat]+                        ) -> return (mcid, pdat)+                    _ -> fail "not two challenges"+        it "keeps the old CID for the old path and retires it once moved" $ do+            (conn, old, new, pathInfo) <- setup+            withAsync (validateMigration conn pathInfo True) $ \v -> do+                (mcid, pdat) <- challenges conn+                mcid `shouldBe` Just old+                getPeerCID conn `shouldReturn` new+                checkResponse conn pdat+                wait v `shouldReturn` True+                o <- next conn+                case o of+                    OutControl RTT1Level [RetireConnectionID 0] -> return ()+                    _ -> fail "old CID not retired"+        it "goes back to the old CID and retires the new one if not moved" $ do+            (conn, old, _, pathInfo) <- setup+            withAsync (validateMigration conn pathInfo True) $ \v -> do+                (mcid, _) <- challenges conn+                mcid `shouldBe` Just old+                wait v `shouldReturn` False+                getPeerCID conn `shouldReturn` old+                -- After the challenges sent again.+                let retired = do+                        o <- next conn+                        case o of+                            OutControl RTT1Level [RetireConnectionID n] -> return n+                            _ -> retired+                retired `shouldReturn` 1++    -- The PTO probe is for the path in use.  A PATH_CHALLENGE for another+    -- path took it, and the probe went to that path instead.+    describe "a path probe" $+        it "leaves a pending PTO probe for the path in use" $ do+            (_, serverConn) <- makeConnections serverConf Version1+            let ldcc = connLDCC serverConn+            -- What 'run' sets up, so that the window is open.+            setInitialCongestionWindow ldcc 1200+            pathInfo <- getPathInfo serverConn >>= newPathInfo . peerSockAddr+            atomically $ writeTVar (addressValidated pathInfo) True+            sendPing ldcc RTT1Level+            pdat <- newPathData+            sendOutput serverConn $ OutPathProbe pathInfo Nothing [PathChallenge pdat]+            atomically (isEmptyPingSTM ldcc) `shouldReturn` False++    -- RFC 9001 Sec 4.6.2: a stream opened as 0-RTT is found rejected is+    -- held to the server's new limit too.  It read the old parameters,+    -- missed the reset that ran before it was in the table, and kept them.+    describe "resetTxStreamLimits" $+        it "reaches a stream opened while it runs" $ do+            (clientConn, _) <- makeConnections serverConf Version1+            base <- getPeerParameters clientConn+            let params n = base{initialMaxStreamDataBidiRemote = n}+            limits <- forM [0, 4 .. 4 * 1999] $ \sid -> do+                setPeerParameters clientConn $ params 100+                (strm, _) <-+                    concurrently+                        (addStream clientConn sid)+                        ( do+                            setPeerParameters clientConn $ params 10+                            resetTxStreamLimits clientConn $ params 10+                        )+                txfLimit <$> atomically (readStreamFlowTx strm)+            filter (/= 10) limits `shouldBe` []      describe "claimMigration" $ do         it "gives the migration to one caller and refuses the rest" $ do