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

module Ouroboros.Network.PeerSelection.Governor.EstablishedPeers
  ( belowTarget
  , aboveTarget
  ) 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)
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime.SI
import System.Random (randomR)

import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
import Ouroboros.Network.PeerSelection.Governor.Types
import Ouroboros.Network.PeerSelection.LedgerPeers.Type (IsBigLedgerPeer (..))
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers
import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (WarmValency (..))
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers
import Ouroboros.Network.PeerSelection.Types (PublicExtraPeersAPI (..))


---------------------------------
-- Established peers below target
--


-- | If we are below the target of /warm peers/ we promote /cold peers/
-- according to 'policyPickColdPeersToPromote'.
--
-- There are two targets we are trying to hit here:
--
-- 1. a target for the overall number of established peers; and
-- 2. the target that all local root peers are established peers.
--
-- These two targets overlap: the conditions and the actions overlap since local
-- root peers are also known peers. Since they overlap, the order in which we
-- consider these targets is important. We consider the local peers target
-- /before/ the target for promoting other peers.
--
-- We will /always/ try to establish connections to the local root peers, even
-- if that would put us over target for the number of established peers. If we
-- do go over target then the action to demote will be triggered. The demote
-- action never picks local root peers.
--
belowTarget
  :: forall extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( Alternative (STM 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
belowTarget :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Alternative (STM m), MonadSTM m, Ord peeraddr) =>
(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 :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
(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 :: * -> *).
(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 :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
belowTargetOther


-- | For locally configured root peers we have the explicit target that comes from local
-- configuration.
--
belowTargetLocal
  :: 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
belowTargetLocal :: 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
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 :: 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)
policyPickColdPeersToPromote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote :: PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote
                 }
                 st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                   LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers,
                   KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers,
                   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
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteCold,
                   Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteToCold
                 }

    -- Are there any groups of local peers that are below target?
  | Bool -> Bool
