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