Release.hs

{-# LANGUAGE RecordWildCards #-}

module Network.QUIC.Recovery.Release (
    releaseByRetry,
    releaseOldest,
    discard,
    onPacketsLost,
) where

import Control.Concurrent.STM
import Data.Sequence (Seq, ViewL (..), ViewR (..), (><))
import qualified Data.Sequence as Seq

import Network.QUIC.Imports
import Network.QUIC.Recovery.Metrics
import Network.QUIC.Recovery.PeerPacketNumbers
import Network.QUIC.Recovery.Types
import Network.QUIC.Recovery.Utils
import Network.QUIC.Types

----------------------------------------------------------------

discard :: LDCC -> EncryptionLevel -> IO (Seq SentPacket)
discard ldcc@LDCC{..} lvl = do
    packets <- releaseByClear ldcc lvl
    decreaseCC ldcc packets
    writeIORef (lossDetection ! lvl) initialLossDetection
    metricsUpdated ldcc $
        atomicModifyIORef'' recoveryRTT $
            \rtt -> rtt{ptoCount = 0}
    return packets

releaseByClear :: LDCC -> EncryptionLevel -> IO (Seq SentPacket)
releaseByClear ldcc@LDCC{..} lvl = do
    clearPeerPacketNumbers ldcc lvl
    atomicModifyIORef' (sentPackets ! lvl) $ \(SentPackets db) ->
        (emptySentPackets, db)

----------------------------------------------------------------

releaseByRetry :: LDCC -> IO (Seq PlainPacket)
releaseByRetry ldcc = do
    packets <- discard ldcc InitialLevel
    return (spPlainPacket <$> packets)

-- Returning the oldest if it is ack-eliciting.
releaseOldest :: LDCC -> EncryptionLevel -> IO (Maybe SentPacket)
releaseOldest ldcc@LDCC{..} lvl = do
    mr <- atomicModifyIORef' (sentPackets ! lvl) oldest
    case mr of
        Nothing -> return ()
        Just spkt -> decreaseCC ldcc [spkt]
    return mr
  where
    oldest (SentPackets db) = case Seq.viewl db2 of
        x :< db2' ->
            let db' = db1 >< db2'
             in (SentPackets db', Just x)
        _ -> (SentPackets db, Nothing)
      where
        (db1, db2) = Seq.breakl spAckEliciting db

----------------------------------------------------------------

onPacketsLost :: LDCC -> Seq SentPacket -> IO ()
onPacketsLost ldcc@LDCC{..} lostPackets = do
    decreaseCC ldcc lostPackets
    -- RFC 9002 B.8: only packets in flight make a congestion event.  An
    -- ACK-only packet lost used to halve the window.
    case Seq.viewr inflight of
        EmptyR -> return ()
        _ :> lastPkt -> do
            isRecovery <-
                inCongestionRecovery (spTimeSent lastPkt) . congestionRecoveryStartTime
                    <$> readTVarIO recoveryCC
            onCongestionEvent ldcc inflight isRecovery
    mapM_ (qlogPacketLost ldcc . LostPacket) lostPackets
  where
    inflight = Seq.filter ((> 0) . inFlightBytes) lostPackets
    onCongestionEvent = updateCC

----------------------------------------------------------------

decreaseCC :: (Functor m, Foldable m) => LDCC -> m SentPacket -> IO ()
decreaseCC ldcc@LDCC{..} packets = do
    let sentBytes = sum' (inFlightBytes <$> packets)
        num = sum' (countAckEli <$> packets)
    metricsUpdated ldcc $
        atomically $
            modifyTVar' recoveryCC $ \cc ->
                cc
                    { bytesInFlight = bytesInFlight cc - sentBytes
                    , numOfAckEliciting = numOfAckEliciting cc - num
                    }