-- | GossipSub peer scoring (P1-P7) per docs/11-pubsub.md.
--
-- Score formula:
--   Score(p) = TopicCap(Sum(t_i * (w1*P1 + w2*P2 + w3*P3 + w3b*P3b + w4*P4)))
--              + w5*P5 + w6*P6 + w7*P7
--
-- All penalty parameters (P3, P3b, P4, P6, P7) use quadratic escalation:
-- the score contribution is the square of the deficit/counter, mixed with
-- a negative weight. This makes small deficits tolerable but large ones
-- devastating.
module Network.LibP2P.Protocol.GossipSub.Score
  ( -- * Individual score components
    computeP1
  , computeP2
  , computeP3
  , computeP3b
  , computeP4
  , computeP6
  , computeP7
    -- * Aggregate score
  , computeScore
    -- * Decay
  , decayCounter
  , decayPeerCounters
    -- * Counter recording
  , recordFirstDelivery
  , recordMeshDelivery
  , recordInvalidMessage
  , recordMeshFailure
  , addP7Penalty
  ) where

import Data.ByteString (ByteString)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Time (UTCTime, diffUTCTime)
import Network.LibP2P.Crypto.PeerId (PeerId)
import Network.LibP2P.Protocol.GossipSub.Types

-- | P1: Time in Mesh. Returns min(meshTime/quantum, cap).
-- Only counts when peer is actually in mesh.
computeP1 :: TopicScoreParams -> TopicPeerState -> Double
computeP1 :: TopicScoreParams -> TopicPeerState -> Double
computeP1 TopicScoreParams
tsp TopicPeerState
tps
  | Bool -> Bool
not (TopicPeerState -> Bool
tpsInMesh TopicPeerState
tps) = Double
0
  | Bool
otherwise =
      let meshTime :: Double
meshTime = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (TopicPeerState -> NominalDiffTime
tpsMeshTime TopicPeerState
tps) :: Double
          quantum :: Double
quantum = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (TopicScoreParams -> NominalDiffTime
tspTimeInMeshQuantum TopicScoreParams
tsp) :: Double
          raw :: Double
raw = if Double
quantum Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then Double
meshTime Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
quantum else Double
0
      in Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
raw (TopicScoreParams -> Double
tspTimeInMeshCap TopicScoreParams
tsp)

-- | P2: First Message Deliveries. Returns min(counter, cap).
computeP2 :: TopicScoreParams -> TopicPeerState -> Double
computeP2 :: TopicScoreParams -> TopicPeerState -> Double
computeP2 TopicScoreParams
tsp TopicPeerState
tps = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (TopicPeerState -> Double
tpsFirstMessageDeliveries TopicPeerState
tps) (TopicScoreParams -> Double
tspFirstMessageDeliveriesCap TopicScoreParams
tsp)

-- | P3: Mesh Message Deliveries. Returns deficit^2 when activated and below threshold.
-- The weight (negative) is applied externally in computeScore.
computeP3 :: TopicScoreParams -> TopicPeerState -> UTCTime -> Double
computeP3 :: TopicScoreParams -> TopicPeerState -> UTCTime -> Double
computeP3 TopicScoreParams
tsp TopicPeerState
tps UTCTime
now
  | Bool -> Bool
not (TopicPeerState -> Bool
tpsInMesh TopicPeerState
tps) = Double
0
  | Bool -> Bool
not Bool
activated = Double
0
  | Double
deficit Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 = Double
0
  | Bool
otherwise = Double
deficit Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
deficit
  where
    activated :: Bool
activated = case TopicPeerState -> Maybe UTCTime
tpsGraftTime TopicPeerState
tps of
      Maybe UTCTime
Nothing -> Bool
False
      Just UTCTime
gt ->
        let elapsed :: NominalDiffTime
elapsed = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
gt
        in NominalDiffTime
elapsed NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= TopicScoreParams -> NominalDiffTime
tspMeshMessageDeliveriesActivation TopicScoreParams
tsp
    threshold :: Double
threshold = TopicScoreParams -> Double
tspMeshMessageDeliveriesThreshold TopicScoreParams
tsp
    deliveries :: Double
