{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE ScopedTypeVariables   #-}

#if __GLASGOW_HASKELL__ < 904
{-# OPTIONS_GHC -Wno-name-shadowing #-}
#endif

-- | This subsystem manages the discovery and selection of /upstream/ peers.
--
module Ouroboros.Network.PeerSelection.Churn
  ( PeerChurnArgs (..)
  , ChurnCounters (..)
  , peerChurnGovernor
  ) where

import Data.Void (Void)

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer (..), traceWith)
import System.Random

import Control.Applicative (Alternative)
import Data.Functor (($>))
import Data.Monoid.Synchronisation (FirstToFinish (..))
import Ouroboros.Network.BlockFetch (FetchMode (..))
import Ouroboros.Network.ConsensusMode (ConsensusMode (..))
import Ouroboros.Network.Diffusion.Policies (churnEstablishConnectionTimeout,
           closeConnectionTimeout, deactivateTimeout)
import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
import Ouroboros.Network.PeerSelection.Governor.Types hiding (targets)
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
import Ouroboros.Network.PeerSelection.PeerMetric
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..))

-- | Tag indicating churning approach
-- There are three syncing methods that networking layer supports, the legacy
-- method with or without bootstrap peers, and the Genesis method that relies
-- on chain skipping optimization courtesy of consensus, which also provides

--
data ChurnRegime = ChurnDefault
                 -- ^ tag to use Praos targets when caught up, or Genesis
                 -- targets when syncing in case that is the consensus mode
                 | ChurnPraosSync
                 -- ^ Praos targets to churn normally when syncing
                 | ChurnBootstrapPraosSync
                 -- ^ Praos targets further reduced to conserve resources
                 -- when syncing

getPeerSelectionTargets :: ConsensusMode -> LedgerStateJudgement -> ConsensusModePeerTargets -> PeerSelectionTargets
getPeerSelectionTargets :: ConsensusMode
-> LedgerStateJudgement
-> ConsensusModePeerTargets
-> PeerSelectionTargets
getPeerSelectionTargets ConsensusMode
consensus LedgerStateJudgement
lsj ConsensusModePeerTargets {
                                        PeerSelectionTargets
deadlineTargets :: PeerSelectionTargets
deadlineTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
deadlineTargets,
                                        PeerSelectionTargets
syncTargets :: PeerSelectionTargets
syncTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
syncTargets } =
  case (ConsensusMode
consensus, LedgerStateJudgement
lsj) of
    (ConsensusMode
GenesisMode, LedgerStateJudgement
TooOld) -> PeerSelectionTargets
syncTargets
    (ConsensusMode, LedgerStateJudgement)
_otherwise            -> PeerSelectionTargets
deadlineTargets

pickChurnRegime :: ConsensusMode -> ChurnMode -> UseBootstrapPeers -> ChurnRegime
pickChurnRegime :: ConsensusMode -> ChurnMode -> UseBootstrapPeers -> ChurnRegime
pickChurnRegime ConsensusMode
consensus ChurnMode
churn UseBootstrapPeers
ubp =
  case (ChurnMode
churn, UseBootstrapPeers
ubp, ConsensusMode
consensus) of
    (ChurnMode
ChurnModeNormal, UseBootstrapPeers
_, ConsensusMode
_)                     -> ChurnRegime
ChurnDefault
    (ChurnMode
_, UseBootstrapPeers
_, ConsensusMode
GenesisMode)                         -> ChurnRegime
ChurnDefault
    (ChurnMode
ChurnModeBulkSync, UseBootstrapPeers [RelayAccessPoint]
_, ConsensusMode
_) -> ChurnRegime
ChurnBootstrapPraosSync
    (ChurnMode
ChurnModeBulkSync, UseBootstrapPeers
_, ConsensusMode
_)                   -> ChurnRegime
ChurnPraosSync

-- | Facilitates composing updates to various targets via back-to-back pipeline
type ModifyPeerSelectionTargets = PeerSelectionTargets -> PeerSelectionTargets
type CheckPeerSelectionCounters = PeerSelectionCounters -> PeerSelectionTargets -> Bool

data ChurnCounters = ChurnCounter ChurnAction Int

