diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Network/QUIC/Closer.hs b/Network/QUIC/Closer.hs --- a/Network/QUIC/Closer.hs +++ b/Network/QUIC/Closer.hs @@ -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 diff --git a/Network/QUIC/Connection/Migration.hs b/Network/QUIC/Connection/Migration.hs --- a/Network/QUIC/Connection/Migration.hs +++ b/Network/QUIC/Connection/Migration.hs @@ -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 () diff --git a/Network/QUIC/Connection/Misc.hs b/Network/QUIC/Connection/Misc.hs --- a/Network/QUIC/Connection/Misc.hs +++ b/Network/QUIC/Connection/Misc.hs @@ -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. diff --git a/Network/QUIC/Connection/Queue.hs b/Network/QUIC/Connection/Queue.hs --- a/Network/QUIC/Connection/Queue.hs +++ b/Network/QUIC/Connection/Queue.hs @@ -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 diff --git a/Network/QUIC/Connection/StreamTable.hs b/Network/QUIC/Connection/StreamTable.hs --- a/Network/QUIC/Connection/StreamTable.hs +++ b/Network/QUIC/Connection/StreamTable.hs @@ -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) $ diff --git a/Network/QUIC/Connection/Types.hs b/Network/QUIC/Connection/Types.hs --- a/Network/QUIC/Connection/Types.hs +++ b/Network/QUIC/Connection/Types.hs @@ -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 diff --git a/Network/QUIC/IO.hs b/Network/QUIC/IO.hs --- a/Network/QUIC/IO.hs +++ b/Network/QUIC/IO.hs @@ -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 diff --git a/Network/QUIC/Info.hs b/Network/QUIC/Info.hs --- a/Network/QUIC/Info.hs +++ b/Network/QUIC/Info.hs @@ -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 diff --git a/Network/QUIC/Internal.hs b/Network/QUIC/Internal.hs --- a/Network/QUIC/Internal.hs +++ b/Network/QUIC/Internal.hs @@ -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 diff --git a/Network/QUIC/Receiver.hs b/Network/QUIC/Receiver.hs --- a/Network/QUIC/Receiver.hs +++ b/Network/QUIC/Receiver.hs @@ -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) diff --git a/Network/QUIC/Recovery.hs b/Network/QUIC/Recovery.hs --- a/Network/QUIC/Recovery.hs +++ b/Network/QUIC/Recovery.hs @@ -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) diff --git a/Network/QUIC/Sender.hs b/Network/QUIC/Sender.hs --- a/Network/QUIC/Sender.hs +++ b/Network/QUIC/Sender.hs @@ -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]) diff --git a/Network/QUIC/Server/Reader.hs b/Network/QUIC/Server/Reader.hs --- a/Network/QUIC/Server/Reader.hs +++ b/Network/QUIC/Server/Reader.hs @@ -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). diff --git a/Network/QUIC/Server/Run.hs b/Network/QUIC/Server/Run.hs --- a/Network/QUIC/Server/Run.hs +++ b/Network/QUIC/Server/Run.hs @@ -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 diff --git a/Network/QUIC/Stream/Misc.hs b/Network/QUIC/Stream/Misc.hs --- a/Network/QUIC/Stream/Misc.hs +++ b/Network/QUIC/Stream/Misc.hs @@ -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 diff --git a/Network/QUIC/Stream/Types.hs b/Network/QUIC/Stream/Types.hs --- a/Network/QUIC/Stream/Types.hs +++ b/Network/QUIC/Stream/Types.hs @@ -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 diff --git a/Network/QUIC/Types/Packet.hs b/Network/QUIC/Types/Packet.hs --- a/Network/QUIC/Types/Packet.hs +++ b/Network/QUIC/Types/Packet.hs @@ -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) diff --git a/quic.cabal b/quic.cabal --- a/quic.cabal +++ b/quic.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: quic -version: 0.3.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, diff --git a/test/Config.hs b/test/Config.hs --- a/test/Config.hs +++ b/test/Config.hs @@ -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 diff --git a/test/IOSpec.hs b/test/IOSpec.hs --- a/test/IOSpec.hs +++ b/test/IOSpec.hs @@ -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 diff --git a/test/MigrationSpec.hs b/test/MigrationSpec.hs --- a/test/MigrationSpec.hs +++ b/test/MigrationSpec.hs @@ -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