{-# 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 (..)
  , ModifyPeerSelectionTargets
  , CheckPeerSelectionCounters
  , 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.Diffusion.Policies (churnEstablishConnectionTimeout,
           closeConnectionTimeout, deactivateTimeout)
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 (..))

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

data ChurnCounters = ChurnCounter ChurnAction Int

-- | Record of arguments for peer churn governor
--
data PeerChurnArgs m extraArgs extraDebugState extraFlags extraPeers extraAPI extraCounters peeraddr = PeerChurnArgs {
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> Tracer
     m
     (TracePeerSelection extraDebugState extraFlags extraPeers peeraddr)
pcaPeerSelectionTracer :: Tracer m (TracePeerSelection extraDebugState extraFlags extraPeers peeraddr),
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> Tracer m ChurnCounters
pcaChurnTracer         :: Tracer m ChurnCounters,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> DiffTime
pcaDeadlineInterval    :: DiffTime,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> DiffTime
pcaBulkInterval        :: DiffTime,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> DiffTime
pcaPeerRequestTimeout  :: DiffTime,
  -- ^ the timeout for outbound governor to find new (thus
  -- cold) peers through peer sharing mechanism.
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> PeerMetrics m peeraddr
pcaMetrics             :: PeerMetrics m peeraddr,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> StdGen
pcaRng                 :: StdGen,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> StrictTVar m PeerSelectionTargets
pcaPeerSelectionVar    :: StrictTVar m PeerSelectionTargets,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> STM m (PeerSelectionCounters extraCounters)
pcaReadCounters        :: STM m (PeerSelectionCounters extraCounters),
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> LedgerPeersConsensusInterface extraAPI m
getLedgerStateCtx      :: LedgerPeersConsensusInterface extraAPI m,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> STM m HotValency
getLocalRootHotTarget  :: STM m HotValency,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> PeerSelectionTargets
getOriginalPeerTargets :: PeerSelectionTargets,
  forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> extraArgs
getExtraArgs           :: extraArgs }

-- | 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 extraArgs extraDebugState extraFlags extraPeers extraAPI extraCounters peeraddr.
                     ( MonadDelay m
                     , Alternative (STM m)
                     , MonadTimer m
                     , MonadCatch m
                     )
                  => PeerChurnArgs m extraArgs extraDebugState extraFlags extraPeers extraAPI extraCounters peeraddr
                  -> m Void
peerChurnGovernor :: forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
(MonadDelay m, Alternative (STM m), MonadTimer m, MonadCatch m) =>
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> m Void
peerChurnGovernor
  PeerChurnArgs {
    pcaPeerSelectionTracer :: forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> Tracer
     m
     (TracePeerSelection extraDebugState extraFlags extraPeers peeraddr)
pcaPeerSelectionTracer = Tracer
  m
  (TracePeerSelection extraDebugState extraFlags extraPeers peeraddr)
tracer,
    pcaChurnTracer :: forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> Tracer m ChurnCounters
pcaChurnTracer         = Tracer m ChurnCounters
churnTracer,
    pcaBulkInterval :: forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> DiffTime
pcaBulkInterval        = DiffTime
bulkChurnInterval,
    pcaPeerRequestTimeout :: forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> DiffTime
pcaPeerRequestTimeout  = DiffTime
requestPeersTimeout,
    pcaRng :: forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> StdGen
pcaRng                 = StdGen
inRng,
    pcaPeerSelectionVar :: forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> StrictTVar m PeerSelectionTargets
pcaPeerSelectionVar    = StrictTVar m PeerSelectionTargets
peerSelectionVar,
    pcaReadCounters :: forall (m :: * -> *) extraArgs extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr.
PeerChurnArgs
  m
  extraArgs
  extraDebugState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
-> STM m (PeerSelectionCounters extraCounters)
pcaReadCounters        = STM m (PeerSelectionCounters extraCounters)
readCounters
  } = 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
    targets <- readTVar peerSelectionVar

    modifyTVar peerSelectionVar ( increaseActivePeers targets
                                . increaseEstablishedPeers targets
                                )

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

  where
    -- | 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 extraCounters -> Int)
      -- ^ counter getter
      -> DiffTime
      -- ^ timeout
      -> (PeerSelectionTargets -> ModifyPeerSelectionTargets)
      -- ^ update counters function
      -> CheckPeerSelectionCounters extraCounters
      -- ^ check counters
      -> m ()
    updateTargets :: ChurnAction
-> (PeerSelectionCounters extraCounters -> Int)
-> DiffTime
-> (PeerSelectionTargets
    -> PeerSelectionTargets -> PeerSelectionTargets)
-> CheckPeerSelectionCounters extraCounters
-> m ()
updateTargets ChurnAction
churnAction PeerSelectionCounters extraCounters -> Int
getCounter DiffTime
timeoutDelay PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
modifyTargets CheckPeerSelectionCounters extraCounters
checkCounters = do
      -- update targets, and return the new targets
      startTime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      (c, targets) <- atomically $ do
        targets <- readTVar peerSelectionVar

        (,) <$> (getCounter <$> readCounters)
            <*> stateTVar peerSelectionVar ((\PeerSelectionTargets
a -> (PeerSelectionTargets
a, PeerSelectionTargets
a)) . modifyTargets 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 extraCounters)
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 extraCounters -> Int
getCounter PeerSelectionCounters extraCounters
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 :: PeerSelectionTargets
                        -> ModifyPeerSelectionTargets
    increaseActivePeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
increaseActivePeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfActivePeers = targetNumberOfActivePeers base
      }

    checkActivePeersIncreased :: CheckPeerSelectionCounters extraCounters
    checkActivePeersIncreased :: CheckPeerSelectionCounters extraCounters
checkActivePeersIncreased
      PeerSelectionCounters { Int
numberOfActivePeers :: Int
numberOfActivePeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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 :: PeerSelectionTargets
                        -> ModifyPeerSelectionTargets
    decreaseActivePeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
decreaseActivePeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfActivePeers =
          decrease $ targetNumberOfActivePeers base
      }

    checkActivePeersDecreased :: CheckPeerSelectionCounters extraCounters
    checkActivePeersDecreased :: CheckPeerSelectionCounters extraCounters
checkActivePeersDecreased
      PeerSelectionCounters { Int
numberOfActivePeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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 :: PeerSelectionTargets
                             -> ModifyPeerSelectionTargets
    increaseEstablishedPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
increaseEstablishedPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfEstablishedPeers = targetNumberOfEstablishedPeers base
      }

    checkEstablishedPeersIncreased :: CheckPeerSelectionCounters extraCounters
    checkEstablishedPeersIncreased :: CheckPeerSelectionCounters extraCounters
checkEstablishedPeersIncreased
      PeerSelectionCounters { Int
numberOfEstablishedPeers :: Int
numberOfEstablishedPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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
      :: PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    increaseEstablishedBigLedgerPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
increaseEstablishedBigLedgerPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfEstablishedBigLedgerPeers = targetNumberOfEstablishedBigLedgerPeers base
      }

    checkEstablishedBigLedgerPeersIncreased
      :: CheckPeerSelectionCounters extraCounters
    checkEstablishedBigLedgerPeersIncreased :: CheckPeerSelectionCounters extraCounters
checkEstablishedBigLedgerPeersIncreased
      PeerSelectionCounters { Int
numberOfEstablishedBigLedgerPeers :: Int
numberOfEstablishedBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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
      :: PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    decreaseEstablishedPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
decreaseEstablishedPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfEstablishedPeers =
            decrease (targetNumberOfEstablishedPeers base - targetNumberOfActivePeers base)
          + targetNumberOfActivePeers base
      }

    checkEstablishedPeersDecreased
      :: CheckPeerSelectionCounters extraCounters
    checkEstablishedPeersDecreased :: CheckPeerSelectionCounters extraCounters
checkEstablishedPeersDecreased
      PeerSelectionCounters { Int
numberOfEstablishedPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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 :: PeerSelectionTargets
                                 -> ModifyPeerSelectionTargets
    increaseActiveBigLedgerPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
increaseActiveBigLedgerPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfActiveBigLedgerPeers = targetNumberOfActiveBigLedgerPeers base
      }

    checkActiveBigLedgerPeersIncreased
      :: CheckPeerSelectionCounters extraCounters
    checkActiveBigLedgerPeersIncreased :: CheckPeerSelectionCounters extraCounters
checkActiveBigLedgerPeersIncreased
      PeerSelectionCounters { Int
numberOfActiveBigLedgerPeers :: Int
numberOfActiveBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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 :: PeerSelectionTargets
                                 -> ModifyPeerSelectionTargets
    decreaseActiveBigLedgerPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
decreaseActiveBigLedgerPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfActiveBigLedgerPeers =
          decrease $ targetNumberOfActiveBigLedgerPeers base
      }

    checkActiveBigLedgerPeersDecreased
      :: CheckPeerSelectionCounters extraCounters
    checkActiveBigLedgerPeersDecreased :: CheckPeerSelectionCounters extraCounters
checkActiveBigLedgerPeersDecreased
      PeerSelectionCounters { Int
numberOfActiveBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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 :: PeerSelectionTargets
                                      -> ModifyPeerSelectionTargets
    decreaseEstablishedBigLedgerPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
decreaseEstablishedBigLedgerPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfEstablishedBigLedgerPeers =
          decrease (targetNumberOfEstablishedBigLedgerPeers base -
                    targetNumberOfActiveBigLedgerPeers base)
          + targetNumberOfActiveBigLedgerPeers base
        }

    checkEstablishedBigLedgerPeersDecreased
      :: CheckPeerSelectionCounters extraCounters
    checkEstablishedBigLedgerPeersDecreased :: CheckPeerSelectionCounters extraCounters
checkEstablishedBigLedgerPeersDecreased
      PeerSelectionCounters { Int
numberOfEstablishedBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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
      :: PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    decreaseKnownPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
decreaseKnownPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfRootPeers =
          decrease (targetNumberOfRootPeers base - targetNumberOfEstablishedPeers base)
          + targetNumberOfEstablishedPeers base
      , targetNumberOfKnownPeers =
          decrease (targetNumberOfKnownPeers base - targetNumberOfEstablishedPeers base)
          + targetNumberOfEstablishedPeers base
      }

    checkKnownPeersDecreased
      :: PeerSelectionCounters extraCounters -> PeerSelectionTargets -> Bool
    checkKnownPeersDecreased :: CheckPeerSelectionCounters extraCounters
checkKnownPeersDecreased
      PeerSelectionCounters { Int
numberOfKnownPeers :: Int
numberOfKnownPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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
      :: PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    decreaseKnownBigLedgerPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
decreaseKnownBigLedgerPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfKnownBigLedgerPeers =
          decrease (targetNumberOfKnownBigLedgerPeers base -
                    targetNumberOfEstablishedBigLedgerPeers base)
          + targetNumberOfEstablishedBigLedgerPeers base
      }

    checkKnownBigLedgerPeersDecreased
      :: PeerSelectionCounters extraCounters -> PeerSelectionTargets -> Bool
    checkKnownBigLedgerPeersDecreased :: CheckPeerSelectionCounters extraCounters
checkKnownBigLedgerPeersDecreased
      PeerSelectionCounters { Int
numberOfKnownBigLedgerPeers :: Int
numberOfKnownBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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
      :: PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    increaseKnownPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
increaseKnownPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfRootPeers = targetNumberOfRootPeers base
      , targetNumberOfKnownPeers = targetNumberOfKnownPeers base
      }

    checkKnownPeersIncreased
      :: CheckPeerSelectionCounters extraCounters
    checkKnownPeersIncreased :: CheckPeerSelectionCounters extraCounters
checkKnownPeersIncreased
      PeerSelectionCounters { Int
numberOfRootPeers :: Int
numberOfRootPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfRootPeers,
                              Int
numberOfKnownPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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
      :: PeerSelectionTargets
      -> ModifyPeerSelectionTargets
    increaseKnownBigLedgerPeers :: PeerSelectionTargets
-> PeerSelectionTargets -> PeerSelectionTargets
increaseKnownBigLedgerPeers PeerSelectionTargets
base PeerSelectionTargets
targets =
      PeerSelectionTargets
targets {
        targetNumberOfKnownBigLedgerPeers = targetNumberOfKnownBigLedgerPeers base
      }

    checkKnownBigLedgerPeersIncreased
      :: CheckPeerSelectionCounters extraCounters
    checkKnownBigLedgerPeersIncreased :: CheckPeerSelectionCounters extraCounters
checkKnownBigLedgerPeersIncreased
      PeerSelectionCounters { Int
numberOfKnownBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> 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

      -- Purge the worst active big ledger peers.
      updateTargets DecreasedActiveBigLedgerPeers
                    numberOfActiveBigLedgerPeers
                    deactivateTimeout
                    decreaseActiveBigLedgerPeers
                    checkActiveBigLedgerPeersDecreased

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

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

      -- 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 big ledger peers
      updateTargets IncreasedEstablishedBigLedgerPeers
                    numberOfEstablishedBigLedgerPeers
                    churnEstablishConnectionTimeout
                    increaseEstablishedBigLedgerPeers
                    checkEstablishedBigLedgerPeersIncreased

      -- Purge the worst active peers.
      updateTargets DecreasedActivePeers
                    numberOfActivePeers
                    deactivateTimeout
                    decreaseActivePeers
                    checkActivePeersDecreased

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

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

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

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

      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 = 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 extraDebugState extraFlags extraPeers peeraddr)
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m
  (TracePeerSelection extraDebugState extraFlags extraPeers peeraddr)
tracer (TracePeerSelection extraDebugState extraFlags extraPeers peeraddr
 -> m ())
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
-> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
DiffTime
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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'

    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)