-- | Record of arguments for peer churn governor
--
data PeerChurnArgs m peeraddr = PeerChurnArgs {
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> Tracer m (TracePeerSelection peeraddr)
pcaPeerSelectionTracer :: Tracer m (TracePeerSelection peeraddr),
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> Tracer m ChurnCounters
pcaChurnTracer         :: Tracer m ChurnCounters,
  forall (m :: * -> *) peeraddr. PeerChurnArgs m peeraddr -> DiffTime
pcaDeadlineInterval    :: DiffTime,
  forall (m :: * -> *) peeraddr. PeerChurnArgs m peeraddr -> DiffTime
pcaBulkInterval        :: DiffTime,
  forall (m :: * -> *) peeraddr. PeerChurnArgs m peeraddr -> DiffTime
pcaPeerRequestTimeout  :: DiffTime,
  -- ^ the timeout for outbound governor to find new (thus
  -- cold) peers through peer sharing mechanism.
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> PeerMetrics m peeraddr
pcaMetrics             :: PeerMetrics m peeraddr,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> StrictTVar m ChurnMode
pcaModeVar             :: StrictTVar m ChurnMode,
  forall (m :: * -> *) peeraddr. PeerChurnArgs m peeraddr -> StdGen
pcaRng                 :: StdGen,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> STM m FetchMode
pcaReadFetchMode       :: STM m FetchMode,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> ConsensusModePeerTargets
peerTargets            :: ConsensusModePeerTargets,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> StrictTVar m PeerSelectionTargets
pcaPeerSelectionVar    :: StrictTVar m PeerSelectionTargets,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> STM m PeerSelectionCounters
pcaReadCounters        :: STM m PeerSelectionCounters,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> STM m UseBootstrapPeers
pcaReadUseBootstrap    :: STM m UseBootstrapPeers,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> ConsensusMode
pcaConsensusMode       :: ConsensusMode,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> LedgerPeersConsensusInterface m
getLedgerStateCtx      :: LedgerPeersConsensusInterface m,
  forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> STM m HotValency
getLocalRootHotTarget  :: STM m HotValency }

-- | Churn governor.
--
-- At every churn interval decrease active peers for a short while (1s), so that
-- we can pick new ones. Then we churn non-active peers.
--
-- On startup the churn governor gives a head start to local root peers over
-- root peers.
--
peerChurnGovernor :: forall m peeraddr.
                     ( MonadDelay m
                     , Alternative (STM m)
                     , MonadTimer m
                     , MonadCatch m
                     )
                  => PeerChurnArgs m peeraddr
                  -> m Void
peerChurnGovernor :: forall (m :: * -> *) peeraddr.
(MonadDelay m, Alternative (STM m), MonadTimer m, MonadCatch m) =>
PeerChurnArgs m peeraddr -> m Void
peerChurnGovernor PeerChurnArgs {
                    pcaPeerSelectionTracer :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> Tracer m (TracePeerSelection peeraddr)
pcaPeerSelectionTracer = Tracer m (TracePeerSelection peeraddr)
tracer,
                    pcaChurnTracer :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> Tracer m ChurnCounters
pcaChurnTracer         = Tracer m ChurnCounters
churnTracer,
                    pcaDeadlineInterval :: forall (m :: * -> *) peeraddr. PeerChurnArgs m peeraddr -> DiffTime
pcaDeadlineInterval    = DiffTime
deadlineChurnInterval,
                    pcaBulkInterval :: forall (m :: * -> *) peeraddr. PeerChurnArgs m peeraddr -> DiffTime
pcaBulkInterval        = DiffTime
bulkChurnInterval,
                    pcaPeerRequestTimeout :: forall (m :: * -> *) peeraddr. PeerChurnArgs m peeraddr -> DiffTime
pcaPeerRequestTimeout  = DiffTime
requestPeersTimeout,
                    pcaModeVar :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> StrictTVar m ChurnMode
pcaModeVar             = StrictTVar m ChurnMode
churnModeVar,
                    pcaRng :: forall (m :: * -> *) peeraddr. PeerChurnArgs m peeraddr -> StdGen
pcaRng                 = StdGen
inRng,
                    pcaReadFetchMode :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> STM m FetchMode
pcaReadFetchMode       = STM m FetchMode
getFetchMode,
                    ConsensusModePeerTargets
peerTargets :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> ConsensusModePeerTargets
peerTargets :: ConsensusModePeerTargets
peerTargets,
                    pcaPeerSelectionVar :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> StrictTVar m PeerSelectionTargets
pcaPeerSelectionVar    = StrictTVar m PeerSelectionTargets
peerSelectionVar,
                    pcaReadCounters :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> STM m PeerSelectionCounters
pcaReadCounters        = STM m PeerSelectionCounters
readCounters,
                    pcaReadUseBootstrap :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> STM m UseBootstrapPeers
pcaReadUseBootstrap    = STM m UseBootstrapPeers
getUseBootstrapPeers,
                    pcaConsensusMode :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> ConsensusMode
pcaConsensusMode       = ConsensusMode
consensusMode,
                    getLedgerStateCtx :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> LedgerPeersConsensusInterface m
getLedgerStateCtx = LedgerPeersConsensusInterface {
                        STM m LedgerStateJudgement
lpGetLedgerStateJudgement :: STM m LedgerStateJudgement
lpGetLedgerStateJudgement :: forall (m :: * -> *).
LedgerPeersConsensusInterface m -> STM m LedgerStateJudgement
lpGetLedgerStateJudgement },
                    STM m HotValency
getLocalRootHotTarget :: forall (m :: * -> *) peeraddr.
PeerChurnArgs m peeraddr -> STM m HotValency
getLocalRootHotTarget :: STM m HotValency
getLocalRootHotTarget } = do
  -- Wait a while so that not only the closest peers have had the time
  -- to become warm.
  startTs0 <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  -- TODO: revisit the policy once we have local root peers in the governor.
  -- The intention is to give local root peers give head start and avoid
  -- giving advantage to hostile and quick root peers.
  threadDelay 3
  atomically $ do
    (churnMode, ledgerStateJudgement, useBootstrapPeers, ltt)
      <- (,,,) <$> updateChurnMode <*> lpGetLedgerStateJudgement <*> getUseBootstrapPeers <*> getLocalRootHotTarget
    let regime  = ConsensusMode -> ChurnMode -> UseBootstrapPeers -> ChurnRegime