not ([(WarmValency, Set peeraddr, Set peeraddr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(WarmValency, 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. We need to take into account peers which are being
    -- promoted to Warm, and peers which are being demoted to Cold.

    -- 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 =
                  Set peeraddr
localAvailableToConnect
                     Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
localEstablishedPeers
                     Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
localConnectInProgress
                     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
availableToPromote)
          , (WarmValency Int
warmTarget, Set peeraddr
members, Set peeraddr
membersEstablished) <- [(WarmValency, 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
warmTarget
                                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersEstablished
                                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLocalConnectInProgress
          , 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)
policyPickColdPeersToPromote
              Set peeraddr
membersAvailableToPromote
              Int
numMembersToPromote
          | (Int
numMembersToPromote,
             Set peeraddr
membersAvailableToPromote) <- [(Int, Set peeraddr)]
groupsAvailableToPromote ]

      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [[(WarmValency, Int)]
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[(WarmValency, Int)]
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePromoteColdLocalPeers
                           [ (WarmValency
target, Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersEstablished)
                           | (WarmValency
target, Set peeraddr
_, Set peeraddr
membersEstablished) <- [(WarmValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget ]
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressPromoteCold = inProgressPromoteCold
                                               <> 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
-> DiffusionMode
-> 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
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> DiffusionMode
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPromoteColdPeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peer IsBigLedgerPeer
IsNotBigLedgerPeer DiffusionMode
diffusionMode
                        | peeraddr
peer <- Set peeraddr -> [peeraddr]
forall a. Set a -> [a]
Set.toList Set peeraddr
selectedToPromote
                        , let diffusionMode :: DiffusionMode
diffusionMode = LocalRootConfig extraFlags -> DiffusionMode
forall extraFlags. LocalRootConfig extraFlags -> DiffusionMode
LocalRootPeers.diffusionMode
                                            (LocalRootConfig extraFlags -> DiffusionMode)
-> LocalRootConfig extraFlags -> DiffusionMode
forall a b. (a -> b) -> a -> b
$ LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
LocalRootPeers.toMap LocalRootPeers extraFlags peeraddr
localRootPeers Map peeraddr (LocalRootConfig extraFlags)
-> peeraddr -> LocalRootConfig extraFlags
forall k a. Ord k => Map k a -> k -> a
Map.! peeraddr
peer
                        ]
      }

    -- If we could promote except that there are no peers currently available
    -- then we return the next wakeup time (if any)
  | Bool -> Bool
not ([(WarmValency, Set peeraddr, Set peeraddr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(WarmValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget)
  , let potentialToPromote :: Set peeraddr
potentialToPromote =
          -- These are local peers that are cold but not ready.
          Set peeraddr
localRootPeersSet
             Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
localEstablishedPeers
             Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.availableToConnect KnownPeers peeraddr
knownPeers
  , 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 (KnownPeers peeraddr -> (peeraddr -> Bool) -> Maybe Time
forall peeraddr.
Ord peeraddr =>
KnownPeers peeraddr -> (peeraddr -> Bool) -> Maybe Time
KnownPeers.minConnectTime KnownPeers peeraddr
knownPeers (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
    groupsBelowTarget :: [(WarmValency, Set peeraddr, Set peeraddr)]
groupsBelowTarget =
      [ (WarmValency
warmValency, Set peeraddr
members, Set peeraddr
membersEstablished)
      | (HotValency
_, WarmValency
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 membersEstablished :: Set peeraddr
membersEstablished = Set peeraddr
members 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 -> Int
forall a. Set a -> Int
Set.size Set peeraddr
membersEstablished Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< WarmValency -> Int
getWarmValency WarmValency
warmValency
      ]

    PeerSelectionView {
        viewKnownBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewKnownBigLedgerPeers              = (Set peeraddr
bigLedgerPeersSet, Int
_),
        viewKnownLocalRootPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewKnownLocalRootPeers              = (Set peeraddr
localRootPeersSet, Int
_),
        viewEstablishedLocalRootPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewEstablishedLocalRootPeers        = (Set peeraddr
localEstablishedPeers, Int
_),
        viewAvailableToConnectLocalRootPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewAvailableToConnectLocalRootPeers = (Set peeraddr
localAvailableToConnect, Int
_),
        viewColdLocalRootPeersPromotions :: forall extraViews a. PeerSelectionView extraViews a -> a
viewColdLocalRootPeersPromotions     = (Set peeraddr
localConnectInProgress, Int
numLocalConnectInProgress)
      } = (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


belowTargetOther
  :: 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
belowTargetOther :: 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
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)
policyPickColdPeersToPromote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote :: PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote
                 }
                 st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                   KnownPeers peeraddr
knownPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
                   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
inProgressPromoteCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold,
                   targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                               Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers
                             }
                 }
    -- Are we below the target for number of established peers?
  | Int
numEstablishedPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numConnectInProgress Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfEstablishedPeers

    -- Are there any cold peers we could possibly pick to connect to?
    -- We can subtract the established ones because by definition they are
    -- not cold and our invariant is that they are always in the connect set.
    -- We can also subtract the in progress ones since they are also already
    -- in the connect set and we cannot pick them again.
  , Int
numAvailableToConnect Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numEstablishedPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numConnectInProgress 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
      -- The availableToPromote here is non-empty due to the second guard.
      -- The known peers map restricted to the connect set is the same size as
      -- the connect set (because it is a subset). The establishedPeers is a
      -- subset of the connect set and we also know that there is no overlap
      -- between inProgressPromoteCold and establishedPeers. QED.
      --
      -- The numPeersToPromote is positive based on the first guard.
      --
      let availableToPromote :: Set peeraddr
          availableToPromote :: Set peeraddr
availableToPromote = Set peeraddr
availableToConnect
                                 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.
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
inProgressPromoteCold
          numPeersToPromote :: Int
numPeersToPromote  = Int
targetNumberOfEstablishedPeers
                             Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numEstablishedPeers
                             Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numConnectInProgress
      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)
policyPickColdPeersToPromote
                             Set peeraddr
availableToPromote
                             Int
numPeersToPromote
      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
TracePromoteColdPeers
                           Int
targetNumberOfEstablishedPeers
                           Int
numEstablishedPeers
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressPromoteCold = inProgressPromoteCold
                                               <> 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
-> DiffusionMode
-> 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
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> DiffusionMode
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPromoteColdPeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peer IsBigLedgerPeer
IsNotBigLedgerPeer DiffusionMode
InitiatorAndResponderDiffusionMode
                        | peeraddr
peer <- Set peeraddr -> [peeraddr]
forall a. Set a -> [a]
Set.toList Set peeraddr
selectedToPromote ]
      }

    -- If we could connect except that there are no peers currently available
    -- then we return the next wakeup time (if any)
  | Int
numEstablishedPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numConnectInProgress Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfEstablishedPeers
  = Maybe Time
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip (KnownPeers peeraddr -> (peeraddr -> Bool) -> Maybe Time
forall peeraddr.
Ord peeraddr =>
KnownPeers peeraddr -> (peeraddr -> Bool) -> Maybe Time
KnownPeers.minConnectTime KnownPeers peeraddr
knownPeers (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 {
        viewKnownBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewKnownBigLedgerPeers     = (Set peeraddr
bigLedgerPeersSet, Int
_),

        viewAvailableToConnectPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewAvailableToConnectPeers = (Set peeraddr
availableToConnect, Int
numAvailableToConnect),
        viewEstablishedPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewEstablishedPeers        = (Set peeraddr
_, Int
numEstablishedPeers),
        viewColdPeersPromotions :: forall extraViews a. PeerSelectionView extraViews a -> a
viewColdPeersPromotions     = (Set peeraddr
_, Int
numConnectInProgress)
      }
      =
      (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


-- |
--
-- 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.
     ( 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
belowTargetBigLedgerPeers :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (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
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 :: 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)
policyPickColdPeersToPromote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote :: PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote
                          }
                          st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                            KnownPeers peeraddr
knownPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
                            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
inProgressPromoteCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold,
                            targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                                        Int
targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers
                                      },
                            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 established peers?
  | Int
numEstablishedPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numConnectInProgress
      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfEstablishedBigLedgerPeers

    -- Are there any cold peers we could possibly pick to connect to?
    -- We can subtract the established ones because by definition they are
    -- not cold and our invariant is that they are always in the connect set.
    -- We can also subtract the in progress ones since they are also already
    -- in the connect set and we cannot pick them again.
  , Int
numAvailableToConnect Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numEstablishedPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numConnectInProgress 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
      -- The availableToPromote here is non-empty due to the second guard.
      -- The known peers map restricted to the connect set is the same size as
      -- the connect set (because it is a subset). The establishedPeers is a
      -- subset of the connect set and we also know that there is no overlap
      -- between inProgressPromoteCold and establishedPeers. QED.
      --
      -- The numPeersToPromote is positive based on the first guard.
      --
      let availableToPromote :: Set peeraddr
          availableToPromote :: Set peeraddr
availableToPromote = Set peeraddr
availableToConnect
                                 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.
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
inProgressPromoteCold
          numPeersToPromote :: Int
numPeersToPromote  = Int
targetNumberOfEstablishedBigLedgerPeers
                             Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numEstablishedPeers
                             Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numConnectInProgress
      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)
policyPickColdPeersToPromote
                             Set peeraddr
availableToPromote
                             Int
numPeersToPromote
      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
TracePromoteColdBigLedgerPeers
                           Int
targetNumberOfEstablishedBigLedgerPeers
                           Int
numEstablishedPeers
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressPromoteCold = inProgressPromoteCold
                                               <> 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
-> DiffusionMode
-> 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
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> DiffusionMode
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPromoteColdPeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peer IsBigLedgerPeer
IsBigLedgerPeer DiffusionMode
InitiatorAndResponderDiffusionMode
                        | peeraddr
peer <- Set peeraddr -> [peeraddr]
forall a. Set a -> [a]
Set.toList Set peeraddr
selectedToPromote ]
      }

    -- If we could connect except that there are no peers currently available
    -- then we return the next wakeup time (if any)
  | Int
numEstablishedPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numConnectInProgress
      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfEstablishedBigLedgerPeers
  = Maybe Time
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip (KnownPeers peeraddr -> (peeraddr -> Bool) -> Maybe Time
forall peeraddr.
Ord peeraddr =>
KnownPeers peeraddr -> (peeraddr -> Bool) -> Maybe Time
KnownPeers.minConnectTime KnownPeers peeraddr
knownPeers  (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
    PeerSelectionView {
        viewKnownBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewKnownBigLedgerPeers              = (Set peeraddr
bigLedgerPeersSet, Int
_),
        viewAvailableToConnectBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewAvailableToConnectBigLedgerPeers = (Set peeraddr
availableToConnect, Int
numAvailableToConnect),
        viewEstablishedBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewEstablishedBigLedgerPeers        = (Set peeraddr
_, Int
numEstablishedPeers),
        viewColdBigLedgerPeersPromotions :: forall extraViews a. PeerSelectionView extraViews a -> a
viewColdBigLedgerPeersPromotions     = (Set peeraddr
_, Int
numConnectInProgress)
      }
      =
      (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


-- | Must be larger than '2' since we add a random value drawn from '(-2, 2)`.
--
baseColdPeerRetryDiffTime :: Int
baseColdPeerRetryDiffTime :: Int
baseColdPeerRetryDiffTime = Int
5

maxColdPeerRetryBackoff :: Int
maxColdPeerRetryBackoff :: Int
maxColdPeerRetryBackoff = Int
5


jobPromoteColdPeer
  :: forall extraState extraDebugState extraFlags extraPeers extraAPI
           extraCounters peeraddr peerconn m.
     ( Monad m
     , Ord peeraddr
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> PeerSelectionPolicy peeraddr m
  -> peeraddr
  -> IsBigLedgerPeer
  -> DiffusionMode
  -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers
                          peeraddr peerconn)
jobPromoteColdPeer :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> DiffusionMode
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPromoteColdPeer 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 -> DiffusionMode -> peeraddr -> m peerconn
establishPeerConnection :: IsBigLedgerPeer -> DiffusionMode -> peeraddr -> m peerconn
establishPeerConnection :: forall peeraddr peerconn (m :: * -> *).
PeerStateActions peeraddr peerconn m
-> IsBigLedgerPeer -> DiffusionMode -> peeraddr -> m peerconn
establishPeerConnection},
                     peerconn -> PeerSharing
peerConnToPeerSharing :: peerconn -> PeerSharing
peerConnToPeerSharing :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peerconn -> PeerSharing
peerConnToPeerSharing,
                     extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                       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 { DiffTime
policyPeerShareActivationDelay :: DiffTime
policyPeerShareActivationDelay :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> DiffTime
policyPeerShareActivationDelay }
                   peeraddr
peeraddr IsBigLedgerPeer
isBigLedgerPeer DiffusionMode
diffusionMode =
    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
"promoteColdPeer"
  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
$
      (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 :: PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers,
                      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
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers,
                                  Int
targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers
                                }
                    }
                    Time
now ->
        let (Int
failCount, KnownPeers peeraddr
knownPeers') = peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
KnownPeers.incrementFailCount
                                         peeraddr
peeraddr
                                         (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st)
            (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

            -- exponential backoff: 5s, 10s, 20s, 40s, 80s, 160s.
            delay :: DiffTime
            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
+ Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                      ( Int
baseColdPeerRetryDiffTime
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int -> Int
forall a. Enum a => a -> a
pred Int
failCount Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
maxColdPeerRetryBackoff)
                      )
            bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers

            st' :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st' = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { knownPeers            = KnownPeers.setConnectTimes
                                                 (Map.singleton
                                                   peeraddr
                                                   (delay `addTime` now))
                                                 knownPeers',
                       inProgressPromoteCold = Set.delete peeraddr
                                                 (inProgressPromoteCold st),
                       stdGen = stdGen'
                     }
            cs' :: PeerSelectionCounters extraCounters
cs' = (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'
        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
-> DiffTime
-> SomeException
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> DiffTime
-> SomeException
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePromoteColdBigLedgerPeerFailed
                                   Int
targetNumberOfEstablishedBigLedgerPeers
                                   (case PeerSelectionCounters extraCounters
cs' of
                                     PeerSelectionCounters { numberOfEstablishedBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfEstablishedBigLedgerPeers = Int
a } -> Int
a)
                                   peeraddr
peeraddr DiffTime
delay SomeException
e]
                            else [Int
-> Int
-> peeraddr
-> DiffTime
-> SomeException
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> DiffTime
-> SomeException
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePromoteColdFailed
                                   Int
targetNumberOfEstablishedPeers
                                   (case PeerSelectionCounters extraCounters
cs' of
                                     PeerSelectionCounters { numberOfEstablishedPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfEstablishedPeers = Int
a } -> Int
a)
                                   peeraddr
peeraddr DiffTime
delay SomeException
e],
            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
      --TODO: decide if we should do timeouts here or if we should make that
      -- the responsibility of establishPeerConnection
      peerconn <- IsBigLedgerPeer -> DiffusionMode -> peeraddr -> m peerconn
establishPeerConnection IsBigLedgerPeer
isBigLedgerPeer DiffusionMode
diffusionMode peeraddr
peeraddr
      let !peerSharing = peerconn -> PeerSharing
peerConnToPeerSharing peerconn
peerconn

      return $ Completion $ \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,
                               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 :: 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
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers,
                                           Int
targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers
                                         }
                             }
                             Time
now ->
        let psTime :: Maybe Time
psTime = case PeerSharing
peerSharing of
                          PeerSharing
PeerSharingEnabled  -> Time -> Maybe Time
forall a. a -> Maybe a
Just (DiffTime -> Time -> Time
addTime DiffTime
policyPeerShareActivationDelay Time
now)
                          PeerSharing
PeerSharingDisabled -> Maybe Time
forall a. Maybe a
Nothing
            establishedPeers' :: EstablishedPeers peeraddr peerconn
establishedPeers' = peeraddr
-> peerconn
-> Maybe Time
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall peeraddr peerconn.
Ord peeraddr =>
peeraddr
-> peerconn
-> Maybe Time
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
EstablishedPeers.insert peeraddr
peeraddr peerconn
peerconn Maybe Time
psTime EstablishedPeers peeraddr peerconn
establishedPeers
            advertise :: PeerAdvertise
advertise = case PeerSharing
peerSharing of
                          PeerSharing
PeerSharingEnabled  -> PeerAdvertise
DoAdvertisePeer
                          PeerSharing
PeerSharingDisabled -> PeerAdvertise
DoNotAdvertisePeer
            -- Update PeerSharing value in KnownPeers
            knownPeers' :: KnownPeers peeraddr
knownPeers'       = (Maybe KnownPeerInfo -> Maybe KnownPeerInfo)
-> Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
(Maybe KnownPeerInfo -> Maybe KnownPeerInfo)
-> Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.alter
                                  (\Maybe KnownPeerInfo
x -> case Maybe KnownPeerInfo
x of
                                    Maybe KnownPeerInfo
Nothing ->
                                      (Maybe PeerSharing, Maybe PeerAdvertise)
-> Maybe KnownPeerInfo -> Maybe KnownPeerInfo
KnownPeers.alterKnownPeerInfo
                                        (PeerSharing -> Maybe PeerSharing
forall a. a -> Maybe a
Just PeerSharing
peerSharing, PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
advertise)
                                        Maybe KnownPeerInfo
x
                                    Just KnownPeerInfo
_ ->
                                      (Maybe PeerSharing, Maybe PeerAdvertise)
-> Maybe KnownPeerInfo -> Maybe KnownPeerInfo
KnownPeers.alterKnownPeerInfo
                                        (PeerSharing -> Maybe PeerSharing
forall a. a -> Maybe a
Just PeerSharing
peerSharing, Maybe PeerAdvertise
forall a. Maybe a
Nothing)
                                        Maybe KnownPeerInfo
x
                                  )
                                  (peeraddr -> Set peeraddr
forall a. a -> Set a
Set.singleton peeraddr
peeraddr)
                              (KnownPeers peeraddr -> KnownPeers peeraddr)
-> KnownPeers peeraddr -> KnownPeers peeraddr
forall a b. (a -> b) -> a -> b
$ Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.setSuccessfulConnectionFlag (peeraddr -> Set peeraddr
forall a. a -> Set a
Set.singleton peeraddr
peeraddr)
                              (KnownPeers peeraddr -> KnownPeers peeraddr)
-> KnownPeers peeraddr -> KnownPeers peeraddr
forall a b. (a -> b) -> a -> b
$ peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.clearTepidFlag peeraddr
peeraddr (KnownPeers peeraddr -> KnownPeers peeraddr)
-> KnownPeers peeraddr -> KnownPeers peeraddr
forall a b. (a -> b) -> a -> b
$
                                    peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.resetFailCount
                                        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

            st' :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st' = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { establishedPeers      = establishedPeers',
                       inProgressPromoteCold = Set.delete peeraddr
                                               (inProgressPromoteCold st),
                       knownPeers            = knownPeers'
                     }
            cs' :: PeerSelectionCounters extraCounters
cs' = (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'

        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
TracePromoteColdBigLedgerPeerDone
                                    Int
targetNumberOfEstablishedBigLedgerPeers
                                    (case PeerSelectionCounters extraCounters
cs' of
                                      PeerSelectionCounters { numberOfEstablishedBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfEstablishedBigLedgerPeers = Int
a } -> Int
a)
                                    peeraddr
peeraddr]
                             else [Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePromoteColdDone
                                    Int
targetNumberOfEstablishedPeers
                                    (case PeerSelectionCounters extraCounters
cs' of
                                      PeerSelectionCounters { numberOfEstablishedPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfEstablishedPeers = Int
a } ->  Int
a)
                                    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  = []
           }


---------------------------------
-- Established peers above target
--
--


-- | If we are above the target of /established peers/ we demote some of the
-- /warm peers/ to the cold state, according to 'policyPickWarmPeersToDemote'.
--
aboveTarget
  :: forall extraState extraDebugState extraFlags extraPeers extraAPI
            extraCounters peeraddr peerconn m.
     ( Alternative (STM m)
     , MonadSTM m
     , Ord peeraddr
     )
  => 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) =>
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, HasCallStack) =>
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
aboveTargetOther

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)
policyPickWarmPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote
                 }
                 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 :: Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers,
                   Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteWarm,
                   Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteWarm,
                   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
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers
                             }
                 }
    -- Are we above the target for number of established peers?
    -- Or more precisely, how many established peers could we demote?
    -- We only want to pick established peers that are not active, since for
    -- active one we need to demote them first.
  | let peerSelectionView :: PeerSelectionSetsWithSizes extraCounters peeraddr
