Detect.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.QUIC.Recovery.Detect (
    releaseByPredicate,
    detectAndRemoveLostPackets,
    removePacketNumbers,
) where

import Data.Sequence (Seq, ViewL (..))
import qualified Data.Sequence as Seq

import Network.QUIC.Imports
import Network.QUIC.Qlog
import Network.QUIC.Recovery.Constants
import Network.QUIC.Recovery.PeerPacketNumbers
import Network.QUIC.Recovery.Types
import Network.QUIC.Types

releaseByPredicate
    :: LDCC -> EncryptionLevel -> (SentPacket -> Bool) -> IO (Seq SentPacket)
releaseByPredicate ldcc@LDCC{..} lvl predicate = do
    packets <- atomicModifyIORef' (sentPackets ! lvl) $ \(SentPackets db) ->
        let (pkts, db') = Seq.partition predicate db
         in (SentPackets db', pkts)
    removePacketNumbers ldcc lvl packets
    return packets

detectAndRemoveLostPackets :: LDCC -> EncryptionLevel -> IO (Seq SentPacket)
detectAndRemoveLostPackets ldcc@LDCC{..} lvl = do
    lae <- timeOfLastAckElicitingPacket <$> readIORef (lossDetection ! lvl)
    when (lae == timeMicrosecond0) $
        qlogDebug ldcc $
            Debug "detectAndRemoveLostPackets: timeOfLastAckElicitingPacket: 0"
    atomicModifyIORef'' (lossDetection ! lvl) $ \ld ->
        ld
            { lossTime = Nothing
            }
    RTT{..} <- readIORef recoveryRTT
    LossDetection{..} <- readIORef (lossDetection ! lvl)
    when (largestAckedPacket == -1) $
        qlogDebug ldcc $
            Debug "detectAndRemoveLostPackets: largestAckedPacket: -1"
    -- Sec 6.1.2. Time Threshold
    -- max(kTimeThreshold * max(smoothed_rtt, latest_rtt), kGranularity)
    let lossDelay0 = kTimeThreshold $ max latestRTT smoothedRTT
    let lossDelay = max lossDelay0 kGranularity

    tm <- getPastTimeMicrosecond lossDelay
    let predicate ent =
            (spPacketNumber ent <= largestAckedPacket - kPacketThreshold)
                || (spPacketNumber ent <= largestAckedPacket && spTimeSent ent <= tm)
    lostPackets <- releaseByPredicate ldcc lvl predicate

    mx <- findOldest ldcc lvl (\x -> spPacketNumber x <= largestAckedPacket)
    case mx of
        -- No gap packet. PTO turn.
        Nothing -> return ()
        -- There are gap packets which are not declared lost.
        -- Set lossTime to next.
        Just x -> do
            let next = spTimeSent x `addMicroseconds` lossDelay
            atomicModifyIORef'' (lossDetection ! lvl) $ \ld ->
                ld
                    { lossTime = Just next
                    }

    unless (Seq.null lostPackets) $ qlogDebug ldcc $ Debug "loss detected"
    return lostPackets

findOldest
    :: LDCC
    -> EncryptionLevel
    -> (SentPacket -> Bool)
    -> IO (Maybe SentPacket)
findOldest LDCC{..} lvl p = oldest <$> readIORef (sentPackets ! lvl)
  where
    oldest (SentPackets db) = case Seq.viewl $ Seq.filter p db of
        EmptyL -> Nothing
        x :< _ -> Just x

removePacketNumbers
    :: Foldable t => LDCC -> EncryptionLevel -> t SentPacket -> IO ()
removePacketNumbers ldcc lvl packets = mapM_ reduce packets
  where
    reduce x = reducePeerPacketNumbers ldcc lvl ppns
      where
        ppns = spPeerPacketNumbers x