pickChurnRegime ConsensusMode
consensusMode ChurnMode
churnMode UseBootstrapPeers
useBootstrapPeers
        targets = ConsensusMode
-> LedgerStateJudgement
-> ConsensusModePeerTargets
-> PeerSelectionTargets
getPeerSelectionTargets ConsensusMode
consensusMode LedgerStateJudgement
ledgerStateJudgement ConsensusModePeerTargets
peerTargets

    modifyTVar peerSelectionVar ( increaseActivePeers regime ltt targets
                                . increaseEstablishedPeers regime ltt targets)

  endTs0 <- getMonotonicTime
  fuzzyDelay inRng (endTs0 `diffTime` startTs0) >>= churnLoop

  where
    updateChurnMode :: STM m ChurnMode
    updateChurnMode :: STM m ChurnMode
updateChurnMode = do
        fm <- STM m FetchMode
getFetchMode
        let mode = case FetchMode
fm of
                     FetchMode
FetchModeDeadline -> ChurnMode
ChurnModeNormal
                     FetchMode
FetchModeBulkSync -> ChurnMode
ChurnModeBulkSync
        writeTVar churnModeVar mode
        return mode

    -- | Update the targets to a given value, and block until they are reached.
    -- The time we are blocked is limited by a timeout.
    --
    updateTargets
      :: ChurnAction
      -- ^ churn actions for tracing
      -> (PeerSelectionCounters -> Int)
      -- ^ counter getter
      -> DiffTime
      -- ^ timeout
      -> (ChurnRegime -> HotValency -> PeerSelectionTargets -> ModifyPeerSelectionTargets)
      -- ^ update counters function
      -> CheckPeerSelectionCounters
      -- ^ check counters
      -> m ()
    updateTargets :: ChurnAction
-> (PeerSelectionCounters -> Int)
-> DiffTime
-> (ChurnRegime
    -> HotValency
    -> PeerSelectionTargets
    -> PeerSelectionTargets
    -> PeerSelectionTargets)
-> CheckPeerSelectionCounters
-> m ()
updateTargets ChurnAction
churnAction PeerSelectionCounters -> Int
getCounter DiffTime
timeoutDelay ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
modifyTargets CheckPeerSelectionCounters
checkCounters = do
      -- update targets, and return the new targets
      startTime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      (c, targets) <- atomically $ do
        churnMode <- updateChurnMode
        ltt       <- getLocalRootHotTarget
        lsj       <- lpGetLedgerStateJudgement
        regime    <- pickChurnRegime consensusMode churnMode <$> getUseBootstrapPeers
        let targets = ConsensusMode