deliveries = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (TopicPeerState -> Double
tpsMeshMessageDeliveries TopicPeerState
tps) (TopicScoreParams -> Double
tspMeshMessageDeliveriesCap TopicScoreParams
tsp)
    deficit :: Double
deficit = Double
threshold Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
deliveries

-- | P3b: Mesh Failure Penalty. Returns the stored penalty value (already squared at capture time).
computeP3b :: TopicPeerState -> Double
computeP3b :: TopicPeerState -> Double
computeP3b = TopicPeerState -> Double
tpsMeshFailurePenalty

-- | P4: Invalid Messages. Returns counter^2.
computeP4 :: TopicPeerState -> Double
computeP4 :: TopicPeerState -> Double
computeP4 TopicPeerState
tps = TopicPeerState -> Double
tpsInvalidMessages TopicPeerState
tps Double -> Double -> Double
forall a. Num a => a -> a -> a
* TopicPeerState -> Double
tpsInvalidMessages TopicPeerState
tps

-- | P6: IP Colocation Factor. Returns (count - threshold)^2 if count > threshold, else 0.
computeP6 :: PeerScoreParams -> PeerState -> Map.Map ByteString (Set.Set PeerId) -> Double
computeP6 :: PeerScoreParams
-> PeerState -> Map ByteString (Set PeerId) -> Double
computeP6 PeerScoreParams
params PeerState
ps Map ByteString (Set PeerId)
ipMap = case PeerState -> Maybe ByteString
psIPAddress PeerState
ps of
  Maybe ByteString
Nothing -> Double
0
  Just ByteString
ip ->
    let count :: Int
count = Int -> (Set PeerId -> Int) -> Maybe (Set PeerId) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Set PeerId -> Int
forall a. Set a -> Int
Set.size (ByteString -> Map ByteString (Set PeerId) -> Maybe (Set PeerId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
ip Map ByteString (Set PeerId)
ipMap)
        threshold :: Int
threshold = PeerScoreParams -> Int
pspIPColocationFactorThreshold PeerScoreParams
params
        excess :: Int
excess = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
threshold
    in if Int
excess Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
       then Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
excess Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
excess)
       else Double
0

-- | P7: Behavioral Penalty. Returns counter^2.
computeP7 :: PeerState -> Double
computeP7 :: PeerState -> Double
computeP7 PeerState
ps = PeerState -> Double
psBehaviorPenalty PeerState
ps Double -> Double -> Double
forall a. Num a => a -> a -> a
* PeerState -> Double
psBehaviorPenalty PeerState
ps

-- | Compute full peer score per the formula in docs/11-pubsub.md.
-- Takes explicit PeerId for the P5 application-specific callback.
computeScore :: PeerScoreParams -> PeerState -> Map.Map ByteString (Set.Set PeerId) -> UTCTime -> Double
computeScore :: PeerScoreParams
-> PeerState -> Map ByteString (Set PeerId) -> UTCTime -> Double
computeScore PeerScoreParams
params PeerState
ps Map ByteString (Set PeerId)
ipMap UTCTime
now =
  let -- Topic score: sum over topics
      topicScore :: Double
topicScore = (Double -> Topic -> TopicPeerState -> Double)
-> Double -> Map Topic TopicPeerState -> Double
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\Double
acc Topic
topic TopicPeerState
tps ->
        case Topic -> Map Topic TopicScoreParams -> Maybe TopicScoreParams
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Topic
topic (PeerScoreParams -> Map Topic TopicScoreParams
pspTopicParams PeerScoreParams
params) of
          Maybe TopicScoreParams
Nothing -> Double
acc  -- no params for this topic, skip
          Just TopicScoreParams
tsp ->
            let p1 :: Double
p1 = TopicScoreParams -> Double
tspTimeInMeshWeight TopicScoreParams
tsp Double -> Double -> Double
forall a. Num a => a -> a -> a
* TopicScoreParams -> TopicPeerState -> Double
computeP1 TopicScoreParams
tsp TopicPeerState
tps
                p2 :: Double
