quic 0.3.23 → 0.3.24
raw patch · 30 files changed
+617/−138 lines, 30 files
Files
- ChangeLog.md +24/−0
- Network/QUIC/Client/Reader.hs +5/−3
- Network/QUIC/Connection/Crypto.hs +4/−0
- Network/QUIC/Connection/Misc.hs +14/−3
- Network/QUIC/Connection/PacketNumber.hs +26/−0
- Network/QUIC/Connection/Queue.hs +10/−5
- Network/QUIC/Connection/Types.hs +14/−10
- Network/QUIC/IO.hs +9/−0
- Network/QUIC/Internal.hs +17/−2
- Network/QUIC/Packet.hs +1/−0
- Network/QUIC/Packet/Decrypt.hs +7/−0
- Network/QUIC/Receiver.hs +89/−39
- Network/QUIC/Recovery.hs +3/−0
- Network/QUIC/Recovery/Types.hs +18/−2
- Network/QUIC/Recovery/Utils.hs +1/−1
- Network/QUIC/Sender.hs +81/−49
- Network/QUIC/Server/Reader.hs +32/−10
- Network/QUIC/Server/Run.hs +1/−0
- Network/QUIC/Stream.hs +2/−0
- Network/QUIC/Stream/Misc.hs +12/−5
- Network/QUIC/Stream/Types.hs +2/−2
- Network/QUIC/Types/Constants.hs +4/−0
- Network/QUIC/Types/Frame.hs +4/−0
- Network/QUIC/Types/Queue.hs +4/−0
- quic.cabal +1/−1
- test/DatagramSpec.hs +39/−0
- test/IOSpec.hs +99/−0
- test/MigrationSpec.hs +4/−1
- test/PacketSpec.hs +85/−0
- test/RecoverySpec.hs +5/−5
ChangeLog.md view
@@ -1,5 +1,29 @@ # ChangeLog +## 0.3.24++`sendDatagram` throws `ConnectionIsClosed` for a DATAGRAM too large for a+packet. In `Network.QUIC.Internal`, `getIdleTimeout` replaces+`readMinIdleTimeout`, `streamResetTx` is a `TVar TxReset`, and+`adjustForRetransmit` takes `StreamResets`.++* Discard a packet whose packet number is processed already+ [#235](https://github.com/kazu-yamamoto/quic/pull/235)+* Resend no STREAM frame of a stream we have reset+ [#236](https://github.com/kazu-yamamoto/quic/pull/236)+* Treat an idle timeout of 0 as none and raise it to 3 PTOs+ [#237](https://github.com/kazu-yamamoto/quic/pull/237)+* Take what a handshake packet tells only once it decrypts+ [#238](https://github.com/kazu-yamamoto/quic/pull/238)+* Forget the receive queue of a connection by its source when it ends+ [#239](https://github.com/kazu-yamamoto/quic/pull/239)+* Count nothing for a stream reset while sendStream waits+ [#240](https://github.com/kazu-yamamoto/quic/pull/240)+* Keep DATAGRAMs within a packet+ [#241](https://github.com/kazu-yamamoto/quic/pull/241)+* Keep the receive queue of a connection by its source until it ends+ [#242](https://github.com/kazu-yamamoto/quic/pull/242)+ ## 0.3.23 Adds `scMaxConnections` to `ServerConfig` and `setMaxBidiStreams` and
Network/QUIC/Client/Reader.hs view
@@ -80,8 +80,10 @@ yield wait loop recv = do- Microseconds ito <- readMinIdleTimeout conn- expired <- registerDelay ito+ mito <- getIdleTimeout conn+ expired <- case mito of+ Nothing -> newTVarIO False+ Just (Microseconds ito) -> registerDelay ito ebs <- recv $ ((readTVar retired >>= STM.check) $> Retired)@@ -154,7 +156,7 @@ setRetried conn True releaseByRetry (connLDCC conn) >>= mapM_ put where- put ppkt = putOutput conn $ OutRetrans ppkt+ put ppkt = putOutput conn $ OutRetrans ppkt emptyStreamResets -- | Whether a packet from the server has been decrypted or a Retry taken. processed :: Connection -> IO Bool
Network/QUIC/Connection/Crypto.hs view
@@ -28,6 +28,7 @@ ) where import Control.Concurrent.STM+import qualified Data.IntSet as IntSet import Network.TLS.QUIC import Network.QUIC.Connection.Misc@@ -99,6 +100,9 @@ writeArray coders lvl initialCoder writeArray protectors lvl initialProtector when (lvl == InitialLevel) $ writeIORef prevInitialKeys Nothing+ -- Nothing more is decrypted there. 0-RTT shares its record with 1-RTT.+ when (lvl == InitialLevel || lvl == HandshakeLevel) $+ writeIORef (peerReceived ! lvl) IntSet.empty -- | Keeping the Initial keys we have, before they are replaced with the ones -- for a version we chose ourselves.
Network/QUIC/Connection/Misc.hs view
@@ -34,7 +34,7 @@ killReaders, addResource, freeResources,- readMinIdleTimeout,+ getIdleTimeout, setMinIdleTimeout, sendFrames, closeConnection,@@ -63,6 +63,7 @@ import Network.QUIC.Connector import Network.QUIC.Imports import Network.QUIC.Parameters+import Network.QUIC.Recovery (getPTO) import Network.QUIC.Types ----------------------------------------------------------------@@ -292,14 +293,24 @@ ---------------------------------------------------------------- -readMinIdleTimeout :: Connection -> IO Microseconds-readMinIdleTimeout Connection{..} = readIORef minIdleTimeout+-- | The idle timeout in effect, if any (RFC 9000 Sec 10.1): the smaller of+-- the two advertised, 0 being none, and at least three times the PTO.+getIdleTimeout :: Connection -> IO (Maybe Microseconds)+getIdleTimeout Connection{..} = do+ ito <- readIORef minIdleTimeout+ if ito == Microseconds 0+ then return Nothing+ else do+ pto <- getPTO connLDCC+ return $ Just $ max ito (3 * pto) setMinIdleTimeout :: Connection -> Microseconds -> IO () setMinIdleTimeout Connection{..} us | us == Microseconds 0 = return () | otherwise = atomicModifyIORef'' minIdleTimeout modify where+ -- Ours being none, the peer's alone is in effect.+ modify (Microseconds 0) = us modify us0 = min us us0 ----------------------------------------------------------------
Network/QUIC/Connection/PacketNumber.hs view
@@ -4,8 +4,12 @@ nextPacketNumber, setPeerPacketNumber, getPeerPacketNumber,+ recordPeerPacketNumber,+ receivedWindow, ) where +import qualified Data.IntSet as IntSet+ import Network.QUIC.Connection.Types import Network.QUIC.Connector import Network.QUIC.Imports hiding (range)@@ -28,3 +32,25 @@ setPeerPacketNumber :: Connection -> EncryptionLevel -> PacketNumber -> IO () setPeerPacketNumber Connection{..} lvl n = atomicModifyIORef'' (peerPacketNumber ! lvl) $ max n++----------------------------------------------------------------+-- Peer's packet numbers processed, against duplicates++-- | How far below the largest a packet number is remembered. Older ones+-- are taken as duplicates (RFC 9000 Sec 12.3).+receivedWindow :: PacketNumber+receivedWindow = 4096++-- | Recording a packet number of the peer, 'False' if it may be a duplicate.+recordPeerPacketNumber+ :: Connection -> EncryptionLevel -> PacketNumber -> IO Bool+recordPeerPacketNumber Connection{..} lvl pn =+ atomicModifyIORef' (peerReceived ! lvl) record+ where+ record pns+ | pn `IntSet.member` pns = (pns, False)+ | otherwise = case fst <$> IntSet.maxView pns of+ Just mx+ | pn < mx - receivedWindow -> (pns, False)+ | pn < mx -> (IntSet.insert pn pns, True)+ _ -> (snd $ IntSet.split (pn - receivedWindow - 1) $ IntSet.insert pn pns, True)
Network/QUIC/Connection/Queue.hs view
@@ -3,6 +3,7 @@ import Control.Concurrent.STM import Network.QUIC.Connection.Types+import Network.QUIC.Recovery (StreamResets) import Network.QUIC.Stream import Network.QUIC.Types @@ -65,20 +66,24 @@ -- lost it is no longer in the sent-packet database, so 'releaseOldest' cannot -- find it; it is here, waiting for a window that may not open until it has -- gone out.-takeRetransSTM :: Connection -> EncryptionLevel -> STM (Maybe PlainPacket)+takeRetransSTM+ :: Connection -> EncryptionLevel -> STM (Maybe (PlainPacket, StreamResets)) takeRetransSTM conn lvl = do outs <- flushTQueue (outputQ conn) let (found, rest) = pick outs mapM_ (writeTQueue (outputQ conn)) rest case found of Nothing -> return ()- Just ppkt ->- modifyTVar' (queuedControls conn) (subtract $ countControls $ OutRetrans ppkt)+ Just (ppkt, resets) ->+ modifyTVar' (queuedControls conn) $+ subtract $+ countControls $+ OutRetrans ppkt resets return found where pick [] = (Nothing, [])- pick (o@(OutRetrans ppkt@(PlainPacket hdr _)) : os)- | levelOf hdr == lvl = (Just ppkt, os)+ pick (o@(OutRetrans ppkt@(PlainPacket hdr _) resets) : os)+ | levelOf hdr == lvl = (Just (ppkt, resets), os) | otherwise = let (f, r) = pick os in (f, o : r) pick (o : os) = let (f, r) = pick os in (f, o : r) levelOf hdr
Network/QUIC/Connection/Types.hs view
@@ -321,6 +321,9 @@ peerPacketNumber :: Array EncryptionLevel (IORef PacketNumber) -- ^ The largest the peer has sent, by level. 0-RTT and 1-RTT share -- one, as they share a packet number space.+ , peerReceived :: Array EncryptionLevel (IORef IntSet)+ -- ^ The packet numbers processed, by space, kept within+ -- 'Network.QUIC.Connection.PacketNumber.receivedWindow' of the largest. , streamTable :: TVar StreamTable , -- | What a stream the application has closed still owes the -- connection's window, for as long as the peer has not finished it.@@ -442,7 +445,8 @@ delayedAckCount <- newIORef 0 delayedAckCancel <- newIORef (return ()) -- State- peerPacketNumber <- newPeerPacketNumber+ peerPacketNumber <- newPerSpace 0+ peerReceived <- newPerSpace IntSet.empty streamTable <- newTVarIO emptyStreamTable departedStreams <- newTVarIO IntMap.empty myStreamId <- newTVarIO (newConcurrency rl Bidirectional 0)@@ -485,8 +489,8 @@ connKeyPackets <- newIORef 0 -- Recovery -- Counted as 'putOutput' does, which this cannot use.- let put x = atomically $ do- let out = OutRetrans x+ let put x resets = atomically $ do+ let out = OutRetrans x resets writeTQueue outputQ out modifyTVar' queuedControls (+ countControls out) connLDCC <- newLDCC connState connQLog put@@ -561,11 +565,11 @@ ---------------------------------------------------------------- -newPeerPacketNumber :: IO (Array EncryptionLevel (IORef PacketNumber))-newPeerPacketNumber = do- ini <- newIORef 0- app <- newIORef 0- hnd <- newIORef 0+newPerSpace :: a -> IO (Array EncryptionLevel (IORef a))+newPerSpace x = do+ ini <- newIORef x+ app <- newIORef x+ hnd <- newIORef x return $ listArray (InitialLevel, RTT1Level)@@ -579,7 +583,7 @@ data Output = OutControl EncryptionLevel [Frame] | OutHandshake [(EncryptionLevel, ByteString)]- | OutRetrans PlainPacket+ | OutRetrans PlainPacket StreamResets | -- | 1-RTT frames for a path other than the one in use. -- The CID, if given, is the one to send with instead of the one in use. OutPathProbe PathInfo (Maybe CID) [Frame]@@ -588,7 +592,7 @@ -- Not data, which flow control bounds, nor what is never resent. countControls :: Output -> Int countControls (OutControl _ frames) = length $ filter isControl frames-countControls (OutRetrans (PlainPacket _ plain)) = length $ filter isControl $ plainFrames plain+countControls (OutRetrans (PlainPacket _ plain) _) = length $ filter isControl $ plainFrames plain countControls OutHandshake{} = 0 countControls (OutPathProbe _ _ frames) = length $ filter isControl frames
Network/QUIC/IO.hs view
@@ -78,6 +78,10 @@ -- streams sending at once used to see the same window and send it -- twice over. eblocked <- atomically $ do+ -- Reset meanwhile: counted now, it would be in no final size+ -- and the connection window would lose it for good.+ reset <- isTxStreamResetSTM s+ when reset $ throwSTM StreamIsClosed r <- checkBlocked s len wait case r of Right n -> do@@ -338,6 +342,11 @@ when (BS.length dat + frameOverhead > limitBytes) $ E.throwIO $ ConnectionIsClosed "DATAGRAM size violation"+ -- RFC 9221 Sec 5: a DATAGRAM frame cannot be split across packets.+ room <- subtract packetOverhead <$> getMaxPacketSize conn+ when (BS.length dat + frameOverhead > room) $+ E.throwIO $+ ConnectionIsClosed "DATAGRAM too large for a packet" let frame = Datagram False dat putOutput conn $ OutControl lvl [frame]
Network/QUIC/Internal.hs view
@@ -17,7 +17,13 @@ module Network.QUIC.Client.WatchDog, module Network.QUIC.Socket, sendOutput,+ adjustForRetransmit, processFrame,+ processReceivedPacket,+ processReceivedPacketHandshake,+ newRecvQDict,+ lookupInsertRecvQDict,+ deleteRecvQDict, ) where import Network.QUIC.Client.Reader (@@ -36,9 +42,18 @@ import Network.QUIC.Parameters import Network.QUIC.QLogger import Network.QUIC.Qlog-import Network.QUIC.Receiver (processFrame)+import Network.QUIC.Receiver (+ processFrame,+ processReceivedPacket,+ processReceivedPacketHandshake,+ ) import Network.QUIC.Recovery-import Network.QUIC.Sender (sendOutput)+import Network.QUIC.Sender (adjustForRetransmit, sendOutput)+import Network.QUIC.Server.Reader (+ deleteRecvQDict,+ lookupInsertRecvQDict,+ newRecvQDict,+ ) import Network.QUIC.Socket import Network.QUIC.Stream import Network.QUIC.TLS
Network/QUIC/Packet.hs view
@@ -11,6 +11,7 @@ decodePackets, decodeCryptPackets, decryptCrypt,+ decryptCryptWithKeys, decodeStatelessResetToken, -- * Frame
Network/QUIC/Packet/Decrypt.hs view
@@ -3,6 +3,7 @@ module Network.QUIC.Packet.Decrypt ( decryptCrypt,+ decryptCryptWithKeys, ) where import qualified Data.ByteString as BS@@ -42,6 +43,12 @@ decryptCryptWith conn crypt lvl protector' $ \_ -> return coder | otherwise -> return Nothing++-- | Decrypting with the keys given, not with the connection's.+decryptCryptWithKeys+ :: Connection -> Crypt -> EncryptionLevel -> (Coder, Protector) -> IO (Maybe Plain)+decryptCryptWithKeys conn crypt lvl (coder, protector) =+ decryptCryptWith conn crypt lvl protector $ \_ -> return coder decryptCryptWith :: Connection
Network/QUIC/Receiver.hs view
@@ -4,6 +4,8 @@ module Network.QUIC.Receiver ( receiver, processFrame,+ processReceivedPacket,+ processReceivedPacketHandshake, ) where import qualified Control.Exception as E@@ -36,8 +38,10 @@ recvTimeout = do -- The spec says that CC is not sent when timeout. -- But we intentionally sends CC when timeout.- ito <- readMinIdleTimeout conn- mx <- timeout ito "recvTimeout" $ connRecv conn -- fixme: taking minimum with peer's one+ mito <- getIdleTimeout conn+ mx <- case mito of+ Nothing -> Just <$> connRecv conn+ Just ito -> timeout ito "recvTimeout" $ connRecv conn case mx of Nothing -> do st <- getConnectionState conn@@ -92,7 +96,7 @@ processReceivedPacketHandshake :: Connection -> ReceivedPacket -> IO () processReceivedPacketHandshake conn rpkt = do- let CryptPacket hdr _ = rpCryptPacket rpkt+ let CryptPacket hdr crypt = rpCryptPacket rpkt lvl = rpEncryptionLevel rpkt msg = "processReceivedPacketHandshake "@@ -104,43 +108,69 @@ when (isClient conn) $ do lvl' <- getEncryptionLevel conn speedup (connLDCC conn) lvl' ("not decryptable: " <> toLogStr (show lvl))+ -- RFC 9000 Sec 7.2 and RFC 9001 Sec 4.9.1: what a packet tells us of+ -- the connection is taken only once it decrypts, or anyone on the+ -- path could break the handshake with a packet of garbage. Just () | isClient conn -> do- when (lvl == InitialLevel) $ do- peercid <- getPeerCID conn- let newPeerCID = headerPeerCID hdr- when (peercid /= headerPeerCID hdr) $- resetPeerCID conn newPeerCID- setPeerAuthCIDs conn $ \auth ->- auth{initSrcCID = Just newPeerCID}- case hdr of+ mver <- case hdr of Initial peerVer _ _ _ -> do myVer <- getVersion conn- let myOrigiVer = getOriginalVersion conn- firstTime = myVer == myOrigiVer- when (firstTime && myVer /= peerVer) $ do- setVersion conn peerVer- dcid <- getClientDstCID conn- initializeCoder conn InitialLevel $ initialSecrets peerVer dcid- qlogDebug conn $ Debug "Version changed"- _ -> return ()- processReceivedPacket conn rpkt+ let firstTime = myVer == getOriginalVersion conn+ return $+ if firstTime && myVer /= peerVer+ then Just peerVer+ else Nothing+ _ -> return Nothing+ case mver of+ -- RFC 9368 Sec 4: only a version we offered.+ Just peerVer+ | peerVer `notElem` otherVersions (origVersionInfo conn) ->+ qlogDropped conn (hdr, "unoffered_version" :: String)+ _ -> do+ dcid <- getClientDstCID conn+ mplain <- decryptReceived conn rpkt $ case mver of+ Nothing -> decryptCrypt conn crypt lvl+ Just peerVer -> do+ cipher <- getCipher conn InitialLevel+ keys <-+ genNiteCoder True peerVer cipher $+ initialSecrets peerVer dcid+ decryptCryptWithKeys conn crypt lvl keys+ when (isJust mplain) $ do+ case mver of+ Nothing -> return ()+ Just peerVer -> do+ setVersion conn peerVer+ initializeCoder conn InitialLevel $+ initialSecrets peerVer dcid+ qlogDebug conn $ Debug "Version changed"+ when (lvl == InitialLevel) $ do+ peercid <- getPeerCID conn+ let newPeerCID = headerPeerCID hdr+ when (peercid /= newPeerCID) $+ resetPeerCID conn newPeerCID+ setPeerAuthCIDs conn $ \auth ->+ auth{initSrcCID = Just newPeerCID}+ processDecrypted conn Nothing rpkt mplain | otherwise -> do- mycid <- getMyCID conn- when- ( lvl == HandshakeLevel- || (lvl == InitialLevel && mycid == headerMyCID hdr)- )- $ do- getPathInfo conn >>= setAddressValidated- when (lvl == HandshakeLevel) $ do- let ldcc = connLDCC conn- discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel- unless discarded $ fire conn (Microseconds 100000) $ do- dropSecrets conn InitialLevel- clearCryptoStream conn InitialLevel- onPacketNumberSpaceDiscarded ldcc InitialLevel- processReceivedPacket conn rpkt+ mplain <- decryptReceived conn rpkt $ decryptCrypt conn crypt lvl+ when (isJust mplain) $ do+ mycid <- getMyCID conn+ when+ ( lvl == HandshakeLevel+ || (lvl == InitialLevel && mycid == headerMyCID hdr)+ )+ $ do+ getPathInfo conn >>= setAddressValidated+ when (lvl == HandshakeLevel) $ do+ let ldcc = connLDCC conn+ discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel+ unless discarded $ fire conn (Microseconds 100000) $ do+ dropSecrets conn InitialLevel+ clearCryptoStream conn InitialLevel+ onPacketNumberSpaceDiscarded ldcc InitialLevel+ processDecrypted conn Nothing rpkt mplain processReceivedPacket :: Connection -> ReceivedPacket -> IO () processReceivedPacket conn = processReceivedPacket' conn Nothing@@ -149,9 +179,16 @@ -- the handshake is over: only then may the peer migrate. processReceivedPacket' :: Connection -> Maybe Bool -> ReceivedPacket -> IO () processReceivedPacket' conn mcidChanged rpkt = do- let CryptPacket hdr crypt = rpCryptPacket rpkt- lvl = rpEncryptionLevel rpkt- tim = rpTimeRecevied rpkt+ let CryptPacket _ crypt = rpCryptPacket rpkt+ mplain <- decryptReceived conn rpkt $ decryptCrypt conn crypt lvl+ processDecrypted conn mcidChanged rpkt mplain+ where+ lvl = rpEncryptionLevel rpkt++-- | Counting the packet for the path, then decrypting it as given.+decryptReceived+ :: Connection -> ReceivedPacket -> IO (Maybe Plain) -> IO (Maybe Plain)+decryptReceived conn rpkt decrypt = do -- Before the decryption below. RFC 9000, section 8.1: "servers MUST -- count all of the payload bytes received in datagrams that are uniquely -- attributed to a single connection. This includes datagrams that@@ -164,8 +201,21 @@ -- connection does not recover; it hangs until the idle timeout. pathInfo <- getPathInfo conn addPathRxBytes pathInfo $ rpReceivedBytes rpkt- mplain <- decryptCrypt conn crypt lvl+ decrypt++-- | Processing what 'decryptReceived' gave, 'Nothing' if it did not decrypt.+processDecrypted+ :: Connection -> Maybe Bool -> ReceivedPacket -> Maybe Plain -> IO ()+processDecrypted conn mcidChanged rpkt mplain = do+ let CryptPacket hdr crypt = rpCryptPacket rpkt+ lvl = rpEncryptionLevel rpkt+ tim = rpTimeRecevied rpkt+ dup <- case mplain of+ Just Plain{..} -> not <$> recordPeerPacketNumber conn lvl plainPacketNumber+ Nothing -> return False case mplain of+ -- RFC 9000 Sec 12.3: a packet processed already is discarded.+ Just _ | dup -> qlogDropped conn (hdr, "duplicate" :: String) Just plain@Plain{..} -> do addRxBytes conn $ rpReceivedBytes rpkt when (isIllegalReservedBits plainMarks || isNoFrames plainMarks) $
Network/QUIC/Recovery.hs view
@@ -45,6 +45,9 @@ spPacketNumber, spPeerPacketNumbers, spAckEliciting,+ spStreamResets,+ StreamResets (..),+ emptyStreamResets, mkSentPacket, fixSentPacket, LDCC,
Network/QUIC/Recovery/Types.hs view
@@ -4,6 +4,8 @@ module Network.QUIC.Recovery.Types ( SentPacket (..),+ StreamResets (..),+ emptyStreamResets, mkSentPacket, fixSentPacket, LostPacket (..),@@ -58,9 +60,21 @@ , spPacketNumber :: PacketNumber , spPeerPacketNumbers :: PeerPacketNumbers , spAckEliciting :: Bool+ , spStreamResets :: StreamResets } deriving (Eq, Show) +-- | The streams a packet carries STREAM frames of, each with whether we have+-- reset it. The 'TVar's are the streams' own, so a reset after sending+-- shows here, and a reset stream is not resent (RFC 9000 Sec 13.3).+newtype StreamResets = StreamResets [(StreamId, TVar TxReset)] deriving (Eq)++instance Show StreamResets where+ show (StreamResets xs) = "StreamResets " ++ show (map fst xs)++emptyStreamResets :: StreamResets+emptyStreamResets = StreamResets []+ instance Ord SentPacket where x <= y = spPacketNumber x <= spPacketNumber y @@ -82,6 +96,7 @@ , spPacketNumber = mypn , spPeerPacketNumbers = ppns , spAckEliciting = ackeli+ , spStreamResets = emptyStreamResets } fixSentPacket :: SentPacket -> Int -> Int -> SentPacket@@ -284,7 +299,7 @@ data LDCC = LDCC { ldccState :: ConnState , ldccQlogger :: QLogger- , putRetrans :: PlainPacket -> IO ()+ , putRetrans :: PlainPacket -> StreamResets -> IO () , recoveryRTT :: IORef RTT , recoveryCC :: TVar CC , spaceDiscarded :: Array EncryptionLevel (IORef Bool)@@ -319,7 +334,8 @@ arr = array (InitialLevel, RTT1Level) lst return arr -newLDCC :: ConnState -> QLogger -> (PlainPacket -> IO ()) -> IO LDCC+newLDCC+ :: ConnState -> QLogger -> (PlainPacket -> StreamResets -> IO ()) -> IO LDCC newLDCC cs qLog put = LDCC cs qLog put <$> newIORef initialRTT
Network/QUIC/Recovery/Utils.hs view
@@ -32,7 +32,7 @@ retransmit ldcc lostPackets = mapM_ put packetsToBeResent where packetsToBeResent = Seq.filter spAckEliciting lostPackets- put = putRetrans ldcc . spPlainPacket+ put spkt = putRetrans ldcc (spPlainPacket spkt) (spStreamResets spkt) ----------------------------------------------------------------
Network/QUIC/Sender.hs view
@@ -5,6 +5,7 @@ mkHeader, sendFinal, sendOutput,+ adjustForRetransmit, ) where import Control.Concurrent@@ -197,11 +198,13 @@ when ok $ do let ldcc = connLDCC conn mp <- releaseOldest ldcc lvl- frames <- case mp of+ (frames, resets) <- case mp of Just spkt -> do qlogDebug conn $ Debug "probe old" let PlainPacket _ plain0 = spPlainPacket spkt- adjustForRetransmit conn $ plainFrames plain0+ resets = spStreamResets spkt+ frames <- adjustForRetransmit conn resets $ plainFrames plain0+ return (frames, resets) Nothing -> do -- Nothing in flight at this level to resend. That does not -- mean there is nothing to send: a packet already declared@@ -210,12 +213,13 @@ -- is allowed to ignore and it is not. Spend the probe on it. mr <- atomically $ takeRetransSTM conn lvl case mr of- Just (PlainPacket _ plain0) -> do+ Just (PlainPacket _ plain0, resets) -> do qlogDebug conn $ Debug "probe retrans"- adjustForRetransmit conn $ plainFrames plain0+ frames <- adjustForRetransmit conn resets $ plainFrames plain0+ return (frames, resets) Nothing -> do qlogDebug conn $ Debug "probe ping"- return [Ping]+ return ([Ping], emptyStreamResets) -- A probe must elicit an ACK, whatever was left of the packet. let frames' = if any ackEliciting frames then frames else Ping : frames xs <- construct conn lvl frames' False@@ -233,7 +237,8 @@ addTxBytes conn bytes addPathTxBytes pathInfo bytes let sentPacket0 = fixSentPacket spkt bytes padlen- sentPacket = sentPacket0{spTimeSent = now}+ sentPacket =+ sentPacket0{spTimeSent = now, spStreamResets = resets} qlogSent conn sentPacket now onPacketSent ldcc sentPacket @@ -412,9 +417,11 @@ unless exist $ construct conn RTT1Level [] False >>= sendPacket conn sendOutput conn (OutControl lvl frames) = do mout <- tryPeekOutput conn+ room <- subtract packetOverhead <$> getMaxPacketSize conn case mout of+ -- Merged only where the DATAGRAMs fit in one packet. Just (OutControl lvl' frames')- | lvl == lvl' -> do+ | lvl == lvl' && datagramBytes (frames ++ frames') <= room -> do construct conn lvl (frames ++ frames') False >>= sendPacket conn void $ atomically $ takeOutputSTM conn _ -> construct conn lvl frames False >>= sendPacket conn@@ -435,10 +442,10 @@ (Just cid, PlainPacket Short{} plain) -> spkt{spPlainPacket = PlainPacket (Short cid) plain} _ -> spkt-sendOutput conn (OutRetrans (PlainPacket hdr0 plain0)) = do- frames <- adjustForRetransmit conn $ plainFrames plain0+sendOutput conn (OutRetrans (PlainPacket hdr0 plain0) resets) = do+ frames <- adjustForRetransmit conn resets $ plainFrames plain0 let lvl = levelFromHeader hdr0- construct conn lvl frames False >>= sendPacket conn+ construct conn lvl frames False >>= sendPacket conn . withStreamResets resets levelFromHeader :: Header -> EncryptionLevel levelFromHeader hdr@@ -447,36 +454,57 @@ where lvl = packetEncryptionLevel hdr -adjustForRetransmit :: Connection -> [Frame] -> IO [Frame]-adjustForRetransmit _ [] = return []-adjustForRetransmit conn (Padding{} : xs) = adjustForRetransmit conn xs-adjustForRetransmit conn (Ack{} : xs) = adjustForRetransmit conn xs-adjustForRetransmit conn (MaxStreamData sid _ : xs) = do- mstrm <- findStream conn sid- case mstrm of- Nothing -> adjustForRetransmit conn xs- Just strm -> do- newMax <- getRxMaxStreamData strm- let r = MaxStreamData sid newMax- rs <- adjustForRetransmit conn xs- return (r : rs)-adjustForRetransmit conn (MaxData{} : xs) = do- newMax <- getRxMaxData conn- let r = MaxData newMax- rs <- adjustForRetransmit conn xs- return (r : rs)-adjustForRetransmit conn (Datagram{} : xs) = adjustForRetransmit conn xs--- RFC 9000 Sec 13.3: "Responses to path validation using PATH_RESPONSE--- 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)+streamResets :: [Stream] -> StreamResets+streamResets ss = StreamResets [(streamId s, streamResetTx s) | s <- ss] +-- | Giving the packets the streams whose STREAM frames they may carry.+withStreamResets :: StreamResets -> [SentPacket] -> [SentPacket]+withStreamResets resets = map $ \spkt -> spkt{spStreamResets = resets}++adjustForRetransmit :: Connection -> StreamResets -> [Frame] -> IO [Frame]+adjustForRetransmit conn (StreamResets resets) = go+ where+ go [] = return []+ go (Padding{} : xs) = go xs+ go (Ack{} : xs) = go xs+ go (MaxStreamData sid _ : xs) = do+ mstrm <- findStream conn sid+ case mstrm of+ Nothing -> go xs+ Just strm -> do+ newMax <- getRxMaxStreamData strm+ let r = MaxStreamData sid newMax+ rs <- go xs+ return (r : rs)+ go (MaxData{} : xs) = do+ newMax <- getRxMaxData conn+ let r = MaxData newMax+ rs <- go xs+ return (r : rs)+ go (Datagram{} : xs) = go xs+ -- RFC 9000 Sec 13.3: "Responses to path validation using PATH_RESPONSE+ -- 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.+ go (PathResponse{} : xs) = go 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.+ go (PathChallenge{} : xs) = go xs+ -- RFC 9000 Sec 13.3: stream data is resent "unless the endpoint has sent+ -- a RESET_STREAM for that stream".+ go (x@(StreamF sid _ _ _) : xs) = do+ reset <- case lookup sid resets of+ Nothing -> return False+ Just var -> (== ResetSent) <$> readTVarIO var+ rs <- go xs+ return $ if reset then rs else x : rs+ go (x : xs) = do+ rs <- go xs+ return (x : rs)++-- | What the DATAGRAM frames take, with an upper bound on their headers.+datagramBytes :: [Frame] -> Int+datagramBytes fs = sum [1 + 8 + BS.length dat | Datagram _ dat <- fs]+ limitationC :: Int limitationC = 1024 @@ -526,7 +554,7 @@ threshold = 832 limitation :: Int-limitation = 1040+limitation = defaultQUICPacketSize - packetOverhead -- | Upper bound on what a stream frame takes on top of its data streamFrameMaxOverhead :: Int@@ -567,12 +595,14 @@ let sid0 = streamId s0 frame0 = StreamF sid0 off0 dats0 fin0 sb = if fin0 then (s0 :) else id- (frames, streams) <- loop s0 frame0 (len0 + streamFrameMaxOverhead) id sb+ (frames, streams, carried) <-+ loop s0 frame0 (len0 + streamFrameMaxOverhead) id sb (s0 :) ready <- isConnection1RTTReady conn let lvl | ready = RTT1Level | otherwise = RTT0Level- construct conn lvl frames False >>= sendPacket conn+ construct conn lvl frames False+ >>= sendPacket conn . withStreamResets (streamResets carried) mapM_ syncFinTx streams where tryPeek = do@@ -599,11 +629,12 @@ -> Int -> ([Frame] -> [Frame]) -> ([Stream] -> [Stream])- -> IO ([Frame], [Stream])- loop s frame total build sb = do+ -> ([Stream] -> [Stream])+ -> IO ([Frame], [Stream], [Stream])+ loop s frame total build sb cb = do mx <- tryPeek case mx of- Nothing -> return (build [frame], sb [])+ Nothing -> return (build [frame], sb [], cb []) 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.@@ -626,13 +657,13 @@ then do let frame1 = StreamF sid off (dats ++ dats1) fin1' sb1 = if fin1' then sb . (s1 :) else sb- loop s1 frame1 total1 build sb1+ loop s1 frame1 total1 build sb1 cb else do let frame1 = StreamF sid1 off1 dats1 fin1' build1 = build . (frame :) sb1 = if fin1' then sb . (s1 :) else sb- loop s1 frame1 total1 build1 sb1- else return (build [frame], sb [])+ loop s1 frame1 total1 build1 sb1 (cb . (s1 :))+ else return (build [frame], sb [], cb []) sendStreamLarge :: Connection -> Stream -> Offset -> [ByteString] -> Bool -> IO ()@@ -654,7 +685,8 @@ let lvl | ready = RTT1Level | otherwise = RTT0Level- construct conn lvl [frame] False >>= sendPacket conn+ construct conn lvl [frame] False+ >>= sendPacket conn . withStreamResets (streamResets [s]) loop (off + len) dats2 -- Typical case: [3, 1024, 1024, 1024, 200]
Network/QUIC/Server/Reader.hs view
@@ -21,6 +21,10 @@ -- * Receiving and reading RecvQ,+ RecvQDict,+ newRecvQDict,+ lookupInsertRecvQDict,+ deleteRecvQDict, recvServer, ServerState (..), ) where@@ -33,8 +37,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Network.ByteOrder-import Network.Control (LRUCacheRef, Rate, newRate)-import qualified Network.Control as LRUCache+import Network.Control (Rate, newRate) import Network.Socket ( SockAddr (..), Socket,@@ -162,25 +165,41 @@ -- Source CID -> RecvQ -- Initials and RTT0 are queued before Conneciton is created.-data RecvQDict = RecvQDict RecvBudget (LRUCacheRef CID RecvQ)--recvQDictSize :: Int-recvQDictSize = 100+--+-- One entry per connection, taken out when it ends ('deleteRecvQDict'), so+-- this is as large as the connections are many. It was an LRU of 100: an+-- entry pushed out by newer ones made a retransmitted Initial of its client+-- start a second connection.+data RecvQDict = RecvQDict RecvBudget (IORef (Map CID RecvQ)) -- | The queues share one budget, the endpoint's (#170). newRecvQDict :: IO RecvQDict newRecvQDict = RecvQDict <$> newRecvBudget recvBudgetLimit- <*> LRUCache.newLRUCacheRef recvQDictSize+ <*> newIORef M.empty --- Looking up and insert a new RecvQ if not exist.+-- | Looking up and inserting a new RecvQ if not exist, at once: two+-- dispatchers cannot both insert one. lookupInsertRecvQDict :: RecvQDict -> CID -> IO (RecvQ, Bool)-lookupInsertRecvQDict (RecvQDict budget ref) dcid = LRUCache.cached ref dcid $ newRecvQ budget+lookupInsertRecvQDict (RecvQDict budget ref) key = do+ new <- newRecvQ budget+ atomicModifyIORef' ref $ \m -> case M.lookup key m of+ Just q -> (m, (q, True))+ Nothing -> (M.insert key new m, (new, False)) lookupRecvQDict :: RecvQDict -> CID -> IO (Maybe RecvQ)-lookupRecvQDict (RecvQDict _ ref) dcid = LRUCache.cached' ref dcid+lookupRecvQDict (RecvQDict _ ref) key = M.lookup key <$> readIORef ref +-- | Forgetting the queue of a connection that has ended, unless the key has+-- another one by now. Kept, the next connection from the same key, a+-- client with a zero-length CID on the same address, went to it unheard.+deleteRecvQDict :: RecvQDict -> CID -> RecvQ -> IO ()+deleteRecvQDict (RecvQDict _ ref) key q = atomicModifyIORef'' ref $ \m ->+ case M.lookup key m of+ Just q' | q' == q -> M.delete key m+ _ -> m+ ---------------------------------------------------------------- data Accept = Accept@@ -193,6 +212,8 @@ , accPacketSize :: Int , accRegister :: CID -> Connection -> IO () , accUnregister :: CID -> IO ()+ , accForget :: IO ()+ -- ^ Taking the receive queue out of the source table, once ended , accAddressValidated :: Bool , accTime :: TimeMicrosecond }@@ -405,6 +426,7 @@ , accPacketSize = bytes , accRegister = reg , accUnregister = unreg+ , accForget = deleteRecvQDict srcTable key q , accAddressValidated = addrValid , accTime = tim }
Network/QUIC/Server/Run.hs view
@@ -318,6 +318,7 @@ where done = do closeRecvQ $ accRecvQ acc+ accForget acc releaseConnection dispatch open = createServerConnection conf dispatch acc -- 'killReaders' stops this connection's own threads and sees them out,
Network/QUIC/Stream.hs view
@@ -3,6 +3,7 @@ Stream, streamId, streamConnection,+ streamResetTx, newStream, TxStreamData (..), StreamState (..),@@ -17,6 +18,7 @@ -- * Misc resetTxStream, isTxStreamReset,+ isTxStreamResetSTM, getTxStreamOffset, isTxStreamClosed, setTxStreamClosed,
Network/QUIC/Stream/Misc.hs view
@@ -4,6 +4,7 @@ module Network.QUIC.Stream.Misc ( resetTxStream, isTxStreamReset,+ isTxStreamResetSTM, getTxStreamOffset, isTxStreamClosed, setTxStreamClosed,@@ -40,7 +41,7 @@ import Network.QUIC.Imports import Network.QUIC.Stream.Queue import Network.QUIC.Stream.Types-import Network.QUIC.Types (ApplicationProtocolError)+import Network.QUIC.Types (ApplicationProtocolError, TxReset (..)) ---------------------------------------------------------------- @@ -49,13 +50,19 @@ -- so nothing goes out past it. resetTxStream :: Stream -> IO Offset resetTxStream s@Stream{..} = do- -- Before the read: what is queued after it is dropped, not counted.- atomicWriteIORef streamResetTx True+ -- In one transaction with the read: 'queueTx' counts nothing for a+ -- reset stream, so the final size is all the connection counted for it.+ final <- atomically $ do+ writeTVar streamResetTx ResetSent+ txfSent <$> readTVar streamFlowTx setTxStreamClosed s- txfSent <$> readTVarIO streamFlowTx+ return final isTxStreamReset :: Stream -> IO Bool-isTxStreamReset Stream{..} = readIORef streamResetTx+isTxStreamReset s = atomically $ isTxStreamResetSTM s++isTxStreamResetSTM :: Stream -> STM Bool+isTxStreamResetSTM Stream{..} = (== ResetSent) <$> readTVar streamResetTx getTxStreamOffset :: Stream -> Int -> IO Offset getTxStreamOffset Stream{..} len = atomicModifyIORef' streamStateTx get
Network/QUIC/Stream/Types.hs view
@@ -42,7 +42,7 @@ , streamReass :: IORef Reass -- ^ Fragments which cannot be delivered yet , streamSyncFinTx :: TMVar ()- , streamResetTx :: IORef Bool+ , streamResetTx :: TVar TxReset -- ^ Whether our sending part has been reset , streamResetRx :: IORef (Maybe ApplicationProtocolError) -- ^ The error code of a RESET_STREAM from the peer@@ -91,7 +91,7 @@ streamRecvQ <- newRecvStreamQ streamReass <- newIORef $ Reass Map.empty Nothing streamSyncFinTx <- newEmptyTMVarIO- streamResetTx <- newIORef False+ streamResetTx <- newTVarIO NotReset streamResetRx <- newIORef Nothing streamReleased <- newIORef False streamRxBounds <- newTVarIO emptyRxBounds
Network/QUIC/Types/Constants.hs view
@@ -10,6 +10,10 @@ defaultQUICPacketSize :: Int defaultQUICPacketSize = 1200 +-- | Room kept in a packet for the header, an ACK frame and the AEAD tag.+packetOverhead :: Int+packetOverhead = 160+ -- Google paper: UDP payload size = 1350 -- http://www.audentia-gestion.fr/Recherche-Research-Google/46403.pdf
Network/QUIC/Types/Frame.hs view
@@ -49,6 +49,10 @@ -- On 32-bit machines, the total number of stream identifiers is limited. type StreamId = Int +-- | Whether we have reset the sending part of a stream, sending RESET_STREAM+-- (RFC 9000 Sec 3.1). Once reset, never back.+data TxReset = NotReset | ResetSent deriving (Eq, Show)+ -- | Checking if a stream is client-initiated bidirectional. isClientInitiatedBidirectional :: StreamId -> Bool isClientInitiatedBidirectional sid = (0b11 .&. sid) == 0
Network/QUIC/Types/Queue.hs view
@@ -41,6 +41,10 @@ data RecvQ = RecvQ (TQueue ReceivedPacket) (TVar Int) (TVar Int) (TVar Bool) RecvBudget +-- | The same queue.+instance Eq RecvQ where+ RecvQ q1 _ _ _ _ == RecvQ q2 _ _ _ _ = q1 == q2+ newRecvQ :: RecvBudget -> IO RecvQ newRecvQ budget = RecvQ
quic.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: quic-version: 0.3.23+version: 0.3.24 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp
test/DatagramSpec.hs view
@@ -8,6 +8,7 @@ import Control.Monad import Data.ByteString () import qualified Data.ByteString as BS+import qualified System.Timeout as Timeout import Test.Hspec import Network.QUIC@@ -139,6 +140,23 @@ sendDatagram conn (BS.replicate 50 0x41) threadDelay 500 + -- DATAGRAMs were put in one packet however large: the sender died with+ -- BufferOverrun.+ describe "DATAGRAMs" $ do+ it "all arrive when sent back to back" $+ withDatagramServer sc0 $ \got conn -> do+ replicateM_ 10 $ sendDatagram conn (BS.replicate 1000 0x41)+ r <- Timeout.timeout 2000000 $ takeMVar got+ map BS.length <$> r `shouldBe` Just (replicate 10 1000)+ it "are refused when too large for a packet" $+ withDatagramServer sc0 $ \_ conn -> do+ let tooLarge (ConnectionIsClosed err) =+ err == "DATAGRAM too large for a packet"+ tooLarge _ = False+ sendDatagram conn (BS.replicate 1500 0x41) `shouldThrow` tooLarge+ -- The connection is still there.+ sendDatagram conn (BS.replicate 1000 0x41)+ -- #226: the queue grew for as long as the peer sent faster than the -- application read. describe "the DATAGRAM receive queue" $@@ -168,6 +186,27 @@ let scDtgm = sc0 { scMaxDatagramFrameSize = 1024 } ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 1024 } testDatagram0RTT ccDtgm scDtgm++-- | A server receiving ten DATAGRAMs into the 'MVar', and a client+-- running the action. Both take DATAGRAMs of up to 2000 octets.+withDatagramServer+ :: ServerConfig -> (MVar [BS.ByteString] -> Connection -> IO ()) -> IO ()+withDatagramServer sc0 body = do+ let scDtgm = sc0 { scMaxDatagramFrameSize = 2000 }+ ccDtgm = testClientConfig { ccMaxDatagramFrameSize = 2000 }+ mvar <- newEmptyMVar+ got <- newEmptyMVar+ smgr <- newSessionManager+ let sc' = scDtgm { scSessionManager = smgr+ , scHooks = (scHooks scDtgm) { onServerReady = putMVar mvar () } }+ server conn = do+ waitEstablished conn+ replicateM 10 (recvDatagram conn) >>= putMVar got+ E.bracket (forkIO $ E.handle (\(E.SomeException _) -> return ()) $ S.run sc' server) killThread $ \_ -> do+ takeMVar mvar+ C.run ccDtgm $ \conn -> do+ waitEstablished conn+ body got conn injectDatagram1RTT :: EncryptionLevel -> Plain -> Plain injectDatagram1RTT lvl plain
test/IOSpec.hs view
@@ -14,6 +14,8 @@ import qualified Data.ByteString.Short as Short import Data.IORef import qualified Data.IntMap.Strict as IntMap+import Data.Maybe (isNothing)+import qualified Data.Sequence as Seq import GHC.Conc (getUncaughtExceptionHandler, setUncaughtExceptionHandler) import Network.Control (txfSent) import qualified Network.Socket as NS@@ -80,6 +82,84 @@ -- The first one taken and lost: the second keeps its offset. _ <- takeSendStreamQ clientConn offset <$> takeSendStreamQ clientConn `shouldReturn` (6, 16)+ -- A client with a zero-length CID is known by its address until its+ -- connection is set up. The queue of one that ended used to stay, and+ -- the next connection from the same address went to it unheard.+ describe "the queue of a connection by its source" $ do+ it "is forgotten when the connection ends" $ do+ dict <- newRecvQDict+ let key = toCID "127.0.0.1:4433"+ (q1, found1) <- lookupInsertRecvQDict dict key+ found1 `shouldBe` False+ (q1', found1') <- lookupInsertRecvQDict dict key+ (q1' == q1, found1') `shouldBe` (True, True)+ -- Another connection's queue is not forgotten for this one.+ q0 <- newRecvQ =<< newRecvBudget maxBound+ deleteRecvQDict dict key q0+ snd <$> lookupInsertRecvQDict dict key `shouldReturn` True+ deleteRecvQDict dict key q1+ (q2, found2) <- lookupInsertRecvQDict dict key+ (q2 == q1, found2) `shouldBe` (False, False)+ -- An LRU of 100 used to push it out, and a retransmitted Initial+ -- then started a second connection.+ it "is kept however many connections come after it" $ do+ dict <- newRecvQDict+ let key = toCID "first and longer"+ _ <- lookupInsertRecvQDict dict key+ forM_ [1 .. 200 :: Int] $ \i ->+ lookupInsertRecvQDict dict $ toCID $ BS.pack [fromIntegral i]+ snd <$> lookupInsertRecvQDict dict key `shouldReturn` True+ -- RFC 9000 Sec 10.1: 0 is no idle timeout, the effective one is the+ -- smaller of the two advertised, and it is at least three times the PTO.+ describe "the idle timeout" $ do+ it "is the peer's when ours is 0, and none when both are" $ do+ sci <- makeTestServerConfig+ (conn, _) <- makeConnections sci Version1+ writeIORef (minIdleTimeout conn) 0+ getIdleTimeout conn `shouldReturn` Nothing+ setMinIdleTimeout conn 0+ getIdleTimeout conn `shouldReturn` Nothing+ setMinIdleTimeout conn 20_000_000+ getIdleTimeout conn `shouldReturn` Just 20_000_000+ setMinIdleTimeout conn 30_000_000+ getIdleTimeout conn `shouldReturn` Just 20_000_000+ it "is at least three times the PTO" $ do+ sci <- makeTestServerConfig+ (conn, _) <- makeConnections sci Version1+ writeIORef (minIdleTimeout conn) 1000+ pto <- getPTO $ connLDCC conn+ getIdleTimeout conn `shouldReturn` Just (3 * pto)+ -- RFC 9000 Sec 13.3: stream data is resent unless the stream is reset.+ describe "a lost STREAM frame" $+ it "is not resent once its stream is reset" $ do+ scr <- makeTestServerConfig+ (clientConn, _) <- makeConnections scr Version1+ s0 <- addStream clientConn 0+ s4 <- addStream clientConn 4+ now <- getTimeMicrosecond+ let frames = [StreamF 0 0 ["zero"] False, StreamF 4 0 ["four"] False]+ hdr = Short $ toCID ""+ spkt =+ ( mkSentPacket+ 1+ RTT1Level+ (PlainPacket hdr (Plain (Flags 0) 1 frames 0))+ emptyPeerPacketNumbers+ True+ )+ { spTimeSent = now+ , spStreamResets =+ StreamResets [(0, streamResetTx s0), (4, streamResetTx s4)]+ }+ -- Reset after it was sent: the stream also leaves the table.+ resetStream s0 $ ApplicationProtocolError 0+ gone <- isNothing <$> findStream clientConn 0+ gone `shouldBe` True+ retransmit (connLDCC clientConn) $ Seq.singleton spkt+ Just (PlainPacket _ plain, resets) <-+ atomically $ takeRetransSTM clientConn RTT1Level+ adjustForRetransmit clientConn resets (plainFrames plain)+ `shouldReturn` [StreamF 4 0 ["four"] False] -- RFC 9000 Sec 4.1: two streams sending at once used to both see the -- same connection window and queue twice what MAX_DATA allowed. describe "the connection window" $@@ -98,6 +178,25 @@ sent <- txfSent <$> atomically (readConnectionFlowTx clientConn) return $ sent - base filter (> 100) overs `shouldBe` []+ -- A stream reset while 'sendStream' waits for the window used to have+ -- its data counted by the connection but not in the final size.+ describe "a stream reset while sending" $+ it "takes nothing from the connection window" $ do+ scr <- makeTestServerConfig+ (clientConn, _) <- makeConnections scr Version1+ s <- addStream clientConn 0+ setTxMaxStreamData s 100+ base <- txfSent <$> atomically (readConnectionFlowTx clientConn)+ setTxMaxData clientConn base+ r <- newEmptyMVar+ _ <- forkIO $ E.try (sendStream s $ BS.replicate 100 0) >>= putMVar r+ threadDelay 100000 -- waiting for the window+ resetStream s $ ApplicationProtocolError 0+ setTxMaxData clientConn $ base + 100+ res <- takeMVar r :: IO (Either QUICException ())+ sent <- txfSent <$> atomically (readConnectionFlowTx clientConn)+ sent - base `shouldBe` 0+ either show (const "sent") res `shouldBe` show StreamIsClosed describe "a stateless reset to the client" $ it "ends the connection with ConnectionIsReset" $ testStatelessResetReceived cc sc waitS
test/MigrationSpec.hs view
@@ -249,10 +249,13 @@ peersa <- peerSockAddr <$> getPathInfo clientConn connect sock peersa setMinIdleTimeout clientConn $ Microseconds 100000+ -- Raised to three times the PTO, which is what it waits.+ pto <- getPTO $ connLDCC clientConn retired <- getSocketRetire clientConn done <- newEmptyMVar void $ forkIO $ readerClient retired sock clientConn >> putMVar done ()- returned <- timeout (Microseconds 2000000) "idle reader" $ takeMVar done+ returned <-+ timeout (3 * pto + Microseconds 2000000) "idle reader" $ takeMVar done returned `shouldBe` Just () void $ getSocketName sock closeRetiredSockets clientConn
test/PacketSpec.hs view
@@ -62,6 +62,72 @@ (PacketIC (CryptPacket _ crypt) lvl _, _) <- decodePacket bin True mplain <- decryptCrypt serverConn crypt lvl plainPacketNumber <$> mplain `shouldBe` Just 300+ -- RFC 9000 Sec 12.3: a packet processed already is discarded.+ describe "a duplicated packet" $ do+ it "is processed once" $ do+ (clientConn, serverConn) <- makeConnections serverConf Version1+ let hdr = Initial Version1 clientChosenCID (toCID "") ""+ ppkt = PlainPacket hdr $ Plain (Flags 0) 0 [Ping] 0+ bin <- BS.createAndTrim 4096 $ \buf ->+ fst <$> encodePlainPacket clientConn (SizedBuffer buf 2048) ppkt Nothing+ (PacketIC cpkt lvl _, _) <- decodePacket bin True+ tim <- getTimeMicrosecond+ let rpkt = mkReceivedPacket cpkt tim (BS.length bin) lvl+ processReceivedPacket serverConn rpkt+ processReceivedPacket serverConn rpkt+ getRxBytes serverConn `shouldReturn` BS.length bin+ it "is told by its packet number, within the window" $ do+ (_, conn) <- makeConnections serverConf Version1+ let record = recordPeerPacketNumber conn+ record RTT0Level 5 `shouldReturn` True+ -- 0-RTT and 1-RTT share a packet number space.+ record RTT1Level 5 `shouldReturn` False+ record HandshakeLevel 5 `shouldReturn` True+ record RTT1Level 3 `shouldReturn` True+ record RTT1Level (5 + receivedWindow + 1) `shouldReturn` True+ -- Older than the window: taken as a duplicate.+ record RTT1Level 5 `shouldReturn` False+ record RTT1Level 6 `shouldReturn` True+ it "is forgotten with the keys of its space" $ do+ (_, conn) <- makeConnections serverConf Version1+ let record = recordPeerPacketNumber conn+ _ <- record HandshakeLevel 5+ _ <- record RTT1Level 5+ dropSecrets conn HandshakeLevel+ dropSecrets conn RTT0Level+ record HandshakeLevel 5 `shouldReturn` True+ -- 0-RTT keys go, but 1-RTT goes on in the same space.+ record RTT1Level 5 `shouldReturn` False++ -- RFC 9000 Sec 7.2 and RFC 9001 Sec 4.9.1: a packet changes nothing of+ -- the connection unless it decrypts.+ describe "a packet in the handshake" $ do+ it "gives the client the server's CID only if it decrypts" $ do+ let serverInitial corrupt = do+ (clientConn, serverConn) <- makeConnections serverConf Version1+ let hdr = Initial Version1 (toCID "") (toCID "server") ""+ bin <- packetFrom serverConn hdr corrupt+ processHandshake clientConn bin+ getPeerCID clientConn+ serverInitial True `shouldReturn` clientChosenCID+ serverInitial False `shouldReturn` toCID "server"+ it "leaves the client in its version for one it did not offer" $ do+ (clientConn, serverConn) <- makeConnections serverConf Version1+ let hdr = Initial Version2 (toCID "") (toCID "server") ""+ bin <- packetFrom serverConn hdr False+ processHandshake clientConn bin+ getVersion clientConn `shouldReturn` Version1+ getPeerCID clientConn `shouldReturn` clientChosenCID+ it "validates the client's address only if it decrypts" $ do+ let clientInitial corrupt = do+ (clientConn, serverConn) <- makeConnections serverConf Version1+ let hdr = Initial Version1 clientChosenCID (toCID "") ""+ bin <- packetFrom clientConn hdr corrupt+ processHandshake serverConn bin+ getPathInfo serverConn >>= readTVarIO . addressValidated+ clientInitial True `shouldReturn` False+ clientInitial False `shouldReturn` True+ describe "encodePlainPacket" $ do it "leaves the peer a whole header protection sample" $ do (senderConn, _) <- makeConnections serverConf Version1@@ -102,6 +168,25 @@ forM_ [0 .. 15] $ \n -> do broken <- fst <$> decodePacket (retryWithTrailing n) True broken `shouldSatisfy` isBroken++-- | A packet of a PING, its last octet flipped if @corrupt@.+packetFrom+ :: Connection -> Header -> Bool -> IO ByteString+packetFrom sender hdr corrupt = do+ let ppkt = PlainPacket hdr $ Plain (Flags 0) 0 [Ping] 0+ bin <- BS.createAndTrim 4096 $ \buf ->+ fst <$> encodePlainPacket sender (SizedBuffer buf 2048) ppkt Nothing+ return $+ if corrupt+ then BS.snoc (BS.init bin) (BS.last bin `xor` 0xff)+ else bin++processHandshake :: Connection -> ByteString -> IO ()+processHandshake conn bin = do+ (PacketIC cpkt lvl _, _) <- decodePacket bin True+ tim <- getTimeMicrosecond+ processReceivedPacketHandshake conn $+ mkReceivedPacket cpkt tim (BS.length bin) lvl -- | An Initial packet from the client, its packet number in one octet as a -- peer which has seen @pn - 1@ acknowledged may send it. Our encoder
test/RecoverySpec.hs view
@@ -16,7 +16,7 @@ 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 ())+ 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@@ -28,7 +28,7 @@ describe "PTO" $ do it "is armed for the space that expires first" $ do cs <- newConnState Server- ldcc <- newLDCC cs (\_ -> return ()) (\_ -> return ())+ ldcc <- newLDCC cs (\_ -> return ()) (\_ _ -> return ()) -- Far in the future so that the timer does not fire. now <- getTimeMicrosecond let at lvl pn s =@@ -42,13 +42,13 @@ 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 ())+ 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 ())+ ldcc <- newLDCC cs (\_ -> return ()) (\_ _ -> return ()) atomically $ writeTVar (encryptionLevel cs) RTT1Level onAckReceived ldcc HandshakeLevel (AckInfo 0 0 []) 0 getPtoTimeAndSpace ldcc `shouldReturn` Nothing@@ -56,7 +56,7 @@ describe "a lost packet" $ do let lostWith frames = do cs <- newConnState Client- ldcc <- newLDCC cs (\_ -> return ()) (\_ -> return ())+ ldcc <- newLDCC cs (\_ -> return ()) (\_ _ -> return ()) now <- getTimeMicrosecond let lost = (sp 1 (any ackEliciting frames) now)