-> LedgerStateJudgement
-> ConsensusModePeerTargets
-> PeerSelectionTargets
getPeerSelectionTargets ConsensusMode
consensusMode LedgerStateJudgement
lsj ConsensusModePeerTargets
peerTargets

        (,) <$> (getCounter <$> readCounters)
            <*> stateTVar peerSelectionVar ((\PeerSelectionTargets
a -> (PeerSelectionTargets
a, PeerSelectionTargets
a)) . modifyTargets regime ltt targets)

      -- create timeout and block on counters
      bracketOnError (registerDelayCancellable timeoutDelay)
                     (\(STM m TimeoutState
_readTimeout, m ()
cancelTimeout) -> m ()
cancelTimeout)
                     (\( STM m TimeoutState
readTimeout, m ()
cancelTimeout) -> do
                         -- block until counters reached the targets, or the timeout fires
                         a <- STM m (Either Int Int) -> m (Either Int Int)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either Int Int) -> m (Either Int Int))
-> STM m (Either Int Int) -> m (Either Int Int)
forall a b. (a -> b) -> a -> b
$ do
                                counters <- STM m PeerSelectionCounters
readCounters
                                runFirstToFinish $
                                  FirstToFinish (check (checkCounters counters targets) $> (Right $ getCounter counters ))
                                  <>
                                  FirstToFinish (readTimeout >>= \case TimeoutState
TimeoutPending -> STM m (Either Int Int)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                                                                       TimeoutState
_              -> Either Int Int -> STM m (Either Int Int)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Either Int Int
forall a b. a -> Either a b
Left (Int -> Either Int Int) -> Int -> Either Int Int
forall a b. (a -> b) -> a -> b
$ PeerSelectionCounters -> Int
getCounter PeerSelectionCounters
counters))
                         case a of
                           Right Int
c' -> do
                             let r :: Int
r = Int
c' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c
                             endTime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
                             traceWith tracer (TraceChurnAction (endTime `diffTime` startTime) churnAction r)
                             traceWith churnTracer (ChurnCounter churnAction r)
                           Left Int
c' -> do
                             endTime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
                             cancelTimeout
                             let r = Int
c' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c
                             traceWith tracer (TraceChurnTimeout (endTime `diffTime` startTime) churnAction r)
                             traceWith churnTracer (ChurnCounter churnAction r)
                     )

    --
    -- Functions to modify `PeerSelectionTargets` and check
    -- `PeerSelectionCounters`.
    --

    -- TODO: #3396 revisit the policy for genesis
    increaseActivePeers :: ChurnRegime
                        -> HotValency
                        -> PeerSelectionTargets
                        -> ModifyPeerSelectionTargets
    increaseActivePeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
increaseActivePeers ChurnRegime
regime (HotValency Int
ltt) PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfActivePeers =
          case regime of
            ChurnRegime
ChurnDefault -> PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
base
            ChurnRegime
_otherwise   -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ((Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
ltt) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
base) }

    checkActivePeersIncreased :: CheckPeerSelectionCounters
    checkActivePeersIncreased :: CheckPeerSelectionCounters
checkActivePeersIncreased
      PeerSelectionCounters { Int
numberOfActivePeers :: Int
numberOfActivePeers :: PeerSelectionCounters -> Int
numberOfActivePeers }
      PeerSelectionTargets { Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers }
      =
      Int
numberOfActivePeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
targetNumberOfActivePeers

    decreaseActivePeers :: ChurnRegime
                        -> HotValency
                        -> PeerSelectionTargets
                        -> ModifyPeerSelectionTargets
    decreaseActivePeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
decreaseActivePeers ChurnRegime
regime (HotValency Int
ltt) PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfActivePeers =
          case regime of
            ChurnRegime
ChurnDefault -> Int -> Int
decrease (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
base
            ChurnRegime
_otherwise   -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
ltt) (PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
base Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) }

    checkActivePeersDecreased :: CheckPeerSelectionCounters
    checkActivePeersDecreased :: CheckPeerSelectionCounters
checkActivePeersDecreased
      PeerSelectionCounters { Int
numberOfActivePeers :: PeerSelectionCounters -> Int
numberOfActivePeers :: Int
numberOfActivePeers }
      PeerSelectionTargets { Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers }
      =
         Int
numberOfActivePeers
      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfActivePeers

    increaseEstablishedPeers :: ChurnRegime
                             -> HotValency
                             -> PeerSelectionTargets
                             -> ModifyPeerSelectionTargets
    increaseEstablishedPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
increaseEstablishedPeers ChurnRegime
regime HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfEstablishedPeers =
          case regime of
            ChurnRegime
ChurnBootstrapPraosSync -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
targets Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                                           (PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers PeerSelectionTargets
base)
            -- ^ In this mode, we are only connected to a handful of bootstrap peers.
            -- The original churn strategy was to increase the targets by small
            -- fixed amount (e.g. 1). Therefore, we use
            -- targets to calculate the upper bound, ie. active + 1 here.
            ChurnRegime
