{-# LANGUAGE ScopedTypeVariables #-}

-- Constants used in 'Ouroboros.Network.Diffusion'
module Cardano.Network.Diffusion.Policies where

import Control.Concurrent.Class.MonadSTM.Strict

import Cardano.Network.FetchMode (FetchMode (..), PraosFetchMode (..))
import Cardano.Network.PeerSelection.Churn (ChurnMode (..))
import Data.Map.Strict (Map)
import Ouroboros.Network.Block (SlotNo)
import Ouroboros.Network.Diffusion.Policies (deadlineHotScores,
           mkHotDemotionPolicy, optionalMerge, simplePeerSelectionPolicy)
import Ouroboros.Network.PeerSelection.Governor.Types
import Ouroboros.Network.PeerSelection.PeerMetric
import System.Random

simpleChurnModePeerSelectionPolicy
  :: forall m peerAddr.
    ( MonadSTM m
    , Ord peerAddr
    )
  => StrictTVar m StdGen
  -> STM m ChurnMode
  -> PeerMetrics m peerAddr
  -> PeerSelectionPolicy peerAddr m
simpleChurnModePeerSelectionPolicy :: forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> STM m ChurnMode
-> PeerMetrics m peerAddr
-> PeerSelectionPolicy peerAddr m
simpleChurnModePeerSelectionPolicy StrictTVar m StdGen
rngVar STM m ChurnMode
getChurnMode PeerMetrics m peerAddr
metrics =
  (StrictTVar m StdGen
-> PeerMetrics m peerAddr -> PeerSelectionPolicy peerAddr m
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> PeerMetrics m peerAddr -> PeerSelectionPolicy peerAddr m
simplePeerSelectionPolicy StrictTVar m StdGen
rngVar PeerMetrics m peerAddr
metrics) {
    policyPickHotPeersToDemote = mkHotDemotionPolicy rngVar hotScores
  }
  where
    -- The score this policy ranks hot peers by for demotion: in deadline mode
    -- the peer's 'upstreamyness' plus its 'fetchynessBlocks', while syncing
    -- its 'fetchynessBytes', with 'joinedPeerMetricAt' as the tie-break.
    hotScores :: STM m (Map peerAddr (Int, Maybe SlotNo))
    hotScores :: STM m (Map peerAddr (Int, Maybe SlotNo))
hotScores = do
        mode <- STM m ChurnMode
getChurnMode
        case mode of
             ChurnMode (PraosFetchMode PraosFetchMode
FetchModeDeadline) ->
                 PeerMetrics m peerAddr -> STM m (Map peerAddr (Int, Maybe SlotNo))
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
PeerMetrics m peerAddr -> STM m (Map peerAddr (Int, Maybe SlotNo))
deadlineHotScores PeerMetrics m peerAddr
metrics
             ChurnMode (PraosFetchMode PraosFetchMode
FetchModeBulkSync) ->
                 STM m (Map peerAddr (Int, Maybe SlotNo))
bytesScores
             ChurnMode FetchMode
GenesisFetchMode ->
                 STM m (Map peerAddr (Int, Maybe SlotNo))
bytesScores

    bytesScores :: STM m (Map peerAddr (Int, Maybe SlotNo))
    bytesScores :: STM m (Map peerAddr (Int, Maybe SlotNo))
bytesScores = do
        jpm <- PeerMetrics m peerAddr -> STM m (Map peerAddr SlotNo)
forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> STM m (Map p SlotNo)
joinedPeerMetricAt PeerMetrics m peerAddr
metrics
        bup <- fetchynessBytes metrics
        return $ bup `optionalMerge` jpm