p2 = TopicScoreParams -> Double
tspFirstMessageDeliveriesWeight TopicScoreParams
tsp Double -> Double -> Double
forall a. Num a => a -> a -> a
* TopicScoreParams -> TopicPeerState -> Double
computeP2 TopicScoreParams
tsp TopicPeerState
tps
                p3 :: Double
p3 = TopicScoreParams -> Double
tspMeshMessageDeliveriesWeight TopicScoreParams
tsp Double -> Double -> Double
forall a. Num a => a -> a -> a
* TopicScoreParams -> TopicPeerState -> UTCTime -> Double
computeP3 TopicScoreParams
tsp TopicPeerState
tps UTCTime
now
                p3b :: Double
p3b = TopicScoreParams -> Double
tspMeshFailurePenaltyWeight TopicScoreParams
tsp Double -> Double -> Double
forall a. Num a => a -> a -> a
* TopicPeerState -> Double
computeP3b TopicPeerState
tps
                p4 :: Double
p4 = TopicScoreParams -> Double
tspInvalidMessageDeliveriesWeight TopicScoreParams
tsp Double -> Double -> Double
forall a. Num a => a -> a -> a
* TopicPeerState -> Double
computeP4 TopicPeerState
tps
                topicContribution :: Double
topicContribution = TopicScoreParams -> Double
tspTopicWeight TopicScoreParams
tsp Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
p1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
p2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
p3 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
p3b Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
p4)
            in Double
acc Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
topicContribution
        ) Double
0 (PeerState -> Map Topic TopicPeerState
psTopicState PeerState
ps)

      -- Apply TopicScoreCap
      cappedTopicScore :: Double
cappedTopicScore =
        let cap :: Double
cap = PeerScoreParams -> Double
pspTopicScoreCap PeerScoreParams
params
        in if Double
cap Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double
topicScore Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
cap
           then Double
cap
           else Double
topicScore

      -- P5: not computed here (requires PeerId from router context).
      -- Use computeScoreForPeer in Router for full P5 support.

      -- P6: IP colocation
      p6 :: Double
p6 = PeerScoreParams -> Double
pspIPColocationFactorWeight PeerScoreParams
params Double -> Double -> Double
forall a. Num a => a -> a -> a
* PeerScoreParams
-> PeerState -> Map ByteString (Set PeerId) -> Double
computeP6 PeerScoreParams
params PeerState
ps Map ByteString (Set PeerId)
ipMap

      -- P7: behavioral penalty
      p7 :: Double
p7 = PeerScoreParams -> Double
pspBehaviorPenaltyWeight PeerScoreParams
params Double -> Double -> Double
forall a. Num a => a -> a -> a
* PeerState -> Double
computeP7 PeerState
ps

  in Double
cappedTopicScore Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
p6 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
p7

-- Decay

-- | Decay a single counter by a factor.
decayCounter :: Double -> Double -> Double
decayCounter :: Double -> Double -> Double
decayCounter Double
factor Double
value = Double
value Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
factor

-- | Apply counter decay to all scoring counters in a PeerState.
decayPeerCounters :: PeerScoreParams -> PeerState -> PeerState
decayPeerCounters :: PeerScoreParams -> PeerState -> PeerState
decayPeerCounters PeerScoreParams
params PeerState
ps =
  let decayToZero :: Double
decayToZero = PeerScoreParams -> Double
pspDecayToZero PeerScoreParams
params
      zeroCheck :: Double -> Double
zeroCheck Double
v = if Double -> Double
forall a. Num a => a -> a
abs Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
decayToZero then Double
0 else Double
v

      -- Decay topic-level counters
      decayedTopicState :: Map Topic TopicPeerState
decayedTopicState = (Topic -> TopicPeerState -> TopicPeerState)
-> Map Topic TopicPeerState -> Map Topic TopicPeerState
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\Topic
topic TopicPeerState
tps ->
        case Topic -> Map Topic TopicScoreParams -> Maybe TopicScoreParams
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Topic
topic (PeerScoreParams -> Map Topic TopicScoreParams
pspTopicParams PeerScoreParams
params) of
          Maybe TopicScoreParams
Nothing -> TopicPeerState
tps
          Just TopicScoreParams