_otherwise -> PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers PeerSelectionTargets
base }

    checkEstablishedPeersIncreased :: CheckPeerSelectionCounters
    checkEstablishedPeersIncreased :: CheckPeerSelectionCounters
checkEstablishedPeersIncreased
      PeerSelectionCounters { Int
numberOfEstablishedPeers :: Int
numberOfEstablishedPeers :: PeerSelectionCounters -> Int
numberOfEstablishedPeers }
      PeerSelectionTargets { Int
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers }
      =
         Int
numberOfEstablishedPeers
      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
targetNumberOfEstablishedPeers

    increaseEstablishedBigLedgerPeers
      :: ChurnRegime
      -> HotValency
      -> PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    increaseEstablishedBigLedgerPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
increaseEstablishedBigLedgerPeers ChurnRegime
_ HotValency
_ PeerSelectionTargets
base
      PeerSelectionTargets
targets
      =
      PeerSelectionTargets
targets { targetNumberOfEstablishedBigLedgerPeers = targetNumberOfEstablishedBigLedgerPeers base }

    checkEstablishedBigLedgerPeersIncreased
      :: CheckPeerSelectionCounters
    checkEstablishedBigLedgerPeersIncreased :: CheckPeerSelectionCounters
checkEstablishedBigLedgerPeersIncreased
      PeerSelectionCounters { Int
numberOfEstablishedBigLedgerPeers :: Int
numberOfEstablishedBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfEstablishedBigLedgerPeers }
      PeerSelectionTargets { Int
targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers }
      =
      Int
numberOfEstablishedBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
targetNumberOfEstablishedBigLedgerPeers

    decreaseEstablishedPeers
      :: ChurnRegime
      -> HotValency
      -> PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    decreaseEstablishedPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
decreaseEstablishedPeers ChurnRegime
regime HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfEstablishedPeers =
          case regime of
            ChurnRegime
ChurnBootstrapPraosSync -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
targets)
                                           (PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers PeerSelectionTargets
base Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            -- ^ In this mode, we are only connected to a handful of bootstrap peers.
            -- The original churn strategy was to decrease the targets by small
            -- fixed amount (e.g. 1) and then increase it back, and to churn out
            -- all warm peers to speed up the time to find the best performers.
            -- That is why we use the number of active peers in current targets
            -- as the upper bound on the number of established peers during this action.
            ChurnRegime
_otherwise ->   Int -> Int
decrease (PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers PeerSelectionTargets
base Int -> Int -> Int
forall a. Num a => a -> a -> a
- PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
base)
                          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
base }

    checkEstablishedPeersDecreased
      :: CheckPeerSelectionCounters
    checkEstablishedPeersDecreased :: CheckPeerSelectionCounters
checkEstablishedPeersDecreased
      PeerSelectionCounters { Int
numberOfEstablishedPeers :: PeerSelectionCounters -> Int
numberOfEstablishedPeers :: Int
numberOfEstablishedPeers }
      PeerSelectionTargets { Int
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers }
      =
         Int
numberOfEstablishedPeers
      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfEstablishedPeers

    increaseActiveBigLedgerPeers :: ChurnRegime
                                 -> HotValency
                                 -> PeerSelectionTargets
                                 -> ModifyPeerSelectionTargets
    increaseActiveBigLedgerPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
increaseActiveBigLedgerPeers ChurnRegime
regime HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfActiveBigLedgerPeers =
          let praosSyncTargets = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers PeerSelectionTargets
base)
          in case regime of
               ChurnRegime
ChurnBootstrapPraosSync -> Int
praosSyncTargets
               ChurnRegime
ChurnPraosSync -> Int
praosSyncTargets
               ChurnRegime
ChurnDefault -> PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers PeerSelectionTargets
base }

    checkActiveBigLedgerPeersIncreased
      :: CheckPeerSelectionCounters
    checkActiveBigLedgerPeersIncreased :: CheckPeerSelectionCounters
checkActiveBigLedgerPeersIncreased
      PeerSelectionCounters { Int
numberOfActiveBigLedgerPeers :: Int
numberOfActiveBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfActiveBigLedgerPeers }
      PeerSelectionTargets { Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers }
      =
      Int
numberOfActiveBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
targetNumberOfActiveBigLedgerPeers

    decreaseActiveBigLedgerPeers :: ChurnRegime
                                 -> HotValency
                                 -> PeerSelectionTargets
                                 -> ModifyPeerSelectionTargets
    decreaseActiveBigLedgerPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
