{-# 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.PeerSelection.Bootstrap (requiresBootstrapPeers)
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


---------------------------------
-- 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 peeraddr peerconn m.
               ( Alternative (STM m)
               , MonadSTM m
               , Ord peeraddr
               )
            => PeerSelectionActions peeraddr peerconn m
            -> MkGuardedDecision peeraddr peerconn m
belowTarget :: forall peeraddr peerconn (m :: * -> *).
(Alternative (STM m), MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTarget =  PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetBigLedgerPeers (PeerSelectionActions peeraddr peerconn m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState peeraddr peerconn
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> (PeerSelectionActions peeraddr peerconn m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState peeraddr peerconn
    -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetLocal (PeerSelectionActions peeraddr peerconn m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState peeraddr peerconn
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> (PeerSelectionActions peeraddr peerconn m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState peeraddr peerconn
    -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetOther


-- | For locally configured root peers we have the explicit target that comes from local
-- configuration.
--
belowTargetLocal :: forall peeraddr peerconn m.
                    (MonadSTM m, Ord peeraddr, HasCallStack)
                 => PeerSelectionActions peeraddr peerconn m
                 -> MkGuardedDecision peeraddr peerconn m
belowTargetLocal :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetLocal PeerSelectionActions peeraddr peerconn m
actions
                 policy :: PeerSelectionPolicy peeraddr m
policy@PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote :: PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote
                 }
                 st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                   LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers,
                   KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteCold,
                   Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState 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 peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToPromote <-
        [Set peeraddr] -> Set peeraddr
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set peeraddr] -> Set peeraddr)
-> STM m [Set peeraddr] -> STM m (Set peeraddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [STM m (Set peeraddr)] -> STM m [Set peeraddr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
              PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote
              Set peeraddr
membersAvailableToPromote
              Int
numMembersToPromote
          | (Int
numMembersToPromote,
             Set peeraddr
membersAvailableToPromote) <- [(Int, Set peeraddr)]
groupsAvailableToPromote ]

      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [[(WarmValency, Int)] -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
[(WarmValency, Int)] -> Set peeraddr -> TracePeerSelection 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 peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressPromoteCold = inProgressPromoteCold
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> Job () m (Completion m peeraddr peerconn)
jobPromoteColdPeer PeerSelectionActions peeraddr peerconn m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peer IsBigLedgerPeer
IsNotBigLedgerPeer
                        | peeraddr
peer <- Set peeraddr -> [peeraddr]
forall a. Set a -> [a]
Set.toList Set peeraddr
selectedToPromote ]
      }

    -- If we could promote except that there are no peers currently available
    -- then we return the next wakeup time (if any)
  | Bool -> Bool
not ([(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 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 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 peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
forall peeraddr.
LocalRootPeers peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
LocalRootPeers.toGroupSets LocalRootPeers 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 a. PeerSelectionView a -> a
viewKnownBigLedgerPeers              = (Set peeraddr
bigLedgerPeersSet, Int
_),
        viewKnownLocalRootPeers :: forall a. PeerSelectionView a -> a
viewKnownLocalRootPeers              = (Set peeraddr
localRootPeersSet, Int
_),
        viewEstablishedLocalRootPeers :: forall a. PeerSelectionView a -> a
viewEstablishedLocalRootPeers        = (Set peeraddr
localEstablishedPeers, Int
_),
        viewAvailableToConnectLocalRootPeers :: forall a. PeerSelectionView a -> a
viewAvailableToConnectLocalRootPeers = (Set peeraddr
localAvailableToConnect, Int
_),
        viewColdLocalRootPeersPromotions :: forall a. PeerSelectionView a -> a
viewColdLocalRootPeersPromotions     = (Set peeraddr
localConnectInProgress, Int
numLocalConnectInProgress)
      } = PeerSelectionState peeraddr peerconn
-> PeerSelectionView (Set peeraddr, Int)
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn
-> PeerSelectionSetsWithSizes peeraddr
peerSelectionStateToView PeerSelectionState peeraddr peerconn
st


belowTargetOther :: forall peeraddr peerconn m.
                    (MonadSTM m, Ord peeraddr, HasCallStack)
                 => PeerSelectionActions peeraddr peerconn m
                 -> MkGuardedDecision peeraddr peerconn m
belowTargetOther :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetOther PeerSelectionActions peeraddr peerconn m
actions
                 policy :: PeerSelectionPolicy peeraddr m
policy@PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote :: PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote
                 }
                 st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                   KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
inProgressPromoteCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold,
                   targets :: forall peeraddr peerconn.
PeerSelectionState 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 peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      -- 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 <- PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
                             PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote
                             Set peeraddr
availableToPromote
                             Int
numPeersToPromote
      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
TracePromoteColdPeers
                           Int
targetNumberOfEstablishedPeers
                           Int
numEstablishedPeers
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressPromoteCold = inProgressPromoteCold
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> Job () m (Completion m peeraddr peerconn)
jobPromoteColdPeer PeerSelectionActions peeraddr peerconn m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peer IsBigLedgerPeer
IsNotBigLedgerPeer
                        | 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 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 peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    PeerSelectionView {
        viewKnownBigLedgerPeers :: forall a. PeerSelectionView a -> a
viewKnownBigLedgerPeers     = (Set peeraddr
bigLedgerPeersSet, Int
_),

        viewAvailableToConnectPeers :: forall a. PeerSelectionView a -> a
viewAvailableToConnectPeers = (Set peeraddr
availableToConnect, Int
numAvailableToConnect),
        viewEstablishedPeers :: forall a. PeerSelectionView a -> a
viewEstablishedPeers        = (Set peeraddr
_, Int
numEstablishedPeers),
        viewColdPeersPromotions :: forall a. PeerSelectionView a -> a
viewColdPeersPromotions     = (Set peeraddr
_, Int
numConnectInProgress)
      }
      =
      PeerSelectionState peeraddr peerconn
-> PeerSelectionView (Set peeraddr, Int)
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn
-> PeerSelectionSetsWithSizes peeraddr
peerSelectionStateToView PeerSelectionState 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 peeraddr peerconn m.
                             (MonadSTM m, Ord peeraddr, HasCallStack)
                          => PeerSelectionActions peeraddr peerconn m
                          -> MkGuardedDecision peeraddr peerconn m
belowTargetBigLedgerPeers :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
belowTargetBigLedgerPeers PeerSelectionActions peeraddr peerconn m
actions
                          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 peeraddr peerconn
st@PeerSelectionState {
                            KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
                            EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                            Set peeraddr
inProgressPromoteCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold,
                            targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                        Int
targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers
                                      },
                            LedgerStateJudgement
ledgerStateJudgement :: LedgerStateJudgement
ledgerStateJudgement :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LedgerStateJudgement
ledgerStateJudgement,
                            UseBootstrapPeers
bootstrapPeersFlag :: UseBootstrapPeers
bootstrapPeersFlag :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> UseBootstrapPeers
bootstrapPeersFlag
                          }
    -- Are we below the target for number of 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

    -- Are we in insensitive state, i.e. using bootstrap peers?
  , Bool -> Bool
not (UseBootstrapPeers -> LedgerStateJudgement -> Bool
requiresBootstrapPeers UseBootstrapPeers
bootstrapPeersFlag LedgerStateJudgement
ledgerStateJudgement)
  = Maybe Time
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      -- 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 <- PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
                             PickPolicy peeraddr (STM m)
policyPickColdPeersToPromote
                             Set peeraddr
availableToPromote
                             Int
numPeersToPromote
      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
TracePromoteColdBigLedgerPeers
                           Int
targetNumberOfEstablishedBigLedgerPeers
                           Int
numEstablishedPeers
                           Set peeraddr
selectedToPromote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressPromoteCold = inProgressPromoteCold
                                               <> selectedToPromote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> Job () m (Completion m peeraddr peerconn)
jobPromoteColdPeer PeerSelectionActions peeraddr peerconn m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peer IsBigLedgerPeer
IsBigLedgerPeer
                        | 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 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 peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    PeerSelectionView {
        viewKnownBigLedgerPeers :: forall a. PeerSelectionView a -> a
viewKnownBigLedgerPeers              = (Set peeraddr
bigLedgerPeersSet, Int
_),
        viewAvailableToConnectBigLedgerPeers :: forall a. PeerSelectionView a -> a
viewAvailableToConnectBigLedgerPeers = (Set peeraddr
availableToConnect, Int
numAvailableToConnect),
        viewEstablishedBigLedgerPeers :: forall a. PeerSelectionView a -> a
viewEstablishedBigLedgerPeers        = (Set peeraddr
_, Int
numEstablishedPeers),
        viewColdBigLedgerPeersPromotions :: forall a. PeerSelectionView a -> a
viewColdBigLedgerPeersPromotions     = (Set peeraddr
_, Int
numConnectInProgress)
      }
      =
      PeerSelectionState peeraddr peerconn
-> PeerSelectionView (Set peeraddr, Int)
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn
-> PeerSelectionSetsWithSizes peeraddr
peerSelectionStateToView PeerSelectionState 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 peeraddr peerconn m.
                       (Monad m, Ord peeraddr)
                   => PeerSelectionActions peeraddr peerconn m
                   -> PeerSelectionPolicy peeraddr m
                   -> peeraddr
                   -> IsBigLedgerPeer
                   -> Job () m (Completion m peeraddr peerconn)
jobPromoteColdPeer :: forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> IsBigLedgerPeer
-> Job () m (Completion m peeraddr peerconn)
jobPromoteColdPeer PeerSelectionActions {
                     peerStateActions :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> PeerStateActions peeraddr peerconn m
peerStateActions = PeerStateActions {IsBigLedgerPeer -> peeraddr -> m peerconn
establishPeerConnection :: IsBigLedgerPeer -> peeraddr -> m peerconn
establishPeerConnection :: forall peeraddr peerconn (m :: * -> *).
PeerStateActions peeraddr peerconn m
-> IsBigLedgerPeer -> peeraddr -> m peerconn
establishPeerConnection},
                     peerconn -> PeerSharing
peerConnToPeerSharing :: peerconn -> PeerSharing
peerConnToPeerSharing :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m -> peerconn -> PeerSharing
peerConnToPeerSharing
                   }
                   PeerSelectionPolicy { DiffTime
policyPeerShareActivationDelay :: DiffTime
policyPeerShareActivationDelay :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> DiffTime
policyPeerShareActivationDelay }
                   peeraddr
peeraddr IsBigLedgerPeer
isBigLedgerPeer =
    m (Completion m peeraddr peerconn)
-> (SomeException -> m (Completion m peeraddr peerconn))
-> ()
-> String
-> Job () m (Completion m peeraddr peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job m (Completion m peeraddr peerconn)
job SomeException -> m (Completion m peeraddr peerconn)
handler () String
"promoteColdPeer"
  where
    handler :: SomeException -> m (Completion m peeraddr peerconn)
    handler :: SomeException -> m (Completion m peeraddr peerconn)
handler SomeException
e = Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$
      (PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall (m :: * -> *) peeraddr peerconn.
(PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
Completion ((PeerSelectionState peeraddr peerconn
  -> Time -> Decision m peeraddr peerconn)
 -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                      PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers,
                      StdGen
stdGen :: StdGen
stdGen :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> StdGen
stdGen,
                      targets :: forall peeraddr peerconn.
PeerSelectionState 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 peeraddr peerconn -> KnownPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers PeerSelectionState 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 peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers

            st' :: PeerSelectionState peeraddr peerconn
st' = PeerSelectionState peeraddr peerconn
st { knownPeers            = KnownPeers.setConnectTimes
                                                 (Map.singleton
                                                   peeraddr
                                                   (delay `addTime` now))
                                                 knownPeers',
                       inProgressPromoteCold = Set.delete peeraddr
                                                 (inProgressPromoteCold st),
                       stdGen = stdGen'
                     }
            cs' :: PeerSelectionCounters
cs' = PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerSelectionStateToCounters PeerSelectionState peeraddr peerconn
st'
        in
          Decision {
            decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                            then [Int
-> Int
-> peeraddr
-> DiffTime
-> SomeException
-> TracePeerSelection peeraddr
forall peeraddr.
Int
-> Int
-> peeraddr
-> DiffTime
-> SomeException
-> TracePeerSelection peeraddr
TracePromoteColdBigLedgerPeerFailed
                                   Int
targetNumberOfEstablishedBigLedgerPeers
                                   (case PeerSelectionCounters
cs' of
                                     PeerSelectionCounters { numberOfEstablishedBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfEstablishedBigLedgerPeers = Int
a } -> Int
a)
                                   peeraddr
peeraddr DiffTime
delay SomeException
e]
                            else [Int
-> Int
-> peeraddr
-> DiffTime
-> SomeException
-> TracePeerSelection peeraddr
forall peeraddr.
Int
-> Int
-> peeraddr
-> DiffTime
-> SomeException
-> TracePeerSelection peeraddr
TracePromoteColdFailed
                                   Int
targetNumberOfEstablishedPeers
                                   (case PeerSelectionCounters
cs' of
                                     PeerSelectionCounters { numberOfEstablishedPeers :: PeerSelectionCounters -> Int
numberOfEstablishedPeers = Int
a } -> Int
a)
                                   peeraddr
peeraddr DiffTime
delay SomeException
e],
            decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st',
            decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
          }

    job :: m (Completion m peeraddr peerconn)
    job :: m (Completion m peeraddr peerconn)
job = do
      --TODO: decide if we should do timeouts here or if we should make that
      -- the responsibility of establishPeerConnection
      peerconn <- IsBigLedgerPeer -> peeraddr -> m peerconn
establishPeerConnection IsBigLedgerPeer
isBigLedgerPeer peeraddr
peeraddr
      let !peerSharing = peerconn -> PeerSharing
peerConnToPeerSharing peerconn
peerconn

      return $ Completion $ \st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                               PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                               EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                               KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
                               targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                           Int
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 peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers

            st' :: PeerSelectionState peeraddr peerconn
st' = PeerSelectionState peeraddr peerconn
st { establishedPeers      = establishedPeers',
                       inProgressPromoteCold = Set.delete peeraddr
                                               (inProgressPromoteCold st),
                       knownPeers            = knownPeers'
                     }
            cs' :: PeerSelectionCounters
cs' = PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerSelectionStateToCounters PeerSelectionState peeraddr peerconn
st'

        in Decision {
             decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                             then [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TracePromoteColdBigLedgerPeerDone
                                    Int
targetNumberOfEstablishedBigLedgerPeers
                                    (case PeerSelectionCounters
cs' of
                                      PeerSelectionCounters { numberOfEstablishedBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfEstablishedBigLedgerPeers = Int
a } -> Int
a)
                                    peeraddr
peeraddr]
                             else [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
TracePromoteColdDone
                                    Int
targetNumberOfEstablishedPeers
                                    (case PeerSelectionCounters
cs' of
                                      PeerSelectionCounters { numberOfEstablishedPeers :: PeerSelectionCounters -> Int
numberOfEstablishedPeers = Int
a } ->  Int
a)
                                    peeraddr
peeraddr],
             decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st',
             decisionJobs :: [Job () m (Completion m 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 peeraddr peerconn m.
               (Alternative (STM m), MonadSTM m, Ord peeraddr)
            => PeerSelectionActions peeraddr peerconn m
            -> MkGuardedDecision peeraddr peerconn m
aboveTarget :: forall peeraddr peerconn (m :: * -> *).
(Alternative (STM m), MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTarget =  PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetBigLedgerPeers (PeerSelectionActions peeraddr peerconn m
 -> PeerSelectionPolicy peeraddr m
 -> PeerSelectionState peeraddr peerconn
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> (PeerSelectionActions peeraddr peerconn m
    -> PeerSelectionPolicy peeraddr m
    -> PeerSelectionState peeraddr peerconn
    -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a. Semigroup a => a -> a -> a
<> PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetOther

aboveTargetOther :: forall peeraddr peerconn m.
               (MonadSTM m, Ord peeraddr, HasCallStack)
            => PeerSelectionActions peeraddr peerconn m
            -> MkGuardedDecision peeraddr peerconn m
aboveTargetOther :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetOther PeerSelectionActions peeraddr peerconn m
actions
                 PeerSelectionPolicy {
                   PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote
                 }
                 st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                   LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
                   EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                   Set peeraddr
activePeers :: Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers,
                   Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm,
                   Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm,
                   Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
                   targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                               Int
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 peeraddr
peerSelectionView = PeerSelectionState peeraddr peerconn
-> PeerSelectionSetsWithSizes peeraddr
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn
-> PeerSelectionSetsWithSizes peeraddr
peerSelectionStateToView PeerSelectionState peeraddr peerconn
st
        PeerSelectionView {
            viewKnownBigLedgerPeers :: forall a. PeerSelectionView a -> a
viewKnownBigLedgerPeers = (Set peeraddr
bigLedgerPeersSet, Int
_),
            viewEstablishedPeers :: forall a. PeerSelectionView a -> a
viewEstablishedPeers    = (Set peeraddr
_, Int
numEstablishedPeers),
            viewActivePeers :: forall a. PeerSelectionView a -> a
viewActivePeers         = (Set peeraddr
_, Int
numActivePeers)
          }
          =
          PeerSelectionSetsWithSizes peeraddr
peerSelectionView
        PeerSelectionCountersHWC {
            numberOfWarmLocalRootPeers :: PeerSelectionCounters -> Int
numberOfWarmLocalRootPeers = Int
numLocalWarmPeers
          }
          =
          (Set peeraddr, Int) -> Int
forall a b. (a, b) -> b
snd ((Set peeraddr, Int) -> Int)
-> PeerSelectionSetsWithSizes peeraddr -> PeerSelectionCounters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PeerSelectionSetsWithSizes 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 peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet
                              Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
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 peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selectedToDemote <- PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
                            PickPolicy peeraddr (STM m)
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 peeraddr]
decisionTrace = [Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
TraceDemoteWarmPeers
                           Int
targetNumberOfEstablishedPeers
                           Int
numEstablishedPeers
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressDemoteWarm = inProgressDemoteWarm
                                              <> selectedToDemote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteEstablishedPeer PeerSelectionActions peeraddr peerconn m
actions peeraddr
peeraddr peerconn
peerconn
                        | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToDemote' ]
      }

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


aboveTargetBigLedgerPeers :: forall peeraddr peerconn m.
                             (MonadSTM m, Ord peeraddr, HasCallStack)
                          => PeerSelectionActions peeraddr peerconn m
                          -> MkGuardedDecision peeraddr peerconn m
aboveTargetBigLedgerPeers :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions peeraddr peerconn m
-> MkGuardedDecision peeraddr peerconn m
aboveTargetBigLedgerPeers PeerSelectionActions peeraddr peerconn m
actions
                          PeerSelectionPolicy {
                            PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote :: PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote
                          }
                          st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                            PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                            EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                            Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
                            Set peeraddr
inProgressDemoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm,
                            Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm,
                            Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
                            targets :: forall peeraddr peerconn.
PeerSelectionState 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 peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
        PeerSelectionCounters {
            numberOfEstablishedBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfEstablishedBigLedgerPeers = Int
numEstablishedBigLedgerPeers,
            numberOfActiveBigLedgerPeers :: PeerSelectionCounters -> Int
numberOfActiveBigLedgerPeers      = Int
numActiveBigLedgerPeers
          }
          =
          PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerSelectionStateToCounters PeerSelectionState 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 peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do

      selectedToDemote <- PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
PeerSelectionState peeraddr peerconn
-> PickPolicy peeraddr m -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers PeerSelectionState peeraddr peerconn
st
                            PickPolicy peeraddr (STM m)
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 peeraddr]
decisionTrace = [Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> Set peeraddr -> TracePeerSelection peeraddr
TraceDemoteWarmBigLedgerPeers
                           Int
targetNumberOfEstablishedBigLedgerPeers
                           Int
numEstablishedBigLedgerPeers
                           Set peeraddr
selectedToDemote],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          inProgressDemoteWarm = inProgressDemoteWarm
                                              <> selectedToDemote
                        },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteEstablishedPeer PeerSelectionActions peeraddr peerconn m
actions peeraddr
peeraddr peerconn
peerconn
                        | (!peeraddr
peeraddr, !peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToDemote' ]
      }

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


jobDemoteEstablishedPeer :: forall peeraddr peerconn m.
                            (Monad m, Ord peeraddr)
                         => PeerSelectionActions peeraddr peerconn m
                         -> peeraddr
                         -> peerconn
                         -> Job () m (Completion m peeraddr peerconn)
jobDemoteEstablishedPeer :: forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteEstablishedPeer PeerSelectionActions{peerStateActions :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions 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 peeraddr peerconn)
-> (SomeException -> m (Completion m peeraddr peerconn))
-> ()
-> String
-> Job () m (Completion m peeraddr peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job m (Completion m peeraddr peerconn)
job SomeException -> m (Completion m peeraddr peerconn)
handler () String
"demoteEstablishedPeer"
  where
    handler :: SomeException -> m (Completion m peeraddr peerconn)
    handler :: SomeException -> m (Completion m peeraddr peerconn)
handler SomeException
e = Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$
      -- It's quite bad if closing fails. The peer is cooling so
      -- we can't remove it from the set of established peers.
      --
      (PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall (m :: * -> *) peeraddr peerconn.
(PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
Completion ((PeerSelectionState peeraddr peerconn
  -> Time -> Decision m peeraddr peerconn)
 -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                       PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                       EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                       Set peeraddr
inProgressDemoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm,
                       targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                                   Int
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 peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
         in
        Decision {
          decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                          then [Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
forall peeraddr.
Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection peeraddr
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 peeraddr
forall peeraddr.
Int
-> Int -> peeraddr -> SomeException -> TracePeerSelection 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 peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                            inProgressDemoteWarm = inProgressDemoteWarm'
                          },
          decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
      }

    job :: m (Completion m peeraddr peerconn)
    job :: m (Completion m peeraddr peerconn)
job = do
      peerconn -> m ()
closePeerConnection peerconn
peerconn
      Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ (PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall (m :: * -> *) peeraddr peerconn.
(PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
Completion ((PeerSelectionState peeraddr peerconn
  -> Time -> Decision m peeraddr peerconn)
 -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ \st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                               PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                               EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
                               targets :: forall peeraddr peerconn.
PeerSelectionState 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 peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
        in Decision {
             decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = if peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
bigLedgerPeersSet
                             then [Int -> Int -> peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection peeraddr
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 peeraddr
forall peeraddr.
Int -> Int -> peeraddr -> TracePeerSelection 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 peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                               establishedPeers     = establishedPeers',
                               inProgressDemoteWarm = Set.delete peeraddr
                                                        (inProgressDemoteWarm st)
                             },
             decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
           }