tsp -> TopicPeerState
tps
            { tpsFirstMessageDeliveries =
                zeroCheck $ decayCounter (tspFirstMessageDeliveriesDecay tsp) (tpsFirstMessageDeliveries tps)
            , tpsMeshMessageDeliveries =
                zeroCheck $ decayCounter (tspMeshMessageDeliveriesDecay tsp) (tpsMeshMessageDeliveries tps)
            , tpsMeshFailurePenalty =
                zeroCheck $ decayCounter (tspMeshFailurePenaltyDecay tsp) (tpsMeshFailurePenalty tps)
            , tpsInvalidMessages =
                zeroCheck $ decayCounter (tspInvalidMessageDeliveriesDecay tsp) (tpsInvalidMessages tps)
            }
        ) (PeerState -> Map Topic TopicPeerState
psTopicState PeerState
ps)

      -- Decay P7 (behavioral penalty)
      decayedP7 :: Double
decayedP7 = Double -> Double
zeroCheck (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
decayCounter (PeerScoreParams -> Double
pspBehaviorPenaltyDecay PeerScoreParams
params) (PeerState -> Double
psBehaviorPenalty PeerState
ps)

  in PeerState
ps { psTopicState = decayedTopicState, psBehaviorPenalty = decayedP7 }

-- Counter recording

-- | Record a first message delivery for a topic (P2 increment, capped).
recordFirstDelivery :: TopicScoreParams -> TopicPeerState -> TopicPeerState
recordFirstDelivery :: TopicScoreParams -> TopicPeerState -> TopicPeerState
recordFirstDelivery TopicScoreParams
tsp TopicPeerState
tps =
  let current :: Double
current = TopicPeerState -> Double
tpsFirstMessageDeliveries TopicPeerState
tps
      cap :: Double
cap = TopicScoreParams -> Double
tspFirstMessageDeliveriesCap TopicScoreParams
tsp
  in TopicPeerState
tps { tpsFirstMessageDeliveries = min (current + 1) cap }

-- | Record a mesh message delivery (P3 increment, capped).
recordMeshDelivery :: TopicScoreParams -> TopicPeerState -> TopicPeerState
recordMeshDelivery :: TopicScoreParams -> TopicPeerState -> TopicPeerState
recordMeshDelivery TopicScoreParams
tsp TopicPeerState
tps =
  let current :: Double
current = TopicPeerState -> Double
tpsMeshMessageDeliveries TopicPeerState
tps
      cap :: Double
cap = TopicScoreParams -> Double
tspMeshMessageDeliveriesCap TopicScoreParams
tsp
  in TopicPeerState
tps { tpsMeshMessageDeliveries = min (current + 1) cap }

-- | Record an invalid message delivery (P4 increment).
recordInvalidMessage :: TopicPeerState -> TopicPeerState
recordInvalidMessage :: TopicPeerState -> TopicPeerState
recordInvalidMessage TopicPeerState
tps =
  TopicPeerState
tps { tpsInvalidMessages = tpsInvalidMessages tps + 1 }

-- | Record a mesh failure (P3b): capture deficit^2 at prune time.
-- deficit = threshold - deliveries (clamped to >= 0).
recordMeshFailure :: TopicScoreParams -> TopicPeerState -> TopicPeerState
recordMeshFailure :: TopicScoreParams -> TopicPeerState -> TopicPeerState
recordMeshFailure TopicScoreParams
tsp TopicPeerState
tps =
  let threshold :: Double
threshold = TopicScoreParams -> Double
tspMeshMessageDeliveriesThreshold TopicScoreParams
tsp
      deliveries :: Double
deliveries = TopicPeerState -> Double
tpsMeshMessageDeliveries TopicPeerState
tps
      deficit :: Double
deficit = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double
threshold Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
deliveries)
  in TopicPeerState
tps { tpsMeshFailurePenalty = tpsMeshFailurePenalty tps + deficit * deficit }

-- | Increment P7 behavioral penalty counter by 1.
addP7Penalty :: PeerState -> PeerState
addP7Penalty :: PeerState -> PeerState
addP7Penalty PeerState
ps = PeerState
ps { psBehaviorPenalty = psBehaviorPenalty ps + 1 }