decreaseActiveBigLedgerPeers ChurnRegime
regime HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfActiveBigLedgerPeers =
          let praosSyncTargets = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers PeerSelectionTargets
base)
          in case regime of
               ChurnRegime
ChurnBootstrapPraosSync -> Int
praosSyncTargets
               ChurnRegime
ChurnPraosSync -> Int
praosSyncTargets
               ChurnRegime
ChurnDefault -> Int -> Int
decrease (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers PeerSelectionTargets
base }

    checkActiveBigLedgerPeersDecreased
      :: CheckPeerSelectionCounters
    checkActiveBigLedgerPeersDecreased :: CheckPeerSelectionCounters
checkActiveBigLedgerPeersDecreased
      PeerSelectionCounters { Int
numberOfActiveBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfActiveBigLedgerPeers :: Int
numberOfActiveBigLedgerPeers }
      PeerSelectionTargets { Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers }
      =
         Int
numberOfActiveBigLedgerPeers
      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfActiveBigLedgerPeers

    decreaseEstablishedBigLedgerPeers :: ChurnRegime
                                      -> HotValency
                                      -> PeerSelectionTargets
                                      -> ModifyPeerSelectionTargets
    decreaseEstablishedBigLedgerPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
decreaseEstablishedBigLedgerPeers ChurnRegime
_ HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfEstablishedBigLedgerPeers =
          decrease (targetNumberOfEstablishedBigLedgerPeers base -
                    targetNumberOfActiveBigLedgerPeers base)
          + targetNumberOfActiveBigLedgerPeers base
        }

    checkEstablishedBigLedgerPeersDecreased
      :: CheckPeerSelectionCounters
    checkEstablishedBigLedgerPeersDecreased :: CheckPeerSelectionCounters
checkEstablishedBigLedgerPeersDecreased
      PeerSelectionCounters { Int
numberOfEstablishedBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfEstablishedBigLedgerPeers :: Int
numberOfEstablishedBigLedgerPeers }
      PeerSelectionTargets { Int
targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers }
      =
         Int
numberOfEstablishedBigLedgerPeers
      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfEstablishedBigLedgerPeers


    decreaseKnownPeers
      :: ChurnRegime
      -> HotValency
      -> PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    decreaseKnownPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
decreaseKnownPeers ChurnRegime
_ HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
          targetNumberOfRootPeers =
            decrease (targetNumberOfRootPeers base - targetNumberOfEstablishedPeers base)
            + targetNumberOfEstablishedPeers base
        , targetNumberOfKnownPeers =
            decrease (targetNumberOfKnownPeers base - targetNumberOfEstablishedPeers base)
            + targetNumberOfEstablishedPeers base
        }

    checkKnownPeersDecreased
      :: PeerSelectionCounters -> PeerSelectionTargets -> Bool
    checkKnownPeersDecreased :: CheckPeerSelectionCounters
checkKnownPeersDecreased
      PeerSelectionCounters { Int
numberOfKnownPeers :: Int
numberOfKnownPeers :: PeerSelectionCounters -> Int
numberOfKnownPeers }
      PeerSelectionTargets { Int
targetNumberOfKnownPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers }
      =
        -- note: we are not checking target root peers, since it is a one-sided
        -- target
         Int
numberOfKnownPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfKnownPeers

    decreaseKnownBigLedgerPeers
      :: ChurnRegime
      -> HotValency
      -> PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    decreaseKnownBigLedgerPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
decreaseKnownBigLedgerPeers ChurnRegime
_ HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
          targetNumberOfKnownBigLedgerPeers =
            decrease (targetNumberOfKnownBigLedgerPeers base -
                      targetNumberOfEstablishedBigLedgerPeers base)
            + targetNumberOfEstablishedBigLedgerPeers base
        }

    checkKnownBigLedgerPeersDecreased
      :: PeerSelectionCounters -> PeerSelectionTargets -> Bool
    checkKnownBigLedgerPeersDecreased :: CheckPeerSelectionCounters
checkKnownBigLedgerPeersDecreased
      PeerSelectionCounters { Int
numberOfKnownBigLedgerPeers :: Int
numberOfKnownBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfKnownBigLedgerPeers }
      PeerSelectionTargets { Int
targetNumberOfKnownBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownBigLedgerPeers :: Int
targetNumberOfKnownBigLedgerPeers }
      = Int
numberOfKnownBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfKnownBigLedgerPeers


    increaseKnownPeers
      :: ChurnRegime
      -> HotValency
      -> PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    increaseKnownPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
