{-# LANGUAGE ScopedTypeVariables #-}

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

import Control.Concurrent.Class.MonadSTM.Strict

import Data.List (sortOn)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Ouroboros.Cardano.Network.Types (ChurnMode (..))
import Ouroboros.Network.Diffusion.Policies (addRand, optionalMerge,
           simplePeerSelectionPolicy)
import Ouroboros.Network.ExitPolicy
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
  -> RepromoteDelay
  -- ^ delay on error
  -> PeerSelectionPolicy peerAddr m
simpleChurnModePeerSelectionPolicy :: forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> STM m ChurnMode
-> PeerMetrics m peerAddr
-> RepromoteDelay
-> PeerSelectionPolicy peerAddr m
simpleChurnModePeerSelectionPolicy StrictTVar m StdGen
rngVar STM m ChurnMode
getChurnMode PeerMetrics m peerAddr
metrics RepromoteDelay
errorDelay =
  (StrictTVar m StdGen
-> PeerMetrics m peerAddr
-> RepromoteDelay
-> PeerSelectionPolicy peerAddr m
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> PeerMetrics m peerAddr
-> RepromoteDelay
-> PeerSelectionPolicy peerAddr m
simplePeerSelectionPolicy StrictTVar m StdGen
rngVar PeerMetrics m peerAddr
metrics RepromoteDelay
errorDelay) {
    policyPickHotPeersToDemote = hotDemotionPolicy
  }
  where
    hotDemotionPolicy :: PickPolicy peerAddr (STM m)
    hotDemotionPolicy :: PickPolicy peerAddr (STM m)
hotDemotionPolicy peerAddr -> PeerSource
_ peerAddr -> Int
_ peerAddr -> Bool
_ Set peerAddr
available Int
pickNum = do
        mode <- STM m ChurnMode
getChurnMode
        scores <- case mode of
                       ChurnMode
ChurnModeNormal -> 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
                           hup <- upstreamyness metrics
                           bup <- fetchynessBlocks metrics
                           return $ Map.unionWith (+) hup bup `optionalMerge` jpm

                       ChurnMode
ChurnModeBulkSync -> 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

        available' <- addRand rngVar available (,)
        return $ Set.fromList
             . map fst
             . take pickNum
               -- order the results, resolve the ties using slot number when
               -- a peer joined the leader board.
               --
               -- note: this will prefer to preserve newer peers, whose results
               -- less certain than peers who entered leader board earlier.
             . sortOn (\(peerAddr
peer, Word32
rn) ->
                          ((Int, Maybe SlotNo)
-> peerAddr
-> Map peerAddr (Int, Maybe SlotNo)
-> (Int, Maybe SlotNo)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Int
0, Maybe SlotNo
forall a. Maybe a
Nothing) peerAddr
peer Map peerAddr (Int, Maybe SlotNo)
scores, Word32
rn))
             . Map.assocs
             $ available'