{-# 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.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
import Ouroboros.Network.PeerSelection.Types (PublicExtraPeersAPI (..))


----------------------------
-- 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 extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( Alternative (STM m)
     , MonadDelay m
     , MonadSTM m
     , Ord peeraddr
     , HasCallStack
     )
  => (extraState -> Bool)
  -- ^ This argument enables or disables this monitoring action based
  -- on an 'extraState' flag.
  --
  -- This might be useful if the user requires its diffusion layer to
  -- stop making progress during a sensitive/vulnerable situation and
  -- quarantine it and make sure it is only connected to trusted peers.
  -> PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
belowTarget :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Alternative (STM m), MonadDelay m, MonadSTM m, Ord peeraddr,
 HasCallStack) =>
(extraState -> Bool)
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
belowTarget extraState -> Bool
enableAction = (extraState -> Bool)
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr) =>
(extraState -> Bool)
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
belowTargetBigLedgerPeers extraState -> Bool
enableAction
                         (PeerSelectionActions
   extraState
   extraFlags
   extraPeers
   extraAPI
   extraCounters
   peeraddr
   peerconn
   m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> (PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState
         extraState extraFlags extraPeers peeraddr peerconn
    -> Guarded
         (STM m)
         (TimedDecision
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
belowTargetLocal
                         (PeerSelectionActions
   extraState
   extraFlags
   extraPeers
   extraAPI
   extraCounters
   peeraddr
   peerconn
   m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> (PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState
         extraState extraFlags extraPeers peeraddr peerconn
    -> Guarded
         (STM m)
         (TimedDecision
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     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 extraState extraDebugState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn m.
     ( MonadDelay m
     , MonadSTM m
     , Ord peeraddr
     )
  => (extraState -> Bool)
  -- ^ This argument enables or disables this monitoring
  -- action based on an 'extraState' flag.
  --
  -- This might be useful if the user requires its
  -- diffusion layer to stop making progress during a
  -- sensitive/vulnerable situation and quarantine it
  -- and make sure it is only connected to trusted peers.
  -> PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
belowTargetBigLedgerPeers :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr) =>
(extraState -> Bool)
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
belowTargetBigLedgerPeers extraState -> Bool
enableAction
                          actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@PeerSelectionActions {
                            extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                              peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers,
                              extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet
                            },
                            PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters
                          }
                          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
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                            PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers,
                            EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers,
                            Set peeraddr
activePeers :: Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers,
                            Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteWarm,
                            Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteWarm,
                            Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteToCold,
                            targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                                        Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers
                                      },
                            extraState
extraState :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraState
extraState :: extraState
extraState
                          }
    -- 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
  , extraState -> Bool
enableAction extraState
extraState
  = Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToPromote <- (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers peeraddr -> extraPeers -> Bool
memberExtraPeers PeerSelectionState
  extraState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePromoteWarmBigLedgerPeers
                           Int
targetNumberOfActiveBigLedgerPeers
                           Int
numActiveBigLedgerPeers
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressPromoteWarm = inProgressPromoteWarm
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [ PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPromoteWarmPeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
    PeerSelectionCounters {
        numberOfActiveBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfActiveBigLedgerPeers         = Int
numActiveBigLedgerPeers,
        numberOfWarmBigLedgerPeersPromotions :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfWarmBigLedgerPeersPromotions = Int
numPromoteInProgressBigLedgerPeers
      }
      =
      (extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
forall peeraddr extraPeers extraState extraFlags peerconn
       extraCounters.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
peerSelectionStateToCounters extraPeers -> Set peeraddr
extraPeersToSet PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st


belowTargetLocal
  :: forall extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( MonadDelay m
     , MonadSTM m
     , Ord peeraddr
     , HasCallStack
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
belowTargetLocal :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
belowTargetLocal actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@PeerSelectionActions {
                   extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                     peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers
                   }
                 }
                 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
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                   PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
                   LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                   Set peeraddr
inProgressPromoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm,
                   Set peeraddr
inProgressDemoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm,
                   Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers 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 extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags 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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        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
          [ (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers peeraddr -> extraPeers -> Bool
memberExtraPeers PeerSelectionState
  extraState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [[(HotValency, Int)]
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[(HotValency, Int)]
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressPromoteWarm = inProgressPromoteWarm
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [ PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPromoteWarmPeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  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 extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags 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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
    groupsBelowTarget :: [(HotValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget =
      [ (HotValency
hotValency, Set peeraddr
members, Set peeraddr
membersActive)
      | (HotValency
hotValency, WarmValency
_, Set peeraddr
members) <- LocalRootPeers extraFlags peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
LocalRootPeers.toGroupSets LocalRootPeers extraFlags 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 extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( MonadDelay m
     , MonadSTM m
     , Ord peeraddr
     , HasCallStack
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
belowTargetOther :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
belowTargetOther actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@PeerSelectionActions {
                   extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                     peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers,
                     extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet
                   },
                   PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters
                 }
                 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
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                   LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                   Set peeraddr
inProgressPromoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm,
                   Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
                   Set peeraddr
inProgressDemoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm,
                   targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers 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 extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags 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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToPromote <- (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers peeraddr -> extraPeers -> Bool
memberExtraPeers PeerSelectionState
  extraState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePromoteWarmPeers
                           Int
targetNumberOfActivePeers
                           Int
numActivePeers
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressPromoteWarm = inProgressPromoteWarm
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [ PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPromoteWarmPeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    PeerSelectionView {
        viewActivePeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewActivePeers         = (Set peeraddr
_, Int
numActivePeers),
        viewWarmPeersPromotions :: forall extraViews a. PeerSelectionView extraViews a -> a
viewWarmPeersPromotions = (Set peeraddr
_, Int
numPromoteInProgress),
        viewKnownBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewKnownBigLedgerPeers = (Set peeraddr
bigLedgerPeersSet, Int
_)
      }
      =
      (extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionView extraCounters (Set peeraddr, Int)
forall peeraddr extraPeers extraState extraFlags peerconn
       extraViews.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraViews)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionSetsWithSizes extraViews peeraddr
peerSelectionStateToView extraPeers -> Set peeraddr
extraPeersToSet PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st


jobPromoteWarmPeer
  :: forall extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( MonadDelay m
     , Ord peeraddr
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> PeerSelectionPolicy peeraddr m
  -> peeraddr
  -> IsBigLedgerPeer
  -> peerconn
  -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr
                         peerconn)
jobPromoteWarmPeer :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadDelay m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPromoteWarmPeer PeerSelectionActions{peerStateActions :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  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
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
-> (SomeException
    -> m (Completion
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> ()
-> String
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
job SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
handler () String
"promoteWarmPeer"
  where
    handler :: SomeException
            -> m (Completion m extraState extraDebugState extraFlags extraPeers
                             peeraddr peerconn)
    handler :: SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        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
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$
        -- When promotion fails we set the peer as cold.
        (PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
(PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
Completion ((PeerSelectionState
    extraState extraFlags extraPeers peeraddr peerconn
  -> Time
  -> Decision
       m
       extraState
       extraDebugState
       extraFlags
       extraPeers
       peeraddr
       peerconn)
 -> Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                                 PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
                                 Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                                 EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                                 KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers,
                                 StdGen
stdGen :: StdGen
stdGen :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> StdGen
stdGen,
                                 targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers 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 extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
           in if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteWarm PeerSelectionState
  extraState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> SomeException
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> SomeException
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                                          inProgressPromoteWarm = Set.delete peeraddr
                                                                    (inProgressPromoteWarm st),
                                          knownPeers            = knownPeers',
                                          establishedPeers      = establishedPeers',
                                          stdGen                = stdGen'
                                        },
                        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
                      }
                 else Decision {
                        decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st,
                        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
                      }


    job :: m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
    job :: m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
job = do
      IsBigLedgerPeer -> peerconn -> m ()
activatePeerConnection IsBigLedgerPeer
isBigLedgerPeer peerconn
peerconn
      Completion
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ (PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
(PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
Completion ((PeerSelectionState
    extraState extraFlags extraPeers peeraddr peerconn
  -> Time
  -> Decision
       m
       extraState
       extraDebugState
       extraFlags
       extraPeers
       peeraddr
       peerconn)
 -> Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                               PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
                               Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                               targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                                           Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers
                                         }
                             }
                           Time
_now ->
        let bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
         in if peeraddr
peeraddr peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
forall peeraddr peerconn.
Ord peeraddr =>
peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
`EstablishedPeers.member` PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers PeerSelectionState
  extraState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                                        activePeers           = activePeers',
                                        inProgressPromoteWarm = Set.delete peeraddr
                                                                  (inProgressPromoteWarm st)
                                      },
                      decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
                    }
               else
                 Decision {
                   decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st,
                   decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      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 extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( Alternative (STM m)
     , MonadSTM m
     , Ord peeraddr
     , HasCallStack
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
aboveTarget :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Alternative (STM m), MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
aboveTarget = PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
aboveTargetBigLedgerPeers
           (PeerSelectionActions
   extraState
   extraFlags
   extraPeers
   extraAPI
   extraCounters
   peeraddr
   peerconn
   m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> (PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState
         extraState extraFlags extraPeers peeraddr peerconn
    -> Guarded
         (STM m)
         (TimedDecision
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
aboveTargetLocal
           (PeerSelectionActions
   extraState
   extraFlags
   extraPeers
   extraAPI
   extraCounters
   peeraddr
   peerconn
   m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> (PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState
         extraState extraFlags extraPeers peeraddr peerconn
    -> Guarded
         (STM m)
         (TimedDecision
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     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 extraState extraDebugState extraFlags extraPeers extraAPI
           extraCounters peeraddr peerconn m.
     ( MonadSTM m
     , Ord peeraddr
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
aboveTargetBigLedgerPeers :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
aboveTargetBigLedgerPeers actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@PeerSelectionActions {
                            extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                              peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers,
                              extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet
                            },
                            PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters
                          }
                          PeerSelectionPolicy {
                            PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
                          }
                          st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                            PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
                            LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers,
                            EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                            Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                            Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteHot,
                            Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
                            targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers 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 extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags peeraddr
localRootPeers
  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableToDemote)
  = Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToDemote <- (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers peeraddr -> extraPeers -> Bool
memberExtraPeers PeerSelectionState
  extraState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceDemoteHotBigLedgerPeers
                           Int
targetNumberOfActiveBigLedgerPeers
                           Int
numActiveBigLedgerPeers
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressDemoteHot = inProgressDemoteHot
                                             <> selectedToDemote
                        },
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [ PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobDemoteActivePeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
    PeerSelectionCounters {
        numberOfActiveBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfActiveBigLedgerPeers          = Int
numActiveBigLedgerPeers,
        numberOfActiveBigLedgerPeersDemotions :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfActiveBigLedgerPeersDemotions = Int
numDemoteInProgressBigLedgerPeers
      }
      = (extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
forall peeraddr extraPeers extraState extraFlags peerconn
       extraCounters.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
peerSelectionStateToCounters extraPeers -> Set peeraddr
extraPeersToSet PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st


aboveTargetLocal
  :: forall extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( MonadSTM m
     , Ord peeraddr
     , HasCallStack
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
aboveTargetLocal :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
aboveTargetLocal actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@PeerSelectionActions {
                   extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                     peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers
                   }
                 }
                 PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
                 }
                 st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                   LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                   Set peeraddr
inProgressDemoteHot :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
                   Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers 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 extraFlags peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
LocalRootPeers.toGroupSets LocalRootPeers extraFlags 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 extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags 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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        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
          [ (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers peeraddr -> extraPeers -> Bool
memberExtraPeers PeerSelectionState
  extraState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [[(HotValency, Int)]
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[(HotValency, Int)]
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressDemoteHot = inProgressDemoteHot
                                             <> selectedToDemote
                        },
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [ PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobDemoteActivePeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing


aboveTargetOther
  :: forall extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( MonadSTM m
     , Ord peeraddr
     , HasCallStack
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
aboveTargetOther :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
aboveTargetOther actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@PeerSelectionActions {
                   extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                     peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers,
                     extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet
                   },
                   PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters
                 }
                 PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickHotPeersToDemote
                 }
                 st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                   PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
                   LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                   Set peeraddr
inProgressDemoteHot :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
                   Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
                   targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers 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 extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags 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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToDemote <- (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers peeraddr -> extraPeers -> Bool
memberExtraPeers PeerSelectionState
  extraState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceDemoteHotPeers
                           Int
targetNumberOfActivePeers
                           Int
numActivePeers
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressDemoteHot = inProgressDemoteHot
                                             <> selectedToDemote
                        },
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [ PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobDemoteActivePeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet   = PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
    PeerSelectionCounters {
        numberOfActivePeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfActivePeers          = Int
numActivePeers,
        numberOfActivePeersDemotions :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfActivePeersDemotions = Int
numDemoteInProgress
      }
      =
      (extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
forall peeraddr extraPeers extraState extraFlags peerconn
       extraCounters.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
peerSelectionStateToCounters extraPeers -> Set peeraddr
extraPeersToSet PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st


jobDemoteActivePeer
  :: forall extraState extraDebugState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn m.
     ( Monad m
     , Ord peeraddr
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> peeraddr
  -> peerconn
  -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr
                          peerconn)
jobDemoteActivePeer :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobDemoteActivePeer PeerSelectionActions{peerStateActions :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  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
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
-> (SomeException
    -> m (Completion
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> ()
-> String
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
job SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
handler () String
"demoteActivePeer"
  where
    handler :: SomeException -> m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
    handler :: SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
handler SomeException
e = Completion
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        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
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
(PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
Completion ((PeerSelectionState
    extraState extraFlags extraPeers peeraddr peerconn
  -> Time
  -> Decision
       m
       extraState
       extraDebugState
       extraFlags
       extraPeers
       peeraddr
       peerconn)
 -> Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                      PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
                      Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                      Set peeraddr
inProgressDemoteHot :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
                      targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers 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 extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
         in Decision {
              decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> SomeException
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> SomeException
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                                inProgressDemoteHot = inProgressDemoteHot'
                              },
              decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
            }

    job :: m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
    job :: m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
job = do
      peerconn -> m ()
deactivatePeerConnection peerconn
peerconn
      Completion
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ (PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
(PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
Completion ((PeerSelectionState
    extraState extraFlags extraPeers peeraddr peerconn
  -> Time
  -> Decision
       m
       extraState
       extraDebugState
       extraFlags
       extraPeers
       peeraddr
       peerconn)
 -> Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                                PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
                                Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                                KnownPeers peeraddr
knownPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
                                targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                                            Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers :: Int
targetNumberOfActivePeers,
                                            Int
targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers
                                          }
                             }
                             Time
_now ->
        Bool
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     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
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st) (Decision
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     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 extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
         in Decision {
              decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                                activePeers         = activePeers',
                                knownPeers          = knownPeers',
                                inProgressDemoteHot = Set.delete peeraddr
                                                        (inProgressDemoteHot st)
                              },
              decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
            }