increaseKnownPeers ChurnRegime
_ HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
          targetNumberOfRootPeers = targetNumberOfRootPeers base
        , targetNumberOfKnownPeers = targetNumberOfKnownPeers base
        }

    checkKnownPeersIncreased
      :: CheckPeerSelectionCounters
    checkKnownPeersIncreased :: CheckPeerSelectionCounters
checkKnownPeersIncreased
      PeerSelectionCounters { Int
numberOfRootPeers :: Int
numberOfRootPeers :: PeerSelectionCounters -> Int
numberOfRootPeers,
                              Int
numberOfKnownPeers :: PeerSelectionCounters -> Int
numberOfKnownPeers :: Int
numberOfKnownPeers }
      PeerSelectionTargets { Int
targetNumberOfRootPeers :: PeerSelectionTargets -> Int
targetNumberOfRootPeers :: Int
targetNumberOfRootPeers,
                             Int
targetNumberOfKnownPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers }
      =
         Int
numberOfRootPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
targetNumberOfRootPeers
      Bool -> Bool -> Bool
&& Int
numberOfKnownPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
targetNumberOfKnownPeers


    increaseKnownBigLedgerPeers
      :: ChurnRegime
      -> HotValency
      -> PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    increaseKnownBigLedgerPeers :: ChurnRegime
-> HotValency
-> PeerSelectionTargets
-> PeerSelectionTargets
-> PeerSelectionTargets
increaseKnownBigLedgerPeers ChurnRegime
_ HotValency
_ PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
          targetNumberOfKnownBigLedgerPeers = targetNumberOfKnownBigLedgerPeers base
        }

    checkKnownBigLedgerPeersIncreased
      :: CheckPeerSelectionCounters
    checkKnownBigLedgerPeersIncreased :: CheckPeerSelectionCounters
checkKnownBigLedgerPeersIncreased
      PeerSelectionCounters { Int
numberOfKnownBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfKnownBigLedgerPeers :: Int
numberOfKnownBigLedgerPeers }
      PeerSelectionTargets { Int
targetNumberOfKnownBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownBigLedgerPeers :: Int
targetNumberOfKnownBigLedgerPeers }
      =
      Int
numberOfKnownBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
targetNumberOfKnownBigLedgerPeers


    --
    -- Main loop
    --

    churnLoop :: StdGen -> m Void
    churnLoop :: StdGen -> m Void
churnLoop !StdGen
rng = do
      startTs <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime

      churnMode <- atomically updateChurnMode
      traceWith tracer $ TraceChurnMode churnMode

      -- Purge the worst active peers.
      updateTargets DecreasedActivePeers
                    numberOfActivePeers
                    deactivateTimeout -- chainsync might timeout after 5mins
                    decreaseActivePeers
                    checkActivePeersDecreased

      -- Pick new active peers.
      updateTargets IncreasedActivePeers
                    numberOfActivePeers
                    shortTimeout
                    increaseActivePeers
                    checkActivePeersIncreased

      -- Purge the worst active big ledger peers.
      updateTargets DecreasedActiveBigLedgerPeers
                    numberOfActiveBigLedgerPeers
                    deactivateTimeout -- chainsync might timeout after 5mins
                    decreaseActiveBigLedgerPeers
                    (checkActiveBigLedgerPeersDecreased)

      -- Pick new active big ledger peers.
      updateTargets IncreasedActiveBigLedgerPeers
                    numberOfActiveBigLedgerPeers
                    shortTimeout
                    increaseActiveBigLedgerPeers
                    checkActiveBigLedgerPeersIncreased

      -- Forget the worst performing established peers.
      updateTargets DecreasedEstablishedPeers
                    numberOfEstablishedPeers
                    (1 + closeConnectionTimeout)
                    decreaseEstablishedPeers
                    (checkEstablishedPeersDecreased)

      -- Forget the worst performing established big ledger peers.
      updateTargets DecreasedEstablishedBigLedgerPeers
                    numberOfEstablishedBigLedgerPeers
                    (1 + closeConnectionTimeout)
                    decreaseEstablishedBigLedgerPeers
                    checkEstablishedBigLedgerPeersDecreased

      -- Forget the worst performing known peers (root peers, ledger peers)
      updateTargets DecreasedKnownPeers
                    numberOfKnownPeers
                    shortTimeout
                    decreaseKnownPeers
                    checkKnownPeersDecreased

      -- Pick new known peers
      updateTargets IncreasedKnownPeers
                    numberOfKnownPeers
                    (2 * requestPeersTimeout + shortTimeout)
                    increaseKnownPeers
                    checkKnownPeersIncreased

      -- Forget the worst performing known big ledger peers.
      updateTargets DecreasedKnownBigLedgerPeers
                    numberOfKnownBigLedgerPeers
                    shortTimeout
                    decreaseKnownBigLedgerPeers
                    checkKnownBigLedgerPeersDecreased

      -- Pick new known big ledger peers
      updateTargets IncreasedKnownBigLedgerPeers
                    numberOfKnownBigLedgerPeers
                    (2 * requestPeersTimeout + shortTimeout)
                    increaseKnownBigLedgerPeers
                    checkKnownBigLedgerPeersIncreased

      -- Pick new non-active peers
      updateTargets IncreasedEstablishedPeers
                    numberOfEstablishedPeers
                    churnEstablishConnectionTimeout
                    increaseEstablishedPeers
                    checkEstablishedPeersIncreased

      -- Pick new non-active big ledger peers
      updateTargets IncreasedEstablishedBigLedgerPeers
                    numberOfEstablishedBigLedgerPeers
                    churnEstablishConnectionTimeout
                    increaseEstablishedBigLedgerPeers
                    checkEstablishedBigLedgerPeersIncreased

      endTs <- getMonotonicTime

      fuzzyDelay rng (endTs `diffTime` startTs) >>= churnLoop


    --
    -- Auxiliary functions and constants
    --


    -- Randomly delay between churnInterval and churnInterval + maxFuzz seconds.
    fuzzyDelay :: StdGen -> DiffTime -> m StdGen
    fuzzyDelay :: StdGen -> DiffTime -> m StdGen