peerSelectionView = (extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionSetsWithSizes extraCounters peeraddr
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
        PeerSelectionView {
            viewKnownBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewKnownBigLedgerPeers = (Set peeraddr
bigLedgerPeersSet, Int
_),
            viewEstablishedPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewEstablishedPeers    = (Set peeraddr
_, Int
numEstablishedPeers),
            viewActivePeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewActivePeers         = (Set peeraddr
_, Int
numActivePeers)
          }
          =
          PeerSelectionSetsWithSizes extraCounters peeraddr
peerSelectionView
        PeerSelectionCountersHWC {
            numberOfWarmLocalRootPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfWarmLocalRootPeers = Int
numLocalWarmPeers
          }
          =
          (Set peeraddr, Int) -> Int
forall a b. (a, b) -> b
snd ((Set peeraddr, Int) -> Int)
-> PeerSelectionSetsWithSizes extraCounters peeraddr
-> PeerSelectionCounters extraCounters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PeerSelectionSetsWithSizes extraCounters peeraddr
peerSelectionView

        -- One constraint on how many to demote is the difference in the
        -- number we have now vs the target. The other constraint is that
        -- we pick established peers that are not also active. These
        -- constraints combine by taking the minimum. We must also subtract
        -- the number we're demoting so we don't repeat the same work. And
        -- cannot demote ones we're in the process of promoting.
        numPeersToDemote :: Int
numPeersToDemote    = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
numEstablishedPeers
                                   Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
targetNumberOfEstablishedPeers)
                                  (Int
numEstablishedPeers
                                   Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLocalWarmPeers
                                   Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numActivePeers)
                            Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr
inProgressDemoteWarm  Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet)
                            Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr
inProgressPromoteWarm Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet)

        availableToDemote :: Set peeraddr
        availableToDemote :: Set peeraddr
availableToDemote = 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.\\ 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
inProgressDemoteWarm
                              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
inProgressDemoteToCold
  , Int
numPeersToDemote Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  , 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)
policyPickWarmPeersToDemote
                            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
TraceDemoteWarmPeers
                           Int
targetNumberOfEstablishedPeers
                           Int
numEstablishedPeers
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressDemoteWarm = inProgressDemoteWarm
                                              <> 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)
jobDemoteEstablishedPeer 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


aboveTargetBigLedgerPeers
  :: 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
aboveTargetBigLedgerPeers :: 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
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)
policyPickWarmPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote
                          }
                          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,
                            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
inProgressDemoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm,
                            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,
                            targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                                        Int
targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers
                                      }
                          }
    -- Are we above the target for number of established peers?
    -- Or more precisely, how many established peers could we demote?
    -- We only want to pick established peers that are not active, since for
    -- active one we need to demote them first.
  | let bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
        PeerSelectionCounters {
            numberOfEstablishedBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfEstablishedBigLedgerPeers = Int
numEstablishedBigLedgerPeers,
            numberOfActiveBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfActiveBigLedgerPeers      = Int
numActiveBigLedgerPeers
          }
          =
          (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

        -- We want to demote big ledger peers towards the target but we avoid to
        -- pick active peer.  The `min` is taken so that `pickPeers` is given
        -- consistent number of peers with the set of peers available to demote,
        -- i.e. `availableToDemote`.
        numBigLedgerPeersToDemote :: Int
numBigLedgerPeersToDemote    = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ( Int
numEstablishedBigLedgerPeers
                                           Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
targetNumberOfEstablishedBigLedgerPeers)
                                           ( Int
numEstablishedBigLedgerPeers
                                           Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numActiveBigLedgerPeers)
                                     Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
inProgressDemoteWarm
                                     Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
inProgressPromoteWarm

        availableToDemote :: Set peeraddr
        availableToDemote :: Set peeraddr
availableToDemote = 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.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
inProgressDemoteWarm
                              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
inProgressDemoteToCold

  , Int
numBigLedgerPeersToDemote Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  , 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)
policyPickWarmPeersToDemote
                            Set peeraddr
availableToDemote
                            Int
numBigLedgerPeersToDemote
      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
TraceDemoteWarmBigLedgerPeers
                           Int
targetNumberOfEstablishedBigLedgerPeers
                           Int
numEstablishedBigLedgerPeers
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressDemoteWarm = inProgressDemoteWarm
                                              <> 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)
jobDemoteEstablishedPeer 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


jobDemoteEstablishedPeer
  :: 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)
jobDemoteEstablishedPeer :: 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)
jobDemoteEstablishedPeer 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 ()
closePeerConnection :: peerconn -> m ()
closePeerConnection :: forall peeraddr peerconn (m :: * -> *).
PeerStateActions peeraddr peerconn m -> peerconn -> m ()
closePeerConnection}
                         }
                         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
"demoteEstablishedPeer"
  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 closing fails. The peer is cooling so
      -- we can't remove it from the set of established 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,
                       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
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
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers,
                                   Int
targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers
                                 }
                     }
                     Time
_ ->
        let inProgressDemoteWarm' :: Set peeraddr
inProgressDemoteWarm' = peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => a -> Set a -> Set a
Set.delete peeraddr
peeraddr Set peeraddr
inProgressDemoteWarm
            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
TraceDemoteWarmBigLedgerPeerFailed
                                 Int
targetNumberOfEstablishedBigLedgerPeers
                                 (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ 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.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
TraceDemoteWarmFailed
                                 Int
targetNumberOfEstablishedPeers
                                 (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ 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
bigLedgerPeersSet)
                                 peeraddr
peeraddr SomeException
e],
          decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                            inProgressDemoteWarm = inProgressDemoteWarm'
                          },
          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 ()
closePeerConnection 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,
                               EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                               targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                                           Int
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers
                                         }
                             }
                             Time
_now ->
        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
            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
TraceDemoteWarmBigLedgerPeerDone
                                    Int
targetNumberOfEstablishedPeers
                                    (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ 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.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
TraceDemoteWarmDone
                                    Int
targetNumberOfEstablishedPeers
                                    (Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ 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
bigLedgerPeersSet)
                                    peeraddr
peeraddr],
             decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                               establishedPeers     = establishedPeers',
                               inProgressDemoteWarm = Set.delete peeraddr
                                                        (inProgressDemoteWarm st)
                             },
             decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
           }