quic-0.3.14: Network/QUIC/Sender.hs
{-# LANGUAGE OverloadedStrings #-}
module Network.QUIC.Sender (
sender,
mkHeader,
sendFinal,
) where
import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception as E
import qualified Data.ByteString as BS
import Foreign.Ptr (plusPtr)
import Network.QUIC.Config
import Network.QUIC.Connection
import Network.QUIC.Connector
import Network.QUIC.Crypto (confidentialityLimit)
import Network.QUIC.Exception
import Network.QUIC.Imports
import Network.QUIC.Packet
import Network.QUIC.Qlog
import Network.QUIC.Recovery
import Network.QUIC.Stream
import Network.QUIC.Types
----------------------------------------------------------------
cryptoFrame :: Connection -> CryptoData -> EncryptionLevel -> IO Frame
cryptoFrame conn crypto lvl = do
let len = BS.length crypto
mstrm <- getCryptoStream conn lvl
case mstrm of
Nothing -> E.throwIO MustNotReached
Just strm -> do
off <- getTxStreamOffset strm len
return $ CryptoF off crypto
----------------------------------------------------------------
sendPacket :: Connection -> [SentPacket] -> IO ()
sendPacket _ [] = return ()
sendPacket conn spkts0 = getMaxPacketSize conn >>= go
where
SizedBuffer buf0 bufsiz0 = encryptRes conn
ldcc = connLDCC conn
-- RFC 9002 section 7: "packets containing only ACK frames do not count
-- toward bytes in flight and are not congestion controlled". Waiting
-- for the window before sending one is therefore wrong on its own terms,
-- and it wedges the sender: there is one sender thread, it blocks inside
-- here until the window opens, and everything queued behind it waits --
-- including the retransmission of a CRYPTO frame the peer needs before
-- it can acknowledge anything and let the window open at all.
--
-- A stalled handshake caught in IOSpec has exactly that shape. The
-- client's Finished is declared lost and queued for retransmission, and
-- the queue never moves again because the sender is holding an ACK-only
-- Handshake packet against a full window. The PTO keeps firing and
-- keeps sending a bare PING, because what is being held is not
-- ack-eliciting and so is not a probe; twenty seconds later the idle
-- 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)
)
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:
-- it retransmits the oldest packet still in flight at this level,
-- and falls back to a PING when there is none.
--
-- But when the packet the peer is waiting for has already been
-- declared lost, it is no longer in flight -- it is here, in
-- spkts0, waiting for a window that cannot open. The 1-RTT
-- packets holding the window shut cannot be acknowledged until
-- the peer has that very frame, and they are not eligible for
-- loss detection either, because RFC 9002 section 6.2.1 forbids
-- arming a timer for Application Data before the handshake is
-- confirmed. So the bytes stay in flight, the window stays
-- full, sendPingPacket finds nothing to retransmit and sends a
-- PING, and the handshake never finishes.
--
-- Hold an ack-eliciting packet at this level and it is a probe in
-- its own right, so send it instead -- the branch below does.
-- Anything else is not a probe, and the PING still is.
Just lvl
| lvl `elem` [InitialLevel, HandshakeLevel]
, not (any (\p -> spEncryptionLevel p == lvl && spAckEliciting p) spkts0) -> do
sendPingPacket conn lvl
go maxSiz
_ -> do
when (isJust mx) $ qlogDebug conn $ Debug "probe new"
(sentPackets, leftsiz) <- buildPackets buf0 bufsiz0 maxSiz spkts0 id
let bytes = bufsiz0 - leftsiz
pathInfo <- getPathInfo conn
when (isServer conn) $
waitAntiAmplificationFree conn pathInfo bytes
-- If the secret of this level (e.g. HandshakeLevel)
-- is already dropped, bytes is 0.
when (bytes > 0) $ do
now <- getTimeMicrosecond
connSend conn buf0 bytes
addTxBytes conn bytes
addPathTxBytes pathInfo bytes
forM_ sentPackets $ \sentPacket0 -> do
let sentPacket = sentPacket0{spTimeSent = now}
qlogSent conn sentPacket now
onPacketSent ldcc sentPacket
-- RFC 9001 Sec 6.6: "Endpoints MUST count the number of
-- encrypted packets for each set of keys. If the total
-- number of encrypted packets with the same key exceeds
-- the confidentiality limit for the selected AEAD, the
-- endpoint MUST stop using those keys." The way out it
-- gives is a key update, which nothing here starts, so
-- what is left is the other: "If a key update is not
-- possible ... the endpoint MUST stop using the
-- connection", and closing with AEAD_LIMIT_REACHED is how
-- that section recommends doing it.
let n1rtt =
length $
filter ((== RTT1Level) . spEncryptionLevel) sentPackets
when (n1rtt > 0) $ do
protected <-
atomicModifyIORef' (connKeyPackets conn) $
\n -> (n + n1rtt, n + n1rtt)
cipher <- getCipher conn RTT1Level
when (protected > confidentialityLimit cipher) $
closeConnection
conn
AeadLimitReached
"the key has protected too many packets"
buildPackets _ _ _ [] _ = error "sendPacket: buildPackets"
buildPackets buf bufsiz siz [spkt] build0 = do
let pkt = spPlainPacket spkt
-- Pad only what can be acknowledged. Padding puts a packet in
-- flight (RFC 9002 Sec 2) and so spends congestion window, but it
-- does not make the packet ack-eliciting -- and the loss timer is
-- cancelled, correctly, when nothing ack-eliciting is in flight.
-- An ACK-only packet padded to the full size therefore takes 1350
-- bytes of window that nothing will ever give back: no timer, no
-- loss declared, no release. Four of them fill a recovering
-- window and the sender never speaks again. 1-RTT only; the
-- handshake has its own reasons to pad.
mlen
| spAckEliciting spkt = Just siz
| spEncryptionLevel spkt /= RTT1Level = Just siz
| otherwise = Nothing
(bytes, padlen) <-
encodePlainPacket conn (SizedBuffer buf bufsiz) pkt mlen
if bytes < 0
then return (build0 [], bufsiz)
else do
let sentPacket = fixSentPacket spkt bytes padlen
return (build0 [sentPacket], bufsiz - bytes)
buildPackets buf bufsiz siz (spkt : spkts) build0 = do
let pkt = spPlainPacket spkt
(bytes, padlen) <- encodePlainPacket conn (SizedBuffer buf bufsiz) pkt Nothing
if bytes < 0
then buildPackets buf bufsiz siz spkts build0
else do
let sentPacket = fixSentPacket spkt bytes padlen
let build0' = build0 . (sentPacket :)
buf' = buf `plusPtr` bytes
bufsiz' = bufsiz - bytes
siz' = siz - spSentBytes sentPacket
buildPackets buf' bufsiz' siz' spkts build0'
----------------------------------------------------------------
sendPingPacket :: Connection -> EncryptionLevel -> IO ()
sendPingPacket conn lvl = do
pathInfo <- getPathInfo conn
maxSiz <- getMaxPacketSize conn
ok <-
if isClient conn
then return True
else checkAntiAmplificationFree pathInfo maxSiz
when ok $ do
let ldcc = connLDCC conn
mp <- releaseOldest ldcc lvl
frames <- case mp of
Just spkt -> do
qlogDebug conn $ Debug "probe old"
let PlainPacket _ plain0 = spPlainPacket spkt
adjustForRetransmit conn $ plainFrames plain0
Nothing -> do
-- Nothing in flight at this level to resend. That does not
-- mean there is nothing to send: a packet already declared
-- lost has left the sent-packet database and is waiting in
-- the output queue, behind a congestion window that a probe
-- 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
qlogDebug conn $ Debug "probe retrans"
adjustForRetransmit conn $ plainFrames plain0
Nothing -> do
qlogDebug conn $ Debug "probe ping"
return [Ping]
xs <- construct conn lvl frames False
-- Asking for the last one and asking whether there is one at all are
-- the same question, so ask it once.
case reverse xs of
[] -> qlogDebug conn $ Debug "ping NULL"
spkt : _ -> do
let ping = spPlainPacket spkt
let sizbuf@(SizedBuffer buf _) = encryptRes conn
(bytes, padlen) <- encodePlainPacket conn sizbuf ping (Just maxSiz)
when (bytes > 0) $ do
now <- getTimeMicrosecond
connSend conn buf bytes
addTxBytes conn bytes
addPathTxBytes pathInfo bytes
let sentPacket0 = fixSentPacket spkt bytes padlen
sentPacket = sentPacket0{spTimeSent = now}
qlogSent conn sentPacket now
onPacketSent ldcc sentPacket
----------------------------------------------------------------
construct
:: Connection
-> EncryptionLevel
-> [Frame]
-> Bool
-> IO [SentPacket]
construct conn lvl frames multilevel = do
discarded <- getPacketNumberSpaceDiscarded ldcc lvl
if discarded
then return []
else do
established <- isConnectionEstablished conn
if established || multilevel
then do
constructTargetPacket
else do
ppkt0 <- constructLowerAckPacket
ppkt1 <- constructTargetPacket
return (ppkt0 ++ ppkt1)
where
ldcc = connLDCC conn
constructLowerAckPacket = do
let lvl' = case lvl of
HandshakeLevel -> InitialLevel
RTT1Level -> HandshakeLevel
_ -> RTT1Level
if lvl' == RTT1Level
then return []
else do
ppns <- getPeerPacketNumbers ldcc lvl'
if nullPeerPacketNumbers ppns
then return []
else mkPlainPacket conn lvl' [] ppns
constructTargetPacket
| null frames = do
-- ACK only packet
resetDealyedAck conn
ppns <- getPeerPacketNumbers ldcc lvl
if nullPeerPacketNumbers ppns
then return []
else
if lvl == RTT1Level
then do
prevppns <- getPreviousRTT1PPNs ldcc
if ppns /= prevppns
then do
setPreviousRTT1PPNs ldcc ppns
mkPlainPacket conn lvl [] ppns
else return []
else mkPlainPacket conn lvl [] ppns
| otherwise = do
resetDealyedAck conn
ppns <- getPeerPacketNumbers ldcc lvl
mkPlainPacket conn lvl frames ppns
mkPlainPacket
:: Connection -> EncryptionLevel -> [Frame] -> PeerPacketNumbers -> IO [SentPacket]
mkPlainPacket conn lvl frames0 ppns = do
let ackEli
| null frames0 = False
| otherwise = True
frames
| nullPeerPacketNumbers ppns = frames0
| otherwise = mkAck ppns : frames0
header <- mkHeader conn lvl
mypn <- nextPacketNumber conn
let convert = onPlainCreated $ connHooks conn
plain = convert lvl $ Plain (Flags 0) mypn frames 0
ppkt = PlainPacket header plain
return [mkSentPacket mypn lvl ppkt ppns ackEli]
where
mkAck ps = Ack (toAckInfo $ fromPeerPacketNumbers ps) 0
mkHeader :: Connection -> EncryptionLevel -> IO Header
mkHeader conn lvl = do
ver <- getVersion conn
mycid <- getMyCID conn
peercid <- getPeerCID conn
token <- if lvl == InitialLevel then getToken conn else return ""
return $ case lvl of
InitialLevel -> Initial ver peercid mycid token
RTT0Level -> RTT0 ver peercid mycid
HandshakeLevel -> Handshake ver peercid mycid
RTT1Level -> Short peercid
----------------------------------------------------------------
data Switch
= SwPing EncryptionLevel
| SwOut Output
| SwStrm TxStreamData
sender :: Connection -> IO ()
sender conn = handleLogT logAction loop
where
loop = do
exit <- atomically $ do
done <- readTVar $ connDone conn
a <- isEmptyPingSTM (connLDCC conn)
b <- isEmptyOutputSTM conn
c <- isEmptyStreamSTM conn
if done
then return (a && b && c)
else if (not a || not b || not c) then return False else retry
if exit
then
E.throwIO ExitConnection
else do
sendP conn
loop
logAction msg = connDebugLog conn ("debug: sender: " <> msg)
sendP :: Connection -> IO ()
sendP conn = do
x <-
atomically
( (SwPing <$> takePingSTM (connLDCC conn))
`orElse` (SwOut <$> takeOutputSTM conn)
`orElse` (SwStrm <$> takeSendStreamQSTM conn)
)
case x of
SwPing lvl -> sendPingPacket conn lvl
SwOut out -> sendOutput conn out
SwStrm tx -> sendTxStreamData conn tx
sendFinal :: Connection -> IO ()
sendFinal conn = loop 30
where
msg = "sendFinal " ++ if isServer conn then "Server" else "Client"
loop :: Int -> IO ()
loop 0 = return ()
loop n = do
mx <- timeout (Microseconds 10) msg $ sendP conn
case mx of
Nothing -> return ()
Just () -> loop (n - 1)
----------------------------------------------------------------
discardClientInitialPacketNumberSpace :: Connection -> IO ()
discardClientInitialPacketNumberSpace conn
| isClient conn = 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
| otherwise = return ()
sendOutput :: Connection -> Output -> IO ()
sendOutput conn (OutControl RTT1Level []) = do
exist <- atomically $ do
b1 <- not <$> isEmptyCryptoSTM conn
b2 <- not <$> isEmptyOutputSTM conn
b3 <- not <$> isEmptyStreamSTM conn
return (b1 || b2 || b3)
unless exist $ construct conn RTT1Level [] False >>= sendPacket conn
sendOutput conn (OutControl lvl frames) = do
mout <- tryPeekOutput conn
case mout of
Just (OutControl lvl' frames')
| lvl == lvl' -> do
construct conn lvl (frames ++ frames') False >>= sendPacket conn
void $ atomically $ takeOutputSTM conn
_ -> construct conn lvl frames False >>= sendPacket conn
when (lvl == HandshakeLevel) $ discardClientInitialPacketNumberSpace conn
sendOutput conn (OutHandshake lcs0) = do
let convert = onTLSHandshakeCreated $ connHooks conn
(lcs, wait) = convert lcs0
-- only for h3spec
when wait $ wait0RTTReady conn
sendCryptoFragments conn lcs
when (any (\(l, _) -> l == HandshakeLevel) lcs) $
discardClientInitialPacketNumberSpace conn
sendOutput conn (OutRetrans (PlainPacket hdr0 plain0)) = do
frames <- adjustForRetransmit conn $ plainFrames plain0
let lvl = levelFromHeader hdr0
construct conn lvl frames False >>= sendPacket conn
levelFromHeader :: Header -> EncryptionLevel
levelFromHeader hdr
| lvl == RTT0Level = RTT1Level
| otherwise = lvl
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
adjustForRetransmit conn (x : xs) = do
rs <- adjustForRetransmit conn xs
return (x : rs)
limitationC :: Int
limitationC = 1024
thresholdC :: Int
thresholdC = 200
sendCryptoFragments :: Connection -> [(EncryptionLevel, CryptoData)] -> IO ()
sendCryptoFragments _ [] = return ()
sendCryptoFragments conn lcs = do
loop limitationC id lcs
where
multilevel = length lcs >= 2
loop
:: Int
-> ([SentPacket] -> [SentPacket])
-> [(EncryptionLevel, CryptoData)]
-> IO ()
loop _ build0 [] = do
let spkts0 = build0 []
unless (null spkts0) $ sendPacket conn spkts0
loop len0 build0 ((lvl, bs) : xs) | BS.length bs > len0 = do
let (target, rest) = BS.splitAt len0 bs
frame1 <- cryptoFrame conn target lvl
spkts1 <- construct conn lvl [frame1] multilevel
sendPacket conn $ build0 spkts1
-- to calculate multilevel again, let's call sendCryptoFragments
sendCryptoFragments conn ((lvl, rest) : xs)
loop _ build0 [(lvl, bs)] = do
frame1 <- cryptoFrame conn bs lvl
spkts1 <- construct conn lvl [frame1] multilevel
sendPacket conn $ build0 spkts1
loop len0 build0 ((lvl, bs) : xs) | len0 - BS.length bs < thresholdC = do
frame1 <- cryptoFrame conn bs lvl
spkts1 <- construct conn lvl [frame1] multilevel
sendPacket conn $ build0 spkts1
loop limitationC id xs
loop len0 build0 ((lvl, bs) : xs) = do
frame1 <- cryptoFrame conn bs lvl
spkts1 <- construct conn lvl [frame1] multilevel
let len1 = len0 - BS.length bs
build1 = build0 . (spkts1 ++)
loop len1 build1 xs
----------------------------------------------------------------
threshold :: Int
threshold = 832
limitation :: Int
limitation = 1040
-- | Upper bound on what a stream frame takes on top of its data
streamFrameMaxOverhead :: Int
streamFrameMaxOverhead
= sum
[ 1 -- type
, 8 -- stream ID
, 8 -- offset
, 2 -- length
]
packFin :: Connection -> Stream -> Bool -> IO Bool
packFin _ _ True = return True
packFin conn s False = do
mx <- tryPeekSendStreamQ conn
case mx of
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
fin <- packFin conn s fin0
if len < limitation
then sendStreamSmall conn s dats fin len
else sendStreamLarge conn s dats fin
sendStreamSmall :: Connection -> Stream -> [StreamData] -> Bool -> Int -> IO ()
sendStreamSmall conn s0 dats0 fin0 len0 = do
off0 <- getTxStreamOffset s0 len0
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
ready <- isConnection1RTTReady conn
let lvl
| ready = RTT1Level
| otherwise = RTT0Level
construct conn lvl frames False >>= sendPacket conn
mapM_ syncFinTx streams
where
tryPeek = do
mx <- tryPeekSendStreamQ conn
case mx of
Nothing -> do
yield
tryPeekSendStreamQ conn
Just _ -> return mx
loop
:: Stream
-> Frame
-> Int
-> ([Frame] -> [Frame])
-> ([Stream] -> [Stream])
-> IO ([Frame], [Stream])
loop s frame total build sb = do
mx <- tryPeek
case mx of
Nothing -> return (build [frame], sb [])
Just (TxStreamData s1 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
| 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
then do
let (off, dats) = case frame of
StreamF _ o d _ -> (o, d)
_ -> error "sendStreamSmall"
frame1 = StreamF sid off (dats ++ dats1) fin1'
sb1 = if fin1' then sb . (s1 :) else sb
loop s1 frame1 total1 build sb1
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 [])
sendStreamLarge :: Connection -> Stream -> [ByteString] -> Bool -> IO ()
sendStreamLarge conn s dats0 fin0 = do
loop dats0
when fin0 $ syncFinTx s
where
sid = streamId s
loop [] = return ()
loop 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
let lvl
| ready = RTT1Level
| otherwise = RTT0Level
construct conn lvl [frame] False >>= sendPacket conn
loop dats2
-- Typical case: [3, 1024, 1024, 1024, 200]
splitChunks :: [ByteString] -> ([ByteString], [ByteString])
splitChunks bs0 = loop bs0 0 id
where
loop [] _ build = let curr = build [] in (curr, [])
loop bbs@(b : bs) siz0 build
| siz <= threshold = let build' = build . (b :) in loop bs siz build'
| siz <= limitation = let curr = build [b] in (curr, bs)
| len > limitation =
let (u, b') = BS.splitAt (limitation - siz0) b
curr = build [u]
bs' = b' : bs
in (curr, bs')
| otherwise = let curr = build [] in (curr, bbs)
where
len = BS.length b
siz = siz0 + len