fuzzyDelay StdGen
rng DiffTime
execTime = do
      mode <- STM m FetchMode -> m FetchMode
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m FetchMode
getFetchMode
      -- todo: is this right?
      case (mode, consensusMode) of
        (FetchMode
FetchModeDeadline, ConsensusMode
_) -> StdGen -> DiffTime -> m StdGen
longDelay StdGen
rng DiffTime
execTime
        (FetchMode
_, ConsensusMode
GenesisMode)       -> StdGen -> DiffTime -> m StdGen
longDelay StdGen
rng DiffTime
execTime
        (FetchMode, ConsensusMode)
_otherwise             -> StdGen -> DiffTime -> m StdGen
shortDelay StdGen
rng DiffTime
execTime


    fuzzyDelay' :: DiffTime -> Double -> StdGen -> DiffTime -> m StdGen
    fuzzyDelay' :: DiffTime -> Double -> StdGen -> DiffTime -> m StdGen
fuzzyDelay' DiffTime
baseDelay Double
maxFuzz StdGen
rng DiffTime
execTime = do
      let (Double
fuzz, StdGen
rng') = (Double, Double) -> StdGen -> (Double, StdGen)
forall g. RandomGen g => (Double, Double) -> g -> (Double, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Double
0, Double
maxFuzz) StdGen
rng
          delay :: DiffTime
delay = Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
fuzz DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
baseDelay DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
execTime
      Tracer m (TracePeerSelection peeraddr)
-> TracePeerSelection peeraddr -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TracePeerSelection peeraddr)
tracer (TracePeerSelection peeraddr -> m ())
-> TracePeerSelection peeraddr -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> TracePeerSelection peeraddr
forall peeraddr. DiffTime -> TracePeerSelection peeraddr
TraceChurnWait DiffTime
delay
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
delay
      StdGen -> m StdGen
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return StdGen
rng'


    longDelay :: StdGen -> DiffTime -> m StdGen
    longDelay :: StdGen -> DiffTime -> m StdGen
longDelay = DiffTime -> Double -> StdGen -> DiffTime -> m StdGen
fuzzyDelay' DiffTime
deadlineChurnInterval Double
600


    shortDelay :: StdGen -> DiffTime -> m StdGen
    shortDelay :: StdGen -> DiffTime -> m StdGen
shortDelay = DiffTime -> Double -> StdGen -> DiffTime -> m StdGen
fuzzyDelay' DiffTime
bulkChurnInterval Double
60

    -- Ideally this would be as low as possible but the governor might be in
    -- the process of promoting/demoting a peer and it will take some time
    -- before it can act on new targets set by churn
    shortTimeout :: DiffTime
    shortTimeout :: DiffTime
shortTimeout = DiffTime
60

    -- Replace 20% or at least one peer every churnInterval.
    decrease :: Int -> Int
    decrease :: Int -> Int
decrease Int
v = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
v  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
v Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5)