{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Network.PeerSelection.Governor.ActivePeers
  ( belowTarget
  , aboveTarget
  , jobDemoteActivePeer
  ) where

import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import GHC.Stack (HasCallStack)

import Control.Applicative (Alternative)
import Control.Concurrent.JobPool (Job (..))
import Control.Exception (SomeException, assert)
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import System.Random (randomR)

import Ouroboros.Network.PeerSelection.Bootstrap (requiresBootstrapPeers)
import Ouroboros.Network.PeerSelection.Governor.Types
import Ouroboros.Network.PeerSelection.LedgerPeers.Type (IsBigLedgerPeer (..))
import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers
import Ouroboros.Network.PeerSelection.State.KnownPeers (setTepidFlag)
import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..))
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers


----------------------------
-- Active peers below target
--


-- | If we are below the target of /hot peers/ we promote some of the /warm
-- peers/ according to 'policyPickWarmPeersToPromote' policy.
--
belowTarget :: forall peeraddr peerconn m.
               ( Alternative (STM m)
               , MonadDelay m
               , MonadSTM m
               , Ord peeraddr
               , HasCallStack
               )
            => PeerSelectionActions peeraddr peerconn m
            -> MkGuardedDecision peeraddr peerconn m
belowTarget :: forall peeraddr peerconn (m :: * -> *).
(Alternative (STM m), MonadDelay m, MonadSTM m, Ord peeraddr,
 HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTarget = PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetBigLedgerPeers
           (PeerSelectionActions peeraddr peerconn m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState peeraddr peerconn
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> (PeerSelectionActions peeraddr peerconn m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState peeraddr peerconn
    -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetLocal
           (PeerSelectionActions peeraddr peerconn m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState peeraddr peerconn
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> (PeerSelectionActions peeraddr peerconn m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState peeraddr peerconn
    -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetOther

-- | If we are below the target of /hot big ledger peers peers/ we promote some
-- of the /warm peers/ according to 'policyPickWarmPeersToPromote' policy.
--
-- It should be noted if the node is in bootstrap mode (i.e. in a sensitive
-- state) then this monitoring action will be disabled.
--
belowTargetBigLedgerPeers :: forall peeraddr peerconn m.
                             (MonadDelay m, MonadSTM m, Ord peeraddr)
                          => PeerSelectionActions peeraddr peerconn m
                          -> MkGuardedDecision peeraddr peerconn m
belowTargetBigLedgerPeers :: forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetBigLedgerPeers PeerSelectionActions peeraddr peerconn m
actions
                          policy :: PeerSelectionPolicy peeraddr m
policy@PeerSelectionPolicy {
                            PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote :: PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote
                          }
                          st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                            PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers,
                            EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers,
                            Set peeraddr
activePeers :: Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers,
                            Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm,
                            Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm,
                            Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold,
                            targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                        Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers
                                      },
                            LedgerStateJudgement
ledgerStateJudgement :: LedgerStateJudgement
ledgerStateJudgement :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LedgerStateJudgement
ledgerStateJudgement,
                            UseBootstrapPeers
bootstrapPeersFlag :: UseBootstrapPeers
bootstrapPeersFlag :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> UseBootstrapPeers
bootstrapPeersFlag
                          }
    -- Are we below the target for number of active peers?
  | Int
numActiveBigLedgerPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numPromoteInProgressBigLedgerPeers
    Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfActiveBigLedgerPeers

    -- Are there any warm peers we could pick to promote?
  , let availableToPromote :: Set peeraddr
        availableToPromote :: Set peeraddr
availableToPromote = EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.readyPeers EstablishedPeers peeraddr peerconn
establishedPeers
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set peeraddr
bigLedgerPeersSet
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
activePeers
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressPromoteWarm
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteWarm
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteToCold
        numPeersToPromote :: Int
numPeersToPromote = Int
targetNumberOfActiveBigLedgerPeers
                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numActiveBigLedgerPeers
                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numPromoteInProgressBigLedgerPeers
  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableToPromote)
  , Int
numPeersToPromote Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  -- Are we in a insensitive state, i.e. using bootstrap peers?
  , Bool -> Bool
not (UseBootstrapPeers -> LedgerStateJudgement -> Bool
requiresBootstrapPeers UseBootstrapPeers
bootstrapPeersFlag LedgerStateJudgement
ledgerStateJudgement)
  = Maybe Time
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToPromote <- PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
                             PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote
                             Set peeraddr
availableToPromote
                             Int
numPeersToPromote
      let selectedToPromote' :: Map peeraddr peerconn
          selectedToPromote' = EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers
                                 Map peeraddr peerconn -> Set peeraddr -> Map peeraddr peerconn
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
selectedToPromote
      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmBigLedgerPeers
                           Int
targetNumberOfActiveBigLedgerPeers
                           Int
numActiveBigLedgerPeers
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressPromoteWarm = inProgressPromoteWarm
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobPromoteWarmPeer PeerSelectionActions peeraddr peerconn m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peeraddr IsBigLedgerPeer
IsBigLedgerPeer peerconn
peerconn
                        | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToPromote' ]
      }

    -- If we could promote except that there are no peers currently available
    -- then we return the next wakeup time (if any)
  | Int
numActiveBigLedgerPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numPromoteInProgressBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfActiveBigLedgerPeers
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip (EstablishedPeers peeraddr peerconn
-> (peeraddr -> Bool) -> Maybe Time
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn
-> (peeraddr -> Bool) -> Maybe Time
EstablishedPeers.minActivateTime EstablishedPeers peeraddr peerconn
establishedPeers (peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet))

  | Bool
otherwise
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
    PeerSelectionCounters {
        numberOfActiveBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfActiveBigLedgerPeers         = Int
numActiveBigLedgerPeers,
        numberOfWarmBigLedgerPeersPromotions :: PeerSelectionCounters -> Int
numberOfWarmBigLedgerPeersPromotions = Int
numPromoteInProgressBigLedgerPeers
      }
      =
      PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerSelectionStateToCounters PeerSelectionState peeraddr peerconn
st


belowTargetLocal :: forall peeraddr peerconn m.
                    (MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack)
                 => PeerSelectionActions peeraddr peerconn m
                 -> MkGuardedDecision peeraddr peerconn m
belowTargetLocal :: forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetLocal PeerSelectionActions peeraddr peerconn m
actions
                 policy :: PeerSelectionPolicy peeraddr m
policy@PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote :: PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote
                 }
                 st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                   PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                   LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                   Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm,
                   Set peeraddr
inProgressDemoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm,
                   Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold
                 }
    -- Are there any groups of local peers that are below target?
  | Bool -> Bool
not ([(HotValency, Set peeraddr, Set peeraddr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(HotValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget)
    -- We need this detailed check because it is not enough to check we are
    -- below an aggregate target. We can be above target for some groups
    -- and below for others.

    -- Are there any groups where we can pick members to promote?
  , let groupsAvailableToPromote :: [(Int, Set peeraddr)]
groupsAvailableToPromote =
          [ (Int
numMembersToPromote, Set peeraddr
membersAvailableToPromote)
          | let availableToPromote :: Set peeraddr
availableToPromote =
                  (LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers
                    Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                   EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.readyPeers EstablishedPeers peeraddr peerconn
establishedPeers)
                     Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
activePeers
                     Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressPromoteWarm
                     Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteWarm
                     Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteToCold
                numPromoteInProgress :: Int
numPromoteInProgress = Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
inProgressPromoteWarm
          , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableToPromote)
          , (HotValency Int
hotTarget, Set peeraddr
members, Set peeraddr
membersActive) <- [(HotValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget
          , let membersAvailableToPromote :: Set peeraddr
membersAvailableToPromote = Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
                                              Set peeraddr
members Set peeraddr
availableToPromote
                numMembersToPromote :: Int
numMembersToPromote       = Int
hotTarget
                                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersActive
                                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numPromoteInProgress
          , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
membersAvailableToPromote)
          , Int
numMembersToPromote Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
          ]
  , Bool -> Bool
not ([(Int, Set peeraddr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Set peeraddr)]
groupsAvailableToPromote)
  = Maybe Time
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToPromote <-
        [Set peeraddr] -> Set peeraddr
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set peeraddr] -> Set peeraddr)
-> STM m [Set peeraddr] -> STM m (Set peeraddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [STM m (Set peeraddr)] -> STM m [Set peeraddr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
              PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote
              Set peeraddr
membersAvailableToPromote
              Int
numMembersToPromote
          | (Int
numMembersToPromote,
             Set peeraddr
membersAvailableToPromote) <- [(Int, Set peeraddr)]
groupsAvailableToPromote ]

      let selectedToPromote' :: Map peeraddr peerconn
          selectedToPromote' = EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers
                                 Map peeraddr peerconn -> Set peeraddr -> Map peeraddr peerconn
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
selectedToPromote
      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [[(HotValency, Int)] -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
[(HotValency, Int)] -> Set peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmLocalPeers
                           [ (HotValency
target, Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersActive)
                           | (HotValency
target, Set peeraddr
_, Set peeraddr
membersActive) <- [(HotValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget ]
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressPromoteWarm = inProgressPromoteWarm
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobPromoteWarmPeer PeerSelectionActions peeraddr peerconn m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peeraddr IsBigLedgerPeer
IsNotBigLedgerPeer peerconn
peerconn
                        | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToPromote' ]
      }


    -- If we could promote except that there are no peers currently available
    -- then we return the next wakeup time (if any)
  | Bool -> Bool
not ([(HotValency, Set peeraddr, Set peeraddr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(HotValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget)
  , let potentialToPromote :: Set peeraddr
potentialToPromote =
          -- These are local peers that are warm but not ready.
          (LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers
            Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
           EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.toSet EstablishedPeers peeraddr peerconn
establishedPeers)
             Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
activePeers
             Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.readyPeers EstablishedPeers peeraddr peerconn
establishedPeers
  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
potentialToPromote)
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip (EstablishedPeers peeraddr peerconn
-> (peeraddr -> Bool) -> Maybe Time
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn
-> (peeraddr -> Bool) -> Maybe Time
EstablishedPeers.minActivateTime EstablishedPeers peeraddr peerconn
establishedPeers (peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
bigLedgerPeersSet))

  | Bool
otherwise
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
    groupsBelowTarget :: [(HotValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget =
      [ (HotValency
hotValency, Set peeraddr
members, Set peeraddr
membersActive)
      | (HotValency
hotValency, WarmValency
_, Set peeraddr
members) <- LocalRootPeers peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
forall peeraddr.
LocalRootPeers peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
LocalRootPeers.toGroupSets LocalRootPeers peeraddr
localRootPeers
      , let membersActive :: Set peeraddr
membersActive = Set peeraddr
members Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set peeraddr
activePeers
      , Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersActive Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< HotValency -> Int
getHotValency HotValency
hotValency
      ]

belowTargetOther :: forall peeraddr peerconn m.
                    (MonadDelay m, MonadSTM m, Ord peeraddr,
                     HasCallStack)
                 => PeerSelectionActions peeraddr peerconn m
                 -> MkGuardedDecision peeraddr peerconn m
belowTargetOther :: forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetOther PeerSelectionActions peeraddr peerconn m
actions
                 policy :: PeerSelectionPolicy peeraddr m
policy@PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote :: PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote
                 }
                 st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                   LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                   Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm,
                   Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
                   Set peeraddr
inProgressDemoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm,
                   targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                               Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers
                             }
                 }
    -- Are we below the target for number of active peers?
  | Int
numActivePeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numPromoteInProgress Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfActivePeers

    -- Are there any warm peers we could pick to promote?
  , let availableToPromote :: Set peeraddr
        availableToPromote :: Set peeraddr
availableToPromote = EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.readyPeers EstablishedPeers peeraddr peerconn
establishedPeers
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
activePeers
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressPromoteWarm
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteWarm
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteToCold
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers
                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet
        numPeersToPromote :: Int
numPeersToPromote = Int
targetNumberOfActivePeers
                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numActivePeers
                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numPromoteInProgress
  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableToPromote)
  , Int
numPeersToPromote Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  = Maybe Time
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToPromote <- PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
                             PickPolicy peeraddr (STM m)
policyPickWarmPeersToPromote
                             Set peeraddr
availableToPromote
                             Int
numPeersToPromote
      let selectedToPromote' :: Map peeraddr peerconn
          selectedToPromote' = EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers
                                 Map peeraddr peerconn -> Set peeraddr -> Map peeraddr peerconn
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
selectedToPromote
      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmPeers
                           Int
targetNumberOfActivePeers
                           Int
numActivePeers
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressPromoteWarm = inProgressPromoteWarm
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobPromoteWarmPeer PeerSelectionActions peeraddr peerconn m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peeraddr IsBigLedgerPeer
IsNotBigLedgerPeer peerconn
peerconn
                        | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToPromote' ]
      }

    -- If we could promote except that there are no peers currently available
    -- then we return the next wakeup time (if any)
  | Int
numActivePeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numPromoteInProgress Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfActivePeers
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip (EstablishedPeers peeraddr peerconn
-> (peeraddr -> Bool) -> Maybe Time
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn
-> (peeraddr -> Bool) -> Maybe Time
EstablishedPeers.minActivateTime EstablishedPeers peeraddr peerconn
establishedPeers (peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
bigLedgerPeersSet))

  | Bool
otherwise
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    PeerSelectionView {
        viewActivePeers :: forall a. PeerSelectionView a -> a
viewActivePeers         = (Set peeraddr
_, Int
numActivePeers),
        viewWarmPeersPromotions :: forall a. PeerSelectionView a -> a
viewWarmPeersPromotions = (Set peeraddr
_, Int
numPromoteInProgress),
        viewKnownBigLedgerPeers :: forall a. PeerSelectionView a -> a
viewKnownBigLedgerPeers = (Set peeraddr
bigLedgerPeersSet, Int
_)
      }
      =
      PeerSelectionState peeraddr peerconn
-> PeerSelectionView (Set peeraddr, Int)
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn
-> PeerSelectionSetsWithSizes peeraddr
peerSelectionStateToView PeerSelectionState peeraddr peerconn
st


jobPromoteWarmPeer :: forall peeraddr peerconn m.
                      (MonadDelay m, Ord peeraddr)
                   => PeerSelectionActions peeraddr peerconn m
                   -> PeerSelectionPolicy peeraddr m
                   -> peeraddr
                   -> IsBigLedgerPeer
                   -> peerconn
                   -> Job () m (Completion m peeraddr peerconn)
jobPromoteWarmPeer :: forall peeraddr peerconn (m :: * -> *).
(MonadDelay m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobPromoteWarmPeer PeerSelectionActions{peerStateActions :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> PeerStateActions peeraddr peerconn m
peerStateActions = PeerStateActions {IsBigLedgerPeer -> peerconn -> m ()
activatePeerConnection :: IsBigLedgerPeer -> peerconn -> m ()
activatePeerConnection :: forall peeraddr peerconn (m :: * -> *).
PeerStateActions peeraddr peerconn m
-> IsBigLedgerPeer -> peerconn -> m ()
activatePeerConnection}}
                   PeerSelectionPolicy { DiffTime
policyErrorDelay :: DiffTime
policyErrorDelay :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> DiffTime
policyErrorDelay }
                   peeraddr
peeraddr IsBigLedgerPeer
isBigLedgerPeer peerconn
peerconn =
    m (Completion m peeraddr peerconn)
-> (SomeException -> m (Completion m peeraddr peerconn))
-> ()
-> String
-> Job () m (Completion m peeraddr peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job m (Completion m peeraddr peerconn)
job SomeException -> m (Completion m peeraddr peerconn)
handler () String
"promoteWarmPeer"
  where
    handler :: SomeException -> m (Completion m peeraddr peerconn)
    handler :: SomeException -> m (Completion m peeraddr peerconn)
handler SomeException
e = do
      -- We wait here, not to avoid race conditions or broken locking, this is
      -- just a very simple back-off strategy. For cold -> warm failures we use
      -- an exponential back-off retry strategy. For warm -> hot we do not need
      -- such a strategy. Simply a short pause is enough to ensure we never
      -- busy-loop.  Failures of warm -> hot will be accompanied by an
      -- asynchronous demotion to cold relatively promptly. If we did ever need
      -- to carry on after warm -> hot failures then we would need to implement
      -- a more sophisticated back-off strategy, like an exponential back-off
      -- (and perhaps use that failure count in the policy to drop useless peers
      -- in the warm -> cold transition).
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
      Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$
        -- When promotion fails we set the peer as cold.
        (PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall (m :: * -> *) peeraddr peerconn.
(PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
Completion ((PeerSelectionState peeraddr peerconn
  -> Time -> Decision m peeraddr peerconn)
 -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                                 PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                                 Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                                 EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                                 KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers,
                                 StdGen
stdGen :: StdGen
stdGen :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> StdGen
stdGen,
                                 targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                             Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers,
                                             Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers
                                           }
                               }
                      Time
now ->
          -- TODO: this is a temporary fix, which will by addressed by
          -- #3460
          let bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
           in if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` PeerSelectionState peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm PeerSelectionState peeraddr peerconn
st
                 then let establishedPeers' :: EstablishedPeers peeraddr peerconn
establishedPeers' = peeraddr
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall peeraddr peerconn.
Ord peeraddr =>
peeraddr
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
EstablishedPeers.delete peeraddr
peeraddr
                                                EstablishedPeers peeraddr peerconn
establishedPeers
                          (Double
fuzz, StdGen
stdGen')  = (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
2, Double
2 :: Double) StdGen
stdGen
                          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
policyErrorDelay
                          knownPeers' :: KnownPeers peeraddr
knownPeers'       = if peeraddr
peeraddr peeraddr -> KnownPeers peeraddr -> Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> Bool
`KnownPeers.member` KnownPeers peeraddr
knownPeers
                                                 then Map peeraddr Time -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Map peeraddr Time -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.setConnectTimes
                                                        (peeraddr -> Time -> Map peeraddr Time
forall k a. k -> a -> Map k a
Map.singleton
                                                          peeraddr
peeraddr
                                                          (DiffTime
delay DiffTime -> Time -> Time
`addTime` Time
now))
                                                      (KnownPeers peeraddr -> KnownPeers peeraddr)
-> KnownPeers peeraddr -> KnownPeers peeraddr
forall a b. (a -> b) -> a -> b
$ (Int, KnownPeers peeraddr) -> KnownPeers peeraddr
forall a b. (a, b) -> b
snd ((Int, KnownPeers peeraddr) -> KnownPeers peeraddr)
-> (Int, KnownPeers peeraddr) -> KnownPeers peeraddr
forall a b. (a -> b) -> a -> b
$ peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
KnownPeers.incrementFailCount
                                                        peeraddr
peeraddr
                                                        KnownPeers peeraddr
knownPeers
                                                 else
                                                   -- Apparently the governor can remove
                                                   -- the peer we failed to promote from the
                                                   -- set of known peers before we can process
                                                   -- the failure.
                                                   KnownPeers peeraddr
knownPeers
                       in
                      Decision {
                        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                                        then [Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
forall peeraddr.
Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
TracePromoteWarmBigLedgerPeerFailed
                                               Int
targetNumberOfActiveBigLedgerPeers
                                               (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers
                                                           Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                                                           Set peeraddr
bigLedgerPeersSet)
                                               peeraddr
peeraddr SomeException
e]
                                        else [Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
forall peeraddr.
Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
TracePromoteWarmFailed
                                               Int
targetNumberOfActivePeers
                                               (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers
                                                    Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet)
                                               peeraddr
peeraddr SomeException
e],
                        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                                          inProgressPromoteWarm = Set.delete peeraddr
                                                                    (inProgressPromoteWarm st),
                                          knownPeers            = knownPeers',
                                          establishedPeers      = establishedPeers',
                                          stdGen                = stdGen'
                                        },
                        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
                      }
                 else Decision {
                        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                                           then [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmBigLedgerPeerAborted
                                                  Int
targetNumberOfActiveBigLedgerPeers
                                                  (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers
                                                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                                                              Set peeraddr
bigLedgerPeersSet)
                                                  peeraddr
peeraddr]
                                           else [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmAborted
                                                  Int
targetNumberOfActivePeers
                                                  (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers
                                                       Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet)
                                                  peeraddr
peeraddr],
                        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st,
                        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
                      }


    job :: m (Completion m peeraddr peerconn)
    job :: m (Completion m peeraddr peerconn)
job = do
      IsBigLedgerPeer -> peerconn -> m ()
activatePeerConnection IsBigLedgerPeer
isBigLedgerPeer peerconn
peerconn
      Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ (PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall (m :: * -> *) peeraddr peerconn.
(PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
Completion ((PeerSelectionState peeraddr peerconn
  -> Time -> Decision m peeraddr peerconn)
 -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                               PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                               Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                               targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                           Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers
                                         }
                             }
                           Time
_now ->
        let bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
         in if peeraddr
peeraddr peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
forall peeraddr peerconn.
Ord peeraddr =>
peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
`EstablishedPeers.member` PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers PeerSelectionState peeraddr peerconn
st
               then let activePeers' :: Set peeraddr
activePeers' = peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => a -> Set a -> Set a
Set.insert peeraddr
peeraddr Set peeraddr
activePeers in
                    Decision {
                      decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                                      then [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmBigLedgerPeerDone
                                             Int
targetNumberOfActivePeers
                                             (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers'
                                                         Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                                                         Set peeraddr
bigLedgerPeersSet)
                                             peeraddr
peeraddr]
                                      else [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmDone
                                             Int
targetNumberOfActivePeers
                                             (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers'
                                                  Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet)
                                             peeraddr
peeraddr],
                      decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                                        activePeers           = activePeers',
                                        inProgressPromoteWarm = Set.delete peeraddr
                                                                  (inProgressPromoteWarm st)
                                      },
                      decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
                    }
               else
                 Decision {
                   decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                                   then [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmBigLedgerPeerAborted
                                          Int
targetNumberOfActivePeers
                                          (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers
                                                      Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                                                      Set peeraddr
bigLedgerPeersSet)
                                          peeraddr
peeraddr]
                                   else [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TracePromoteWarmAborted
                                          Int
targetNumberOfActivePeers
                                          (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers
                                               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet)
                                          peeraddr
peeraddr],
                   decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st,
                   decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
                 }

----------------------------
-- Active peers above target
--

-- | If we are above the target of /hot peers/ we demote some hot peers to be
-- /warm peers/, according to 'policyPickHotPeersToDemote'.
--
aboveTarget :: forall peeraddr peerconn m.
               ( Alternative (STM m)
               , MonadSTM m
               , Ord peeraddr
               , HasCallStack
               )
            => PeerSelectionActions peeraddr peerconn m
            -> MkGuardedDecision peeraddr peerconn m
aboveTarget :: forall peeraddr peerconn (m :: * -> *).
(Alternative (STM m), MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTarget = PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetBigLedgerPeers
           (PeerSelectionActions peeraddr peerconn m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState peeraddr peerconn
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> (PeerSelectionActions peeraddr peerconn m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState peeraddr peerconn
    -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetLocal
           (PeerSelectionActions peeraddr peerconn m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState peeraddr peerconn
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> (PeerSelectionActions peeraddr peerconn m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState peeraddr peerconn
    -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetOther
  -- Start with big ledger peers then local root targets, then the general
  -- target. Note that making progress downwards with the local root targets
  -- makes progress for the general target too.


aboveTargetBigLedgerPeers :: forall peeraddr peerconn m.
                             (MonadSTM m, Ord peeraddr)
                          => PeerSelectionActions peeraddr peerconn m
                          -> MkGuardedDecision peeraddr peerconn m
aboveTargetBigLedgerPeers :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetBigLedgerPeers PeerSelectionActions peeraddr peerconn m
actions
                          PeerSelectionPolicy {
                            PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
                          }
                          st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                            PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                            LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
                            EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                            Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                            Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot,
                            Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
                            targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                        Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers
                                      }
                          }
    -- Are we above the general target for number of active peers?
  | Int
numActiveBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
targetNumberOfActiveBigLedgerPeers

    -- Would we demote any if we could?
  , let numPeersToDemote :: Int
numPeersToDemote = Int
numActiveBigLedgerPeers
                         Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
targetNumberOfActiveBigLedgerPeers
                         Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numDemoteInProgressBigLedgerPeers
  , Int
numPeersToDemote Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

    -- Are there any hot peers we actually can pick to demote?
    -- For the moment we say we cannot demote local root peers.
    -- TODO: review this decision. If we want to be able to demote local root
    -- peers, e.g. for churn and improved selection, then we'll need an extra
    -- mechanism to avoid promotion/demotion loops for local peers.
  , let availableToDemote :: Set peeraddr
availableToDemote = Set peeraddr
activePeers
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set peeraddr
bigLedgerPeersSet
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteHot
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteToCold
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers
  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableToDemote)
  = Maybe Time
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToDemote <- PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
                            PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
                            Set peeraddr
availableToDemote
                            Int
numPeersToDemote
      let selectedToDemote' :: Map peeraddr peerconn
          selectedToDemote' = EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers
                                Map peeraddr peerconn -> Set peeraddr -> Map peeraddr peerconn
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
selectedToDemote

      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
TraceDemoteHotBigLedgerPeers
                           Int
targetNumberOfActiveBigLedgerPeers
                           Int
numActiveBigLedgerPeers
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressDemoteHot = inProgressDemoteHot
                                             <> selectedToDemote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteActivePeer PeerSelectionActions peeraddr peerconn m
actions peeraddr
peeraddr peerconn
peerconn
                        | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToDemote' ]
      }

  | Bool
otherwise
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
    PeerSelectionCounters {
        numberOfActiveBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfActiveBigLedgerPeers          = Int
numActiveBigLedgerPeers,
        numberOfActiveBigLedgerPeersDemotions :: PeerSelectionCounters -> Int
numberOfActiveBigLedgerPeersDemotions = Int
numDemoteInProgressBigLedgerPeers
      }
      =
      PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerSelectionStateToCounters PeerSelectionState peeraddr peerconn
st


aboveTargetLocal :: forall peeraddr peerconn m.
                    (MonadSTM m, Ord peeraddr, HasCallStack)
                 => PeerSelectionActions peeraddr peerconn m
                 -> MkGuardedDecision peeraddr peerconn m
aboveTargetLocal :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetLocal PeerSelectionActions peeraddr peerconn m
actions
                 PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
                 }
                 st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                   LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                   Set peeraddr
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
                   Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold
                 }
    -- Are there any groups of local peers that are below target?
  | let groupsAboveTarget :: [(HotValency, Set peeraddr, Set peeraddr)]
groupsAboveTarget =
          [ (HotValency
hotValency, Set peeraddr
members, Set peeraddr
membersActive)
          | (HotValency
hotValency, WarmValency
_, Set peeraddr
members) <- LocalRootPeers peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
forall peeraddr.
LocalRootPeers peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
LocalRootPeers.toGroupSets LocalRootPeers peeraddr
localRootPeers
          , let membersActive :: Set peeraddr
membersActive = Set peeraddr
members Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set peeraddr
activePeers
          , Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersActive Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> HotValency -> Int
getHotValency HotValency
hotValency
          ]
  , Bool -> Bool
not ([(HotValency, Set peeraddr, Set peeraddr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(HotValency, Set peeraddr, Set peeraddr)]
groupsAboveTarget)
    -- We need this detailed check because it is not enough to check we are
    -- above an aggregate target. We can be above target for some groups
    -- and below for others.

    -- Are there any groups where we can pick members to demote?
  , let groupsAvailableToDemote :: [(Int, Set peeraddr)]
groupsAvailableToDemote =
          [ (Int
numMembersToDemote, Set peeraddr
membersAvailableToDemote)
          | let availableToDemote :: Set peeraddr
availableToDemote = (LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers
                                       Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                                     Set peeraddr
activePeers)
                                       Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteHot
                                       Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteToCold
                numDemoteInProgress :: Int
numDemoteInProgress = Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
inProgressDemoteHot
                                    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr
inProgressDemoteToCold
                                                Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                                                Set peeraddr
activePeers)
          , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableToDemote)
          , (HotValency Int
hotTarget, Set peeraddr
members, Set peeraddr
membersActive) <- [(HotValency, Set peeraddr, Set peeraddr)]
groupsAboveTarget
          , let membersAvailableToDemote :: Set peeraddr
membersAvailableToDemote = Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
                                             Set peeraddr
members Set peeraddr
availableToDemote
                numMembersToDemote :: Int
numMembersToDemote       = Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersActive
                                         Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
hotTarget
                                         Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numDemoteInProgress
          , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
membersAvailableToDemote)
          , Int
numMembersToDemote Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
          ]
  , Bool -> Bool
not ([(Int, Set peeraddr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Set peeraddr)]
groupsAvailableToDemote)
  = Maybe Time
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToDemote <-
        [Set peeraddr] -> Set peeraddr
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set peeraddr] -> Set peeraddr)
-> STM m [Set peeraddr] -> STM m (Set peeraddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [STM m (Set peeraddr)] -> STM m [Set peeraddr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
              PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
              Set peeraddr
membersAvailableToDemote
              Int
numMembersToDemote
          | (Int
numMembersToDemote,
             Set peeraddr
membersAvailableToDemote) <- [(Int, Set peeraddr)]
groupsAvailableToDemote ]
      let selectedToDemote' :: Map peeraddr peerconn
          selectedToDemote' = EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers
                                Map peeraddr peerconn -> Set peeraddr -> Map peeraddr peerconn
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
selectedToDemote

      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [[(HotValency, Int)] -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
[(HotValency, Int)] -> Set peeraddr -> TracePeerSelection peeraddr
TraceDemoteLocalHotPeers
                           [ (HotValency
target, Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersActive)
                           | (HotValency
target, Set peeraddr
_, Set peeraddr
membersActive) <- [(HotValency, Set peeraddr, Set peeraddr)]
groupsAboveTarget ]
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressDemoteHot = inProgressDemoteHot
                                             <> selectedToDemote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteActivePeer PeerSelectionActions peeraddr peerconn m
actions peeraddr
peeraddr peerconn
peerconn
                        | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToDemote' ]
      }

  | Bool
otherwise
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing


aboveTargetOther :: forall peeraddr peerconn m.
                    (MonadSTM m, Ord peeraddr, HasCallStack)
                 => PeerSelectionActions peeraddr peerconn m
                 -> MkGuardedDecision peeraddr peerconn m
aboveTargetOther :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetOther PeerSelectionActions peeraddr peerconn m
actions
                 PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
                 }
                 st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                   PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                   LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                   Set peeraddr
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
                   Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
                   targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                               Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers
                             }
                 }
    -- Are we above the general target for number of active peers?
  | Int
numActivePeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
targetNumberOfActivePeers

    -- Would we demote any if we could?
  , let numPeersToDemote :: Int
numPeersToDemote = Int
numActivePeers
                         Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
targetNumberOfActivePeers
                         Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numDemoteInProgress
                         Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
inProgressDemoteToCold)
  , Int
numPeersToDemote Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

    -- Are there any hot peers we actually can pick to demote?
    -- For the moment we say we cannot demote local root peers.
    -- TODO: review this decision. If we want to be able to demote local root
    -- peers, e.g. for churn and improved selection, then we'll need an extra
    -- mechanism to avoid promotion/demotion loops for local peers.
  , let availableToDemote :: Set peeraddr
availableToDemote = Set peeraddr
activePeers
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteHot
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteToCold
  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableToDemote)
  = Maybe Time
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToDemote <- PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
                            PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
                            Set peeraddr
availableToDemote
                            Int
numPeersToDemote
      let selectedToDemote' :: Map peeraddr peerconn
          selectedToDemote' = EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers
                                Map peeraddr peerconn -> Set peeraddr -> Map peeraddr peerconn
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
selectedToDemote

      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
TraceDemoteHotPeers
                           Int
targetNumberOfActivePeers
                           Int
numActivePeers
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressDemoteHot = inProgressDemoteHot
                                             <> selectedToDemote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteActivePeer PeerSelectionActions peeraddr peerconn m
actions peeraddr
peeraddr peerconn
peerconn
                        | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToDemote' ]
      }

  | Bool
otherwise
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet   = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
    PeerSelectionCounters {
        numberOfActivePeers :: PeerSelectionCounters -> Int
numberOfActivePeers          = Int
numActivePeers,
        numberOfActivePeersDemotions :: PeerSelectionCounters -> Int
numberOfActivePeersDemotions = Int
numDemoteInProgress
      }
      =
      PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerSelectionStateToCounters PeerSelectionState peeraddr peerconn
st


jobDemoteActivePeer :: forall peeraddr peerconn m.
                       (Monad m, Ord peeraddr)
                    => PeerSelectionActions peeraddr peerconn m
                    -> peeraddr
                    -> peerconn
                    -> Job () m (Completion m peeraddr peerconn)
jobDemoteActivePeer :: forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteActivePeer PeerSelectionActions{peerStateActions :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> PeerStateActions peeraddr peerconn m
peerStateActions = PeerStateActions {peerconn -> m ()
deactivatePeerConnection :: peerconn -> m ()
deactivatePeerConnection :: forall peeraddr peerconn (m :: * -> *).
PeerStateActions peeraddr peerconn m -> peerconn -> m ()
deactivatePeerConnection}}
                    peeraddr
peeraddr peerconn
peerconn =
    m (Completion m peeraddr peerconn)
-> (SomeException -> m (Completion m peeraddr peerconn))
-> ()
-> String
-> Job () m (Completion m peeraddr peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job m (Completion m peeraddr peerconn)
job SomeException -> m (Completion m peeraddr peerconn)
handler () String
"demoteActivePeer"
  where
    handler :: SomeException -> m (Completion m peeraddr peerconn)
    handler :: SomeException -> m (Completion m peeraddr peerconn)
handler SomeException
e = Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$
      -- It's quite bad if demoting fails. The peer is cooling so
      -- we can't remove it from the set of established and hot peers.
      --
      (PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall (m :: * -> *) peeraddr peerconn.
(PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
Completion ((PeerSelectionState peeraddr peerconn
  -> Time -> Decision m peeraddr peerconn)
 -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                      PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                      Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                      Set peeraddr
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
                      targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                  Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers,
                                  Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers
                                }
                    }
                    Time
_ ->
        let
            inProgressDemoteHot' :: Set peeraddr
inProgressDemoteHot'  = peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => a -> Set a -> Set a
Set.delete peeraddr
peeraddr Set peeraddr
inProgressDemoteHot
            bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet     = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
         in Decision {
              decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                              then [Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
forall peeraddr.
Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
TraceDemoteHotBigLedgerPeerFailed
                                     Int
targetNumberOfActiveBigLedgerPeers
                                     (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers
                                                 Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                                                 Set peeraddr
bigLedgerPeersSet)
                                     peeraddr
peeraddr SomeException
e]
                              else [Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
forall peeraddr.
Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
TraceDemoteHotFailed
                                     Int
targetNumberOfActivePeers
                                     (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers
                                          Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet)
                                     peeraddr
peeraddr SomeException
e],
              decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                                inProgressDemoteHot = inProgressDemoteHot'
                              },
              decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
            }

    job :: m (Completion m peeraddr peerconn)
    job :: m (Completion m peeraddr peerconn)
job = do
      peerconn -> m ()
deactivatePeerConnection peerconn
peerconn
      Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ (PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall (m :: * -> *) peeraddr peerconn.
(PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
Completion ((PeerSelectionState peeraddr peerconn
  -> Time -> Decision m peeraddr peerconn)
 -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                                PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                                Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                                KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
                                targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                            Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers,
                                            Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers
                                          }
                             }
                             Time
_now ->
        Bool
-> Decision m peeraddr peerconn -> Decision m peeraddr peerconn
forall a. HasCallStack => Bool -> a -> a
assert (peeraddr
peeraddr peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
forall peeraddr peerconn.
Ord peeraddr =>
peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
`EstablishedPeers.member` PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers PeerSelectionState peeraddr peerconn
st) (Decision m peeraddr peerconn -> Decision m peeraddr peerconn)
-> Decision m peeraddr peerconn -> Decision m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$
        let activePeers' :: Set peeraddr
activePeers' = peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => a -> Set a -> Set a
Set.delete peeraddr
peeraddr Set peeraddr
activePeers
            knownPeers' :: KnownPeers peeraddr
knownPeers'  = peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
setTepidFlag peeraddr
peeraddr KnownPeers peeraddr
knownPeers
            bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
         in Decision {
              decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                              then [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TraceDemoteHotBigLedgerPeerDone
                                     Int
targetNumberOfActiveBigLedgerPeers
                                     (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers'
                                                 Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection`
                                                 Set peeraddr
bigLedgerPeersSet)
                                     peeraddr
peeraddr]
                              else [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TraceDemoteHotDone
                                     Int
targetNumberOfActivePeers
                                     (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
activePeers'
                                          Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet)
                                     peeraddr
peeraddr],
              decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                                activePeers         = activePeers',
                                knownPeers          = knownPeers',
                                inProgressDemoteHot = Set.delete peeraddr
                                                        (inProgressDemoteHot st)
                              },
              decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
            }