{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module contains governor decisions for monitoring tasks:
--
-- * monitoring local root peer config changes
-- * monitoring changes to the peer target numbers
-- * monitoring the completion of asynchronous governor job
-- * monitoring connections
--
module Ouroboros.Network.PeerSelection.Governor.Monitor
  ( targetPeers
  , jobs
  , jobVerifyPeerSnapshot
  , connections
  , localRoots
  , monitorLedgerStateJudgement
  , monitorBootstrapPeersFlag
  , waitForSystemToQuiesce
  , ledgerPeerSnapshotChange
  ) where

import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Set (Set)
import Data.Set qualified as Set

import Control.Concurrent.JobPool (Job (..), JobPool)
import Control.Concurrent.JobPool qualified as JobPool
import Control.Exception (assert)
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime.SI
import System.Random (randomR)

import Ouroboros.Network.ConsensusMode
import Ouroboros.Network.ExitPolicy (RepromoteDelay)
import Ouroboros.Network.ExitPolicy qualified as ExitPolicy
import Ouroboros.Network.PeerSelection.Bootstrap (isBootstrapPeersEnabled,
           isNodeAbleToMakeProgress, requiresBootstrapPeers)
import Ouroboros.Network.PeerSelection.Governor.ActivePeers
           (jobDemoteActivePeer)
import Ouroboros.Network.PeerSelection.Governor.Types hiding
           (PeerSelectionCounters)
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
           (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..),
           LedgerStateJudgement (..), compareLedgerPeerSnapshotApproximate)
import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
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 qualified as LocalRootPeers
import Ouroboros.Network.PeerSelection.Types

-- | Used to set 'bootstrapPeersTimeout' for crashing the node in a critical
-- failure case
--
governor_BOOTSTRAP_PEERS_TIMEOUT :: DiffTime
governor_BOOTSTRAP_PEERS_TIMEOUT :: DiffTime
governor_BOOTSTRAP_PEERS_TIMEOUT = DiffTime
15 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60

-- | Monitor 'PeerSelectionTargets', if they change, we just need to update
-- 'PeerSelectionState', since we return it in a 'Decision' action it will be
-- picked by the governor's 'peerSelectionGovernorLoop'.
--
-- It should be noted if the node is in bootstrap mode (i.e. in a sensitive
-- state) then, until the node reaches a clean state, this monitoring action
-- will be disabled and thus churning will be disabled as well.
--
-- On the other hand, if Genesis mode is on for the node, this action responds
-- to changes in ledger state judgement monitoring actions to change the static
-- set of target peers.
targetPeers :: (MonadSTM m, Ord peeraddr)
            => PeerSelectionActions peeraddr peerconn m
            -> PeerSelectionState peeraddr peerconn
            -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
targetPeers :: forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
targetPeers PeerSelectionActions{ STM m PeerSelectionTargets
readPeerSelectionTargets :: STM m PeerSelectionTargets
readPeerSelectionTargets :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> STM m PeerSelectionTargets
readPeerSelectionTargets,
                                  peerTargets :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> ConsensusModePeerTargets
peerTargets = ConsensusModePeerTargets {
                                    PeerSelectionTargets
deadlineTargets :: PeerSelectionTargets
deadlineTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
deadlineTargets,
                                    PeerSelectionTargets
syncTargets :: PeerSelectionTargets
syncTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
syncTargets } }
            st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState{
              PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers,
              LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers,
              PeerSelectionTargets
targets :: PeerSelectionTargets
targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets,
              UseBootstrapPeers
bootstrapPeersFlag :: UseBootstrapPeers
bootstrapPeersFlag :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> UseBootstrapPeers
bootstrapPeersFlag,
              Bool
hasOnlyBootstrapPeers :: Bool
hasOnlyBootstrapPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Bool
hasOnlyBootstrapPeers,
              LedgerStateJudgement
ledgerStateJudgement :: LedgerStateJudgement
ledgerStateJudgement :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LedgerStateJudgement
ledgerStateJudgement,
              ConsensusMode
consensusMode :: ConsensusMode
consensusMode :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> ConsensusMode
consensusMode
            } =
    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
      churnTargets <- STM m PeerSelectionTargets
readPeerSelectionTargets
      -- Genesis consensus mode:
      -- we check if targets proposed by churn are stale
      -- in the sense that they are the targets for
      -- opposite value of the current ledger state judgement.
      -- This indicates that we aren't churning currently, and
      -- furthermore it means that the ledger state has flipped since
      -- we last churned. Therefore we can't set the targets from
      -- the TVar, and instead we set the appropriate targets
      -- for the mode we are in.
      let targets' =
            case (LedgerStateJudgement
ledgerStateJudgement, ConsensusMode
consensusMode) of
              (LedgerStateJudgement
YoungEnough, ConsensusMode
GenesisMode)
                | PeerSelectionTargets
churnTargets PeerSelectionTargets -> PeerSelectionTargets -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSelectionTargets
syncTargets ->
                  PeerSelectionTargets
deadlineTargets
              (LedgerStateJudgement
TooOld, ConsensusMode
GenesisMode)
                | PeerSelectionTargets
churnTargets PeerSelectionTargets -> PeerSelectionTargets -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSelectionTargets
deadlineTargets ->
                  PeerSelectionTargets
syncTargets
              (LedgerStateJudgement, ConsensusMode)
_otherwise -> PeerSelectionTargets
churnTargets

      -- nb. first check is redundant in Genesis mode
      check (   isNodeAbleToMakeProgress bootstrapPeersFlag
                                         ledgerStateJudgement
                                         hasOnlyBootstrapPeers
             && targets /= targets'
             && sanePeerSelectionTargets targets')
      -- We simply ignore target updates that are not "sane".

      let usingBootstrapPeers = UseBootstrapPeers -> LedgerStateJudgement -> Bool
requiresBootstrapPeers UseBootstrapPeers
bootstrapPeersFlag
                                                       LedgerStateJudgement
ledgerStateJudgement
          -- We have to enforce the invariant that the number of root peers is
          -- not more than the target number of known peers. It's unlikely in
          -- practice so it's ok to resolve it arbitrarily using clampToLimit.
          --
          -- Here we need to make sure that we prioritise the trustable peers
          -- by clamping to trustable first.
          --
          -- TODO: we ought to add a warning if 'clampToLimit' modified local
          -- root peers, even though this is unexpected in the most common
          -- scenarios.
          localRootPeers' =
              Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToLimit
                              (PeerSelectionTargets -> Int
targetNumberOfKnownPeers PeerSelectionTargets
targets')
            (LocalRootPeers peeraddr -> LocalRootPeers peeraddr)
-> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall a b. (a -> b) -> a -> b
$ (if Bool
usingBootstrapPeers
                  then LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToTrustable
                  else LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall a. a -> a
id)
            (LocalRootPeers peeraddr -> LocalRootPeers peeraddr)
-> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall a b. (a -> b) -> a -> b
$ LocalRootPeers peeraddr
localRootPeers

          -- We have to enforce that local and big ledger peers are disjoint.
          publicRootPeers' = PublicRootPeers peeraddr
publicRootPeers
                             PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
`PublicRootPeers.difference`
                             LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers'

      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [PeerSelectionTargets
-> PeerSelectionTargets -> TracePeerSelection peeraddr
forall peeraddr.
PeerSelectionTargets
-> PeerSelectionTargets -> TracePeerSelection peeraddr
TraceTargetsChanged PeerSelectionTargets
targets PeerSelectionTargets
targets'],
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                          targets        = targets',
                          localRootPeers = localRootPeers',
                          publicRootPeers = publicRootPeers'
                        } }

-- | Await for the first result from 'JobPool' and return its 'Decision'.
--
jobs :: MonadSTM m
     => JobPool () m (Completion m peeraddr peerconn)
     -> PeerSelectionState peeraddr peerconn
     -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
jobs :: forall (m :: * -> *) peeraddr peerconn.
MonadSTM m =>
JobPool () m (Completion m peeraddr peerconn)
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
jobs JobPool () m (Completion m peeraddr peerconn)
jobPool PeerSelectionState peeraddr peerconn
st =
    -- This case is simple because the job pool returns a 'Completion' which is
    -- just a function from the current state to a new 'Decision'.
    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
      Completion completion <- JobPool () m (Completion m peeraddr peerconn)
-> STM m (Completion m peeraddr peerconn)
forall (m :: * -> *) group a.
MonadSTM m =>
JobPool group m a -> STM m a
JobPool.waitForJob JobPool () m (Completion m peeraddr peerconn)
jobPool
      return (completion st)


-- | Monitor connections.
--
connections :: forall m peeraddr peerconn.
               (MonadSTM m, Ord peeraddr)
            => PeerSelectionActions peeraddr peerconn m
            -> PeerSelectionState peeraddr peerconn
            -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
connections :: forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
connections PeerSelectionActions{
              peerStateActions :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> PeerStateActions peeraddr peerconn m
peerStateActions = PeerStateActions {peerconn -> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection :: peerconn -> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection :: forall peeraddr peerconn (m :: * -> *).
PeerStateActions peeraddr peerconn m
-> peerconn -> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection}
            }
            st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
              PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
              LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
              Set peeraddr
activePeers :: Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers,
              EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers,
              Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot,
              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 :: Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold,
              StdGen
stdGen :: StdGen
stdGen :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> StdGen
stdGen
            } =
    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
      -- Get previously cooling peers
      monitorStatus <- (peerconn -> STM m (PeerStatus, Maybe RepromoteDelay))
-> Map peeraddr peerconn
-> STM m (Map peeraddr (PeerStatus, Maybe RepromoteDelay))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map peeraddr a -> f (Map peeraddr b)
traverse peerconn -> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection
                                (EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers)
      let demotions = Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
asynchronousDemotions Map peeraddr (PeerStatus, Maybe RepromoteDelay)
monitorStatus
      check (not (Map.null demotions))
      let (demotedToWarm, demotedToCoolingOrCold) = Map.partition ((==PeerWarm) . fst) demotions
          (demotedToCold, demotedToCooling) = Map.partition ((==PeerCold) . fst) demotedToCoolingOrCold
          -- fuzz reconnect delays
          (aFuzz, stdGen')  = randomR (0.1, 10 :: Double) stdGen
          (rFuzz, stdGen'') = randomR (0.1, 4  :: Double) stdGen'
          demotions' = (\a :: (PeerStatus, Maybe RepromoteDelay)
a@(PeerStatus
peerState, Maybe RepromoteDelay
repromoteDelay) -> case PeerStatus
peerState of
                         PeerStatus
PeerHot  -> (PeerStatus, Maybe RepromoteDelay)
a
                         PeerStatus
PeerWarm ->
                           ( PeerStatus
peerState
                           , (\RepromoteDelay
x -> (RepromoteDelay
x RepromoteDelay -> RepromoteDelay -> RepromoteDelay
forall a. Num a => a -> a -> a
+ Double -> RepromoteDelay
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
aFuzz) RepromoteDelay -> RepromoteDelay -> RepromoteDelay
forall a. Ord a => a -> a -> a
`max` RepromoteDelay
0) (RepromoteDelay -> RepromoteDelay)
-> Maybe RepromoteDelay -> Maybe RepromoteDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RepromoteDelay
repromoteDelay
                           )
                         PeerStatus
PeerCooling -> (PeerStatus, Maybe RepromoteDelay)
a
                         PeerStatus
PeerCold ->
                           ( PeerStatus
peerState
                           , (\RepromoteDelay
x -> (RepromoteDelay
x RepromoteDelay -> RepromoteDelay -> RepromoteDelay
forall a. Num a => a -> a -> a
+ Double -> RepromoteDelay
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
rFuzz) RepromoteDelay -> RepromoteDelay -> RepromoteDelay
forall a. Ord a => a -> a -> a
`max` RepromoteDelay
0) (RepromoteDelay -> RepromoteDelay)
-> Maybe RepromoteDelay -> Maybe RepromoteDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RepromoteDelay
repromoteDelay
                           )
                       ) ((PeerStatus, Maybe RepromoteDelay)
 -> (PeerStatus, Maybe RepromoteDelay))
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotions
      return $ \Time
now ->
        let -- Remove all asynchronous demotions from 'activePeers'
            activePeers' :: Set peeraddr
activePeers'       = Set peeraddr
activePeers Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Map peeraddr (PeerStatus, Maybe RepromoteDelay) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotions'

            -- Note that we do not use establishedStatus' which
            -- has the synchronous ones that are supposed to be
            -- handled elsewhere. We just update the async ones:
            establishedPeers' :: EstablishedPeers peeraddr peerconn
establishedPeers'  = Map peeraddr Time
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall peeraddr peerconn.
Ord peeraddr =>
Map peeraddr Time
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
EstablishedPeers.setActivateTimes
                                   ( (\(PeerStatus
_, Maybe RepromoteDelay
a) -> RepromoteDelay -> DiffTime
ExitPolicy.repromoteDelay (RepromoteDelay -> Maybe RepromoteDelay -> RepromoteDelay
forall a. a -> Maybe a -> a
fromMaybe RepromoteDelay
0 Maybe RepromoteDelay
a) DiffTime -> Time -> Time
`addTime` Time
now)
                                      -- 'monitorPeerConnection' returns
                                      -- 'Nothing' iff all mini-protocols are
                                      -- either still running or 'NotStarted'
                                      -- (e.g.  this possible for warm or hot
                                      -- peers).  In such case we don't want to
                                      -- `setActivateTimes`
                                      ((PeerStatus, Maybe RepromoteDelay) -> Time)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Map peeraddr Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PeerStatus, Maybe RepromoteDelay) -> Bool)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Maybe RepromoteDelay -> Bool
forall a. Maybe a -> Bool
isJust (Maybe RepromoteDelay -> Bool)
-> ((PeerStatus, Maybe RepromoteDelay) -> Maybe RepromoteDelay)
-> (PeerStatus, Maybe RepromoteDelay)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PeerStatus, Maybe RepromoteDelay) -> Maybe RepromoteDelay
forall a b. (a, b) -> b
snd) Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotedToWarm
                                   )
                               (EstablishedPeers peeraddr peerconn
 -> EstablishedPeers peeraddr peerconn)
-> (EstablishedPeers peeraddr peerconn
    -> EstablishedPeers peeraddr peerconn)
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set peeraddr
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall peeraddr peerconn.
Ord peeraddr =>
Set peeraddr
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
EstablishedPeers.deletePeers
                                  (Map peeraddr (PeerStatus, Maybe RepromoteDelay) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotedToCold)
                               (EstablishedPeers peeraddr peerconn
 -> EstablishedPeers peeraddr peerconn)
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ EstablishedPeers peeraddr peerconn
establishedPeers

            -- Asynchronous transition to cold peer can only be
            -- a result of a failure.
            knownPeers' :: KnownPeers peeraddr
knownPeers'        = Map peeraddr Time -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Map peeraddr Time -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.setConnectTimes
                                    ( (\(PeerStatus
_, Maybe RepromoteDelay
a) -> RepromoteDelay -> DiffTime
ExitPolicy.repromoteDelay (RepromoteDelay -> Maybe RepromoteDelay -> RepromoteDelay
forall a. a -> Maybe a -> a
fromMaybe RepromoteDelay
0 Maybe RepromoteDelay
a) DiffTime -> Time -> Time
`addTime` Time
now)
                                      ((PeerStatus, Maybe RepromoteDelay) -> Time)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Map peeraddr Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotedToCold
                                    )
                               (KnownPeers peeraddr -> KnownPeers peeraddr)
-> (Set peeraddr -> KnownPeers peeraddr)
-> Set peeraddr
-> KnownPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr)
-> KnownPeers peeraddr -> Set peeraddr -> KnownPeers peeraddr
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr'
                                   (((Int, KnownPeers peeraddr) -> KnownPeers peeraddr
forall a b. (a, b) -> b
snd ((Int, KnownPeers peeraddr) -> KnownPeers peeraddr)
-> (KnownPeers peeraddr -> (Int, KnownPeers peeraddr))
-> KnownPeers peeraddr
-> KnownPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((KnownPeers peeraddr -> (Int, KnownPeers peeraddr))
 -> KnownPeers peeraddr -> KnownPeers peeraddr)
-> (peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr))
-> peeraddr
-> KnownPeers peeraddr
-> KnownPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
KnownPeers.incrementFailCount)
                                   (PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers PeerSelectionState peeraddr peerconn
st)
                               (Set peeraddr -> KnownPeers peeraddr)
-> Set peeraddr -> KnownPeers peeraddr
forall a b. (a -> b) -> a -> b
$ Map peeraddr (PeerStatus, Maybe RepromoteDelay) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotedToCold
            (Map peeraddr (PeerStatus, Maybe RepromoteDelay)
localDemotions, Map peeraddr (PeerStatus, Maybe RepromoteDelay)
nonLocalDemotions) =
              (peeraddr -> (PeerStatus, Maybe RepromoteDelay) -> Bool)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> (Map peeraddr (PeerStatus, Maybe RepromoteDelay),
    Map peeraddr (PeerStatus, Maybe RepromoteDelay))
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey
                (\peeraddr
peer (PeerStatus, Maybe RepromoteDelay)
_ -> peeraddr
peer peeraddr -> LocalRootPeers peeraddr -> Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> LocalRootPeers peeraddr -> Bool
`LocalRootPeers.member` LocalRootPeers peeraddr
localRootPeers)
                Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotions'

            publicRootDemotions :: Map peeraddr (PeerStatus, Maybe RepromoteDelay)
publicRootDemotions     = Map peeraddr (PeerStatus, Maybe RepromoteDelay)
nonLocalDemotions
                   Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Set peeraddr -> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys`  Set peeraddr
bigLedgerPeersSet
            bigLedgerPeersDemotions :: Map peeraddr (PeerStatus, Maybe RepromoteDelay)
bigLedgerPeersDemotions = Map peeraddr (PeerStatus, Maybe RepromoteDelay)
nonLocalDemotions
                   Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Set peeraddr -> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
bigLedgerPeersSet

            -- Peers in this state won't be able to be promoted nor demoted.
            inProgressDemoteToCold' :: Set peeraddr
inProgressDemoteToCold' =
              (Set peeraddr
inProgressDemoteToCold Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Map peeraddr (PeerStatus, Maybe RepromoteDelay) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotedToCold )
               Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Semigroup a => a -> a -> a
<> Map peeraddr (PeerStatus, Maybe RepromoteDelay) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe RepromoteDelay)
demotedToCooling
        in Bool
-> Decision m peeraddr peerconn -> Decision m peeraddr peerconn
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr
activePeers' Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf`
                     Map peeraddr peerconn -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet (EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers'))
            Decision {
              decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [ Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection peeraddr
forall peeraddr.
Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection peeraddr
TraceDemoteLocalAsynchronous Map peeraddr (PeerStatus, Maybe RepromoteDelay)
localDemotions
                              | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map peeraddr (PeerStatus, Maybe RepromoteDelay) -> Bool
forall a. Map peeraddr a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map peeraddr (PeerStatus, Maybe RepromoteDelay)
localDemotions ]
                           [TracePeerSelection peeraddr]
-> [TracePeerSelection peeraddr] -> [TracePeerSelection peeraddr]
forall a. Semigroup a => a -> a -> a
<> [ Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection peeraddr
forall peeraddr.
Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection peeraddr
TraceDemoteAsynchronous Map peeraddr (PeerStatus, Maybe RepromoteDelay)
publicRootDemotions
                              | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map peeraddr (PeerStatus, Maybe RepromoteDelay) -> Bool
forall a. Map peeraddr a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map peeraddr (PeerStatus, Maybe RepromoteDelay)
publicRootDemotions ]
                           [TracePeerSelection peeraddr]
-> [TracePeerSelection peeraddr] -> [TracePeerSelection peeraddr]
forall a. Semigroup a => a -> a -> a
<> [ Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection peeraddr
forall peeraddr.
Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection peeraddr
TraceDemoteBigLedgerPeersAsynchronous
                                  Map peeraddr (PeerStatus, Maybe RepromoteDelay)
bigLedgerPeersDemotions
                              | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map peeraddr (PeerStatus, Maybe RepromoteDelay) -> Bool
forall a. Map peeraddr a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map peeraddr (PeerStatus, Maybe RepromoteDelay)
bigLedgerPeersDemotions ],
              decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [],
              decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                                activePeers       = activePeers',
                                establishedPeers  = establishedPeers',
                                knownPeers        = knownPeers',

                                -- When promoting a warm peer, it might happen
                                -- that the connection will break (or one of the
                                -- established protocols will error).  For that
                                -- reason we need to adjust 'inProgressPromoteWarm'.
                                inProgressPromoteWarm
                                                  = inProgressPromoteWarm
                                                      Set.\\ Map.keysSet demotedToCoolingOrCold,

                                inProgressDemoteToCold =
                                  inProgressDemoteToCold',

                                -- Note that we do not need to adjust
                                -- inProgressDemoteWarm or inProgressDemoteHot
                                -- here since we define the async demotions
                                -- to not include peers in those sets. Instead,
                                -- those ones will complete synchronously.

                                stdGen = stdGen''
                              }
          }
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers peeraddr
publicRootPeers
    -- Those demotions that occurred not as a result of action by the governor.
    -- They're further classified into demotions to warm, and demotions to cold.
    asynchronousDemotions :: Map peeraddr (PeerStatus, Maybe RepromoteDelay)
                          -> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
    asynchronousDemotions :: Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
asynchronousDemotions = (peeraddr
 -> (PeerStatus, Maybe RepromoteDelay)
 -> Maybe (PeerStatus, Maybe RepromoteDelay))
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> Map peeraddr (PeerStatus, Maybe RepromoteDelay)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey peeraddr
-> (PeerStatus, Maybe RepromoteDelay)
-> Maybe (PeerStatus, Maybe RepromoteDelay)
asyncDemotion

    -- The asynchronous ones, those not directed by the governor, are:
    -- hot -> warm, warm -> cold and hot -> cold, other than the ones in the in
    -- relevant progress set.
    asyncDemotion :: peeraddr
                  -> (PeerStatus, Maybe RepromoteDelay)
                  -> Maybe (PeerStatus, Maybe RepromoteDelay)

    -- a hot -> warm transition has occurred if it is now warm, and it was
    -- hot, but not in the set we were deliberately demoting synchronously
    asyncDemotion :: peeraddr
-> (PeerStatus, Maybe RepromoteDelay)
-> Maybe (PeerStatus, Maybe RepromoteDelay)
asyncDemotion peeraddr
peeraddr (PeerStatus
PeerWarm, Maybe RepromoteDelay
returnCommand)
      | peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member`    Set peeraddr
activePeers
      , peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteHot  = (PeerStatus, Maybe RepromoteDelay)
-> Maybe (PeerStatus, Maybe RepromoteDelay)
forall a. a -> Maybe a
Just (PeerStatus
PeerWarm, Maybe RepromoteDelay
returnCommand)

    -- a `{PeerHot,PeerWarm} -> PeerCooling` transition has occurred if it is
    -- now cooling, and it was warm, but not in the set of peers being demoted
    -- synchronously, e.g. `inProgressDemote{Hot,Warm}`.
    --
    -- If the peer is a member of the `inProgressDemoteToCold` set it means we
    -- already accounted it, since we are adding peers to
    -- `inProgressDemoteToCold` only if this function returns
    -- `Just (PeerCooling, ...)`.
    --
    -- A peer in the `PeerCooling` state is going to be a member of the established set
    -- until its connection is effectively terminated on the outbound side when
    -- it will become `PeerCold`. We check if the peer does not exist in the
    -- `inProgressDemoteToCold` to see if it is a new asynchronous demotion.
    --
    asyncDemotion peeraddr
peeraddr (PeerStatus
PeerCooling, Maybe RepromoteDelay
returnCommand)
      | peeraddr
peeraddr peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
forall peeraddr peerconn.
Ord peeraddr =>
peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
`EstablishedPeers.member` EstablishedPeers peeraddr peerconn
establishedPeers
      , peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
activePeers
      , peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteWarm
      , peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteToCold = (PeerStatus, Maybe RepromoteDelay)
-> Maybe (PeerStatus, Maybe RepromoteDelay)
forall a. a -> Maybe a
Just (PeerStatus
PeerCooling, Maybe RepromoteDelay
returnCommand)

    -- a hot -> cooling transition has occurred if it is now cooling, and it was hot
    asyncDemotion peeraddr
peeraddr (PeerStatus
PeerCooling, Maybe RepromoteDelay
returnCommand)
      | peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member`    Set peeraddr
activePeers
      , peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteHot
      , peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteToCold = (PeerStatus, Maybe RepromoteDelay)
-> Maybe (PeerStatus, Maybe RepromoteDelay)
forall a. a -> Maybe a
Just (PeerStatus
PeerCooling, Maybe RepromoteDelay
returnCommand)

    -- a cooling -> cold transition has occurred if it is now cold, and it was cooling
    asyncDemotion peeraddr
peeraddr (PeerStatus
PeerCold, Maybe RepromoteDelay
returnCommand)
      | peeraddr
peeraddr peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
forall peeraddr peerconn.
Ord peeraddr =>
peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
`EstablishedPeers.member` EstablishedPeers peeraddr peerconn
establishedPeers Bool -> Bool -> Bool
|| peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set peeraddr
activePeers
      , peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteWarm
      , peeraddr
peeraddr peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteHot  = (PeerStatus, Maybe RepromoteDelay)
-> Maybe (PeerStatus, Maybe RepromoteDelay)
forall a. a -> Maybe a
Just (PeerStatus
PeerCold, Maybe RepromoteDelay
returnCommand)
      -- Note:
      --
      -- We need to take care of direct transitions too `PeerCold` without going
      -- through `PeerCooling` which can be triggered by
      -- `deactivatePeerConnection`.
      --
      -- Also the peer might not be in `inProgressDemoteToCold`, that could
      -- happen in `outbound-governor` skipped seeing `PeerCooling`.  This can
      -- happen under load or we could be just unlucky.

    asyncDemotion peeraddr
_        (PeerStatus, Maybe RepromoteDelay)
_                          = Maybe (PeerStatus, Maybe RepromoteDelay)
forall a. Maybe a
Nothing


-----------------------------------------------
-- Monitoring changes to the local root peers
--


-- | Monitor local roots using 'readLocalRootPeers' 'STM' action.
--
-- If the current ledger state is TooOld we can only trust our trustable local
-- root peers, this means that if we remove any local root peer we
-- might no longer abide by the invariant that we are only connected to
-- trusted peers. E.g. Local peers = A, B*, C* (* means trusted peer), if
-- the node is in bootstrap mode and decided to reconfigure the local root
-- peers to the following set: A*, B, C*, D*, E. Notice that B is no longer
-- trusted, however we will keep a connection to it until the outbound
-- governor notices it and disconnects from it.
localRoots :: forall peeraddr peerconn m.
              (MonadSTM m, Ord peeraddr)
           => PeerSelectionActions peeraddr peerconn m
           -> PeerSelectionState peeraddr peerconn
           -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
localRoots :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
localRoots actions :: PeerSelectionActions peeraddr peerconn m
actions@PeerSelectionActions{ STM m (Config peeraddr)
readLocalRootPeers :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m -> STM m (Config peeraddr)
readLocalRootPeers :: STM m (Config peeraddr)
readLocalRootPeers
                                       }
           st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState{
             LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
             PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
             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
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
             Set peeraddr
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
             Set peeraddr
inProgressDemoteToCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
             targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets{Int
targetNumberOfKnownPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers},
             LedgerStateJudgement
ledgerStateJudgement :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LedgerStateJudgement
ledgerStateJudgement :: LedgerStateJudgement
ledgerStateJudgement,
             UseBootstrapPeers
bootstrapPeersFlag :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> UseBootstrapPeers
bootstrapPeersFlag :: UseBootstrapPeers
bootstrapPeersFlag,
             Bool
hasOnlyBootstrapPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Bool
hasOnlyBootstrapPeers :: Bool
hasOnlyBootstrapPeers
           }
  | UseBootstrapPeers -> LedgerStateJudgement -> Bool -> Bool
isNodeAbleToMakeProgress UseBootstrapPeers
bootstrapPeersFlag LedgerStateJudgement
ledgerStateJudgement Bool
hasOnlyBootstrapPeers =
    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
      -- We have to enforce the invariant that the number of root peers is
      -- not more than the target number of known peers. It's unlikely in
      -- practice so it's ok to resolve it arbitrarily using clampToLimit.
      --
      -- Here we need to make sure that we prioritise the trustable peers
      -- by clamping to trustable first.
      localRootPeersRaw <- STM m (Config peeraddr)
readLocalRootPeers
      let inSensitiveState = UseBootstrapPeers -> LedgerStateJudgement -> Bool
requiresBootstrapPeers UseBootstrapPeers
bootstrapPeersFlag LedgerStateJudgement
ledgerStateJudgement
          localRootPeers' = Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToLimit
                              Int
targetNumberOfKnownPeers
                          (LocalRootPeers peeraddr -> LocalRootPeers peeraddr)
-> (Config peeraddr -> LocalRootPeers peeraddr)
-> Config peeraddr
-> LocalRootPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
inSensitiveState
                                then LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToTrustable
                                else LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall a. a -> a
id)
                          (LocalRootPeers peeraddr -> LocalRootPeers peeraddr)
-> (Config peeraddr -> LocalRootPeers peeraddr)
-> Config peeraddr
-> LocalRootPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config peeraddr -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
[(HotValency, WarmValency,
  Map peeraddr (PeerAdvertise, PeerTrustable))]
-> LocalRootPeers peeraddr
LocalRootPeers.fromGroups
                          (Config peeraddr -> LocalRootPeers peeraddr)
-> Config peeraddr -> LocalRootPeers peeraddr
forall a b. (a -> b) -> a -> b
$ Config peeraddr
localRootPeersRaw
      check (localRootPeers' /= localRootPeers)

      --TODO: trace when the clamping kicks in, and warn operators

      let added        = LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
forall peeraddr.
LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers' Map peeraddr (PeerAdvertise, PeerTrustable)
-> Map peeraddr (PeerAdvertise, PeerTrustable)
-> Map peeraddr (PeerAdvertise, PeerTrustable)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\
                         LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
forall peeraddr.
LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers
          removed      = LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
forall peeraddr.
LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers  Map peeraddr (PeerAdvertise, PeerTrustable)
-> Map peeraddr (PeerAdvertise, PeerTrustable)
-> Map peeraddr (PeerAdvertise, PeerTrustable)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\
                         LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
forall peeraddr.
LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers'
          -- LocalRoots are not ledger!
          addedInfoMap = ((PeerAdvertise, PeerTrustable) -> (Maybe a, Maybe PeerAdvertise))
-> Map peeraddr (PeerAdvertise, PeerTrustable)
-> Map peeraddr (Maybe a, Maybe PeerAdvertise)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(PeerAdvertise
pa, PeerTrustable
_) -> (Maybe a
forall a. Maybe a
Nothing, PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
pa)) Map peeraddr (PeerAdvertise, PeerTrustable)
added
          removedSet   = Map peeraddr (PeerAdvertise, PeerTrustable) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerAdvertise, PeerTrustable)
removed
          knownPeers'  = Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
-> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
-> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.insert Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
forall {a}. Map peeraddr (Maybe a, Maybe PeerAdvertise)
addedInfoMap KnownPeers peeraddr
knownPeers
                        -- We do not immediately remove old ones from the
                        -- known peers set because we may have established
                        -- connections

          localRootPeersSet = LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers'

          -- We have to adjust the publicRootPeers to maintain the invariant
          -- that the local and public sets are non-overlapping.
          --
          publicRootPeers' = PublicRootPeers peeraddr
publicRootPeers
                             PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
`PublicRootPeers.difference`
                             Set peeraddr
localRootPeersSet

          -- Non trustable peers that the outbound governor might keep. These
          -- should be demoted forgot as soon as possible. In order to do that
          -- we set 'hasOnlyBootstrapPeers' to False and
          -- 'ledgerStateJudgement' to TooOld in order to force clean state
          -- reconnections.
          hasOnlyBootstrapPeers' =
            Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null (Set peeraddr -> Bool) -> Set peeraddr -> Bool
forall a b. (a -> b) -> a -> b
$ KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers'
                       Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference`
                       (  LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers'
                       Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Semigroup a => a -> a -> a
<> PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBootstrapPeers PublicRootPeers peeraddr
publicRootPeers')

          -- If the node is in a vulnerable position, i.e. connected to a
          -- local root that is no longer deemed trustable we have to
          -- force clean state reconnections. We do this by setting the
          -- 'ledgerStateJudgement' value to 'YoungEnough' which
          -- 'monitorLedgerStateJudgement' will then read the original
          -- 'TooOld' value and trigger the clean state protocol.
          --
          -- Note that if the state actually changes to 'YoungEnough' it
          -- doesn't really matter.
          --
          ledgerStateJudgement' =
            if    UseBootstrapPeers -> LedgerStateJudgement -> Bool
requiresBootstrapPeers UseBootstrapPeers
bootstrapPeersFlag LedgerStateJudgement
ledgerStateJudgement
               Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasOnlyBootstrapPeers'
            then LedgerStateJudgement
YoungEnough
            else LedgerStateJudgement
ledgerStateJudgement

          -- If we are removing local roots and we have active connections to
          -- them then things are a little more complicated. We would typically
          -- change local roots so that we can establish new connections to
          -- the new local roots. But since we will typically already be at our
          -- target for active peers then that will not be possible without us
          -- taking additional action. What we choose to do here is to demote
          -- the peer from active to warm, which will then allow new ones to
          -- be promoted to active.
          selectedToDemote  :: Set peeraddr
          selectedToDemote' :: Map peeraddr peerconn

          selectedToDemote  = Set peeraddr
activePeers Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set peeraddr
removedSet
                                Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteToCold
          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 ->

          Bool
-> Decision m peeraddr peerconn -> Decision m peeraddr peerconn
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf
                    (PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet PublicRootPeers peeraddr
publicRootPeers')
                   (KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers'))
        (Decision m peeraddr peerconn -> Decision m peeraddr peerconn)
-> (Decision m peeraddr peerconn -> Decision m peeraddr peerconn)
-> Decision m peeraddr peerconn
-> Decision m peeraddr peerconn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Decision m peeraddr peerconn -> Decision m peeraddr peerconn
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf
                   (LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers')
                   (KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers'))

        (Decision m peeraddr peerconn -> Decision m peeraddr peerconn)
-> Decision m peeraddr peerconn -> Decision m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ Decision {
            decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = LocalRootPeers peeraddr
-> LocalRootPeers peeraddr -> TracePeerSelection peeraddr
forall peeraddr.
LocalRootPeers peeraddr
-> LocalRootPeers peeraddr -> TracePeerSelection peeraddr
TraceLocalRootPeersChanged LocalRootPeers peeraddr
localRootPeers LocalRootPeers peeraddr
localRootPeers'
                          TracePeerSelection peeraddr
-> [TracePeerSelection peeraddr] -> [TracePeerSelection peeraddr]
forall a. a -> [a] -> [a]
: [ LedgerStateJudgement -> TracePeerSelection peeraddr
forall peeraddr.
LedgerStateJudgement -> TracePeerSelection peeraddr
TraceLedgerStateJudgementChanged LedgerStateJudgement
YoungEnough
                            | LedgerStateJudgement
ledgerStateJudgement LedgerStateJudgement -> LedgerStateJudgement -> Bool
forall a. Eq a => a -> a -> Bool
/= LedgerStateJudgement
ledgerStateJudgement'
                            ],
            decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                              localRootPeers      = localRootPeers',
                              publicRootPeers     = publicRootPeers',
                              knownPeers          = knownPeers',
                              inProgressDemoteHot = inProgressDemoteHot
                                                 <> selectedToDemote,
                              hasOnlyBootstrapPeers = hasOnlyBootstrapPeers',
                              ledgerStateJudgement  = ledgerStateJudgement'
                            },
            decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteActivePeer PeerSelectionActions peeraddr peerconn m
actions peeraddr
peeraddr peerconn
peerconn
                          | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToDemote' ]
          }
  | Bool
otherwise = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing


-- | Monitor 'UseBootstrapPeers' flag.
--
-- The user might reconfigure the node at any point to change the value of
-- UseBootstrapPeers. Essentially the user can enable or disable bootstrap
-- peers at any time. Since 'monitorLedgerStateJudgement' will act on the
-- ledger state judgement value changing, this monitoring action should only
-- be responsible for either disabling bootstrap peers (in case the user
-- disables this flag) or enabling the 'monitorLedgerStateJudgement' action to
-- work correctly in the case the node finds itself in bootstrap mode. In
-- order to achieve this behavior, when bootstrap peers are disabled we should
-- update the ledger state judgement value to 'YoungEnough'; and
-- 'hasOnlyBootstrapPeers' to 'False'.
--
-- Here's a brief explanation why this works. There's 4 scenarios to consider:
--
-- 1. The node is in 'YoungEnough' state and the user
--  1.1. Enables bootstrap peers: In this case since the node is caught up
--  nothing should happen, so setting the LSJ to YoungEnough state is
--  idempotent.
--  1.2. Disables bootstrap peers: In this case, since the node is caught up,
--  its functioning can't really be distinguished from that of a node that has
--  bootstrap peers disabled. So changing the LSJ and 'hasOnlyBootstrapPeers'
--  flag is idempotent.
-- 2. The node is in 'TooOld' state and the user
--  2.1. Enables bootstrap peers: If the node is behind, enabling bootstrap
--  peers will enable 'monitorLedgerStateJudgement'. So if we set the LSJ to
--  be in 'YoungEnough' state it is going to make sure 'monitorLedgerStateJudgement'
--  observes the 'TooOld' state, triggering the right measures to be taken.
--  2.2. Disables bootstrap peers: If this is the case, we want to let the
--  peer connect to non-trusted peers, so just updating the boostrap peers
--  flag will enable the previously disabled monitoring actions.
--
monitorBootstrapPeersFlag :: ( MonadSTM m
                             , Ord peeraddr
                             )
                          => PeerSelectionActions peeraddr peerconn m
                          -> PeerSelectionState peeraddr peerconn
                          -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
monitorBootstrapPeersFlag :: forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
monitorBootstrapPeersFlag PeerSelectionActions { STM m UseBootstrapPeers
readUseBootstrapPeers :: STM m UseBootstrapPeers
readUseBootstrapPeers :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m -> STM m UseBootstrapPeers
readUseBootstrapPeers }
                          st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState { UseBootstrapPeers
bootstrapPeersFlag :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> UseBootstrapPeers
bootstrapPeersFlag :: UseBootstrapPeers
bootstrapPeersFlag
                                                , 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
                                                , PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers
                                                , Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteCold
                                                , Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm
                                                , ConsensusMode
consensusMode :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> ConsensusMode
consensusMode :: ConsensusMode
consensusMode
                                                }
  | ConsensusMode
GenesisMode <- ConsensusMode
consensusMode = 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
  | Bool
otherwise =
  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
    ubp <- STM m UseBootstrapPeers
readUseBootstrapPeers
    check (ubp /= bootstrapPeersFlag)
    let nonEstablishedBootstrapPeers =
          PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBootstrapPeers PublicRootPeers peeraddr
publicRootPeers
          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 Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Semigroup a => a -> a -> a
<> Set peeraddr
inProgressPromoteWarm)
    return $ \Time
_now ->
      Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [UseBootstrapPeers -> TracePeerSelection peeraddr
forall peeraddr. UseBootstrapPeers -> TracePeerSelection peeraddr
TraceUseBootstrapPeersChanged UseBootstrapPeers
ubp],
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState =
          PeerSelectionState peeraddr peerconn
st { bootstrapPeersFlag    = ubp
             , ledgerStateJudgement  = YoungEnough
             , hasOnlyBootstrapPeers = False
             , bootstrapPeersTimeout = Nothing
             , knownPeers =
                 KnownPeers.delete
                   nonEstablishedBootstrapPeers
                   knownPeers
             , publicRootPeers =
                 PublicRootPeers.difference
                   publicRootPeers
                   nonEstablishedBootstrapPeers
             }
      }

-- | Monitor 'LedgerStateJudgement', if it changes,
--
-- For Praos mode:
-- If bootstrap peers are enabled, we need to update 'PeerSelectionTargets'.
-- If the ledger state changed to 'TooOld' we set all other targets to 0
-- and the governor waits for all active connections to drop and then set
-- the targets to sensible values for getting caught up again.
-- However if the state changes to 'YoungEnough' we reset the targets back to
-- their original values.
--
-- It should be noted if the node has bootstrap peers disabled then this
-- monitoring action will be disabled.
--
-- It should also be noted that churning is ignored until the node converges
-- to a clean state. I.e., it will disconnect from the targets source of truth.
--
monitorLedgerStateJudgement :: ( MonadSTM m
                               , Ord peeraddr
                               )
                            => PeerSelectionActions peeraddr peerconn m
                            -> PeerSelectionState peeraddr peerconn
                            -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
monitorLedgerStateJudgement :: forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
monitorLedgerStateJudgement PeerSelectionActions{ getLedgerStateCtx :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> LedgerPeersConsensusInterface m
getLedgerStateCtx = ledgerCtx :: LedgerPeersConsensusInterface m
ledgerCtx@LedgerPeersConsensusInterface {
                                                    lpGetLedgerStateJudgement :: forall (m :: * -> *).
LedgerPeersConsensusInterface m -> STM m LedgerStateJudgement
lpGetLedgerStateJudgement = STM m LedgerStateJudgement
readLedgerStateJudgement } }
                            st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState{ UseBootstrapPeers
bootstrapPeersFlag :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> UseBootstrapPeers
bootstrapPeersFlag :: UseBootstrapPeers
bootstrapPeersFlag,
                                                   PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers,
                                                   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,
                                                   Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm,
                                                   LedgerStateJudgement
ledgerStateJudgement :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LedgerStateJudgement
ledgerStateJudgement :: LedgerStateJudgement
ledgerStateJudgement,
                                                   ConsensusMode
consensusMode :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> ConsensusMode
consensusMode :: ConsensusMode
consensusMode,
                                                   Maybe LedgerPeerSnapshot
ledgerPeerSnapshot :: Maybe LedgerPeerSnapshot
ledgerPeerSnapshot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Maybe LedgerPeerSnapshot
ledgerPeerSnapshot }
  | ConsensusMode
GenesisMode <- ConsensusMode
consensusMode =
    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
      lsj <- STM m LedgerStateJudgement
readLedgerStateJudgement
      check (lsj /= ledgerStateJudgement)

      return $ \Time
_now ->
        Decision {
          decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [LedgerStateJudgement -> TracePeerSelection peeraddr
forall peeraddr.
LedgerStateJudgement -> TracePeerSelection peeraddr
TraceLedgerStateJudgementChanged LedgerStateJudgement
lsj],
          decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs = case (LedgerStateJudgement
lsj, Maybe LedgerPeerSnapshot
ledgerPeerSnapshot) of
                           (LedgerStateJudgement
TooOld, Just LedgerPeerSnapshot
ledgerPeerSnapshot') ->
                             [LedgerPeerSnapshot
-> LedgerPeersConsensusInterface m
-> Job () m (Completion m peeraddr peerconn)
forall (m :: * -> *) peeraddr peerconn.
MonadSTM m =>
LedgerPeerSnapshot
-> LedgerPeersConsensusInterface m
-> Job () m (Completion m peeraddr peerconn)
jobVerifyPeerSnapshot LedgerPeerSnapshot
ledgerPeerSnapshot' LedgerPeersConsensusInterface m
ledgerCtx]
                           (LedgerStateJudgement, Maybe LedgerPeerSnapshot)
_otherwise -> [],
          decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
              ledgerStateJudgement = lsj } }

  | ConsensusMode
PraosMode <- ConsensusMode
consensusMode
  , UseBootstrapPeers -> Bool
isBootstrapPeersEnabled UseBootstrapPeers
bootstrapPeersFlag =
    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
      lsj <- STM m LedgerStateJudgement
readLedgerStateJudgement
      check (lsj /= ledgerStateJudgement)
      st' <- case lsj of
        LedgerStateJudgement
TooOld      -> do
          (Time -> PeerSelectionState peeraddr peerconn)
-> STM m (Time -> PeerSelectionState peeraddr peerconn)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (\Time
now -> PeerSelectionState peeraddr peerconn
st
            { ledgerStateJudgement = lsj
            , targets =
                PeerSelectionTargets
                  { targetNumberOfRootPeers                 = 0
                  , targetNumberOfKnownPeers                = 0
                  , targetNumberOfEstablishedPeers          = 0
                  , targetNumberOfActivePeers               = 0
                  , targetNumberOfKnownBigLedgerPeers       = 0
                  , targetNumberOfEstablishedBigLedgerPeers = 0
                  , targetNumberOfActiveBigLedgerPeers      = 0
                  }
            -- We have to enforce the invariant that the number of root peers is
            -- not more than the target number of known peers. It's unlikely in
            -- practice so it's ok to resolve it arbitrarily using clampToLimit.
            , localRootPeers = LocalRootPeers.empty
            , hasOnlyBootstrapPeers = False
            , bootstrapPeersTimeout = Just (addTime governor_BOOTSTRAP_PEERS_TIMEOUT now)
            , publicRootBackoffs = 0
            , publicRootRetryTime = now
            })
        LedgerStateJudgement
YoungEnough -> do
          let nonEstablishedBootstrapPeers :: Set peeraddr
nonEstablishedBootstrapPeers =
                PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBootstrapPeers PublicRootPeers peeraddr
publicRootPeers
                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 Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Semigroup a => a -> a -> a
<> Set peeraddr
inProgressPromoteWarm)
          (Time -> PeerSelectionState peeraddr peerconn)
-> STM m (Time -> PeerSelectionState peeraddr peerconn)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (\Time
now -> PeerSelectionState peeraddr peerconn
st
            { ledgerStateJudgement  = lsj
            , hasOnlyBootstrapPeers = False
            , bootstrapPeersTimeout = Nothing
            , knownPeers =
                KnownPeers.delete
                  nonEstablishedBootstrapPeers
                  knownPeers
            , publicRootPeers =
                PublicRootPeers.difference
                  publicRootPeers
                  nonEstablishedBootstrapPeers
            , publicRootBackoffs = 0
            , publicRootRetryTime = now
            })
      return $ \Time
now ->
        Decision {
          decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [LedgerStateJudgement -> TracePeerSelection peeraddr
forall peeraddr.
LedgerStateJudgement -> TracePeerSelection peeraddr
TraceLedgerStateJudgementChanged LedgerStateJudgement
lsj],
          decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [],
          decisionState :: PeerSelectionState peeraddr peerconn
decisionState = Time -> PeerSelectionState peeraddr peerconn
st' Time
now
        }
  | 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

-- | If the node just got in the TooOld state, the node just had its targets
-- adjusted to get rid of all peers. This jobs monitors the node state and when
-- it has arrived to a clean (quiesced) state it sets the 'hasOnlyBootstrapPeers'
-- flag on which will unblock the 'localRoots' and 'targetPeers' monitoring actions,
-- allowing the node to make progress by only connecting to trusted peers.
--
-- It should be noted if the node is _not_ in bootstrap mode (i.e. _not_ in a
-- sensitive state) then this monitoring action will be disabled.
--
-- If the node takes more than 15 minutes to converge to a clean state the
-- node will crash itself so it can be brought back on again in a clean state.
-- If the node takes more than 15 minutes to converge to a clean state it
-- means something really bad must be going on, such a global network outage,
-- DNS issues, or there could be an actual bug in the code. In any case we'll
-- detect that and have a way to observe such cases.
--
waitForSystemToQuiesce :: ( MonadSTM m
                          , Ord peeraddr
                          )
                       => PeerSelectionState peeraddr peerconn
                       -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
waitForSystemToQuiesce :: forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
waitForSystemToQuiesce st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState{
                            LedgerStateJudgement
ledgerStateJudgement :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LedgerStateJudgement
ledgerStateJudgement :: LedgerStateJudgement
ledgerStateJudgement
                          , UseBootstrapPeers
bootstrapPeersFlag :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> UseBootstrapPeers
bootstrapPeersFlag :: UseBootstrapPeers
bootstrapPeersFlag
                          , KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers
                          , LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers
                          , PublicRootPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers :: PublicRootPeers peeraddr
publicRootPeers
                          , Set peeraddr
inProgressPromoteCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold
                          , Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm
                          , Int
inProgressPeerShareReqs :: Int
inProgressPeerShareReqs :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Int
inProgressPeerShareReqs
                          , Bool
inProgressPublicRootsReq :: Bool
inProgressPublicRootsReq :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Bool
inProgressPublicRootsReq
                          , Bool
inProgressBigLedgerPeersReq :: Bool
inProgressBigLedgerPeersReq :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Bool
inProgressBigLedgerPeersReq
                          , Bool
hasOnlyBootstrapPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Bool
hasOnlyBootstrapPeers :: Bool
hasOnlyBootstrapPeers
                          }
  -- Is the node in sensitive state?
  | UseBootstrapPeers -> LedgerStateJudgement -> Bool
requiresBootstrapPeers UseBootstrapPeers
bootstrapPeersFlag LedgerStateJudgement
ledgerStateJudgement
  -- Has the node still haven't reached a clean state
  , Bool -> Bool
not Bool
hasOnlyBootstrapPeers
  -- Are the local root peers all trustable?
  , ((PeerAdvertise, PeerTrustable) -> Bool)
-> Map peeraddr (PeerAdvertise, PeerTrustable) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\case
            (PeerAdvertise
_, PeerTrustable
IsTrustable) -> Bool
True
            (PeerAdvertise, PeerTrustable)
_                -> Bool
False
        )
        (LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
forall peeraddr.
LocalRootPeers peeraddr
-> Map peeraddr (PeerAdvertise, PeerTrustable)
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers)
  -- Are the known peers all trustable or all in progress to be demoted?
  , KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf`
    (  PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBootstrapPeers PublicRootPeers peeraddr
publicRootPeers
    Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Semigroup a => a -> a -> a
<> LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet (LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToTrustable LocalRootPeers peeraddr
localRootPeers)
    )

  -- Are there still any in progress promotion jobs?
  , Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
inProgressPromoteCold
  , Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
inProgressPromoteWarm
  , Int
inProgressPeerShareReqs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
  , Bool -> Bool
not Bool
inProgressBigLedgerPeersReq
  , Bool -> Bool
not Bool
inProgressPublicRootsReq =
    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
      TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedDecision m peeraddr peerconn
 -> STM m (TimedDecision m peeraddr peerconn))
-> TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ \Time
_now ->
        Decision { decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [TracePeerSelection peeraddr
forall peeraddr. TracePeerSelection peeraddr
TraceOnlyBootstrapPeers],
                   decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [],
                   decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st { hasOnlyBootstrapPeers = True
                                      , bootstrapPeersTimeout = Nothing
                                      }
        }
  | 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

-- |This job, which is initiated by monitorLedgerStateJudgement job,
-- verifies whether the provided big ledger pools match up with the
-- ledger state once the node catches up to the slot at which the
-- snapshot was ostensibly taken
--
jobVerifyPeerSnapshot :: ( MonadSTM m )
                      => LedgerPeerSnapshot
                      -> LedgerPeersConsensusInterface m
                      -> Job () m (Completion m peeraddr peerconn)
jobVerifyPeerSnapshot :: forall (m :: * -> *) peeraddr peerconn.
MonadSTM m =>
LedgerPeerSnapshot
-> LedgerPeersConsensusInterface m
-> Job () m (Completion m peeraddr peerconn)
jobVerifyPeerSnapshot baseline :: LedgerPeerSnapshot
baseline@(LedgerPeerSnapshot (WithOrigin SlotNo
slot, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
_))
                      LedgerPeersConsensusInterface {
                        STM m (WithOrigin SlotNo)
lpGetLatestSlot :: STM m (WithOrigin SlotNo)
lpGetLatestSlot :: forall (m :: * -> *).
LedgerPeersConsensusInterface m -> STM m (WithOrigin SlotNo)
lpGetLatestSlot,
                        STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers :: forall (m :: * -> *).
LedgerPeersConsensusInterface m
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers }
  = 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)
forall {m :: * -> *} {peeraddr} {peerconn}.
m (Completion m peeraddr peerconn)
job (m (Completion m peeraddr peerconn)
-> SomeException -> m (Completion m peeraddr peerconn)
forall a b. a -> b -> a
const (Bool -> m (Completion m peeraddr peerconn)
forall {m :: * -> *} {m :: * -> *} {peeraddr} {peerconn}.
Monad m =>
Bool -> m (Completion m peeraddr peerconn)
completion Bool
False)) () String
"jobVerifyPeerSnapshot"
  where
    completion :: Bool -> m (Completion m peeraddr peerconn)
completion Bool
result = 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))
-> ((PeerSelectionState peeraddr peerconn
     -> Time -> Decision m peeraddr peerconn)
    -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> m (Completion m peeraddr peerconn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
 -> m (Completion m peeraddr peerconn))
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ \PeerSelectionState peeraddr peerconn
st Time
_now ->
      Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [Bool -> TracePeerSelection peeraddr
forall peeraddr. Bool -> TracePeerSelection peeraddr
TraceVerifyPeerSnapshot Bool
result],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st,
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [] }

    job :: m (Completion m peeraddr peerconn)
job = do
      ledgerPeers <-
        STM m [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> m [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall a. (?callStack::CallStack) => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
 -> m [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> STM m [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> m [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall a b. (a -> b) -> a -> b
$ do
          Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ())
-> (WithOrigin SlotNo -> Bool) -> WithOrigin SlotNo -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin SlotNo
slot) (WithOrigin SlotNo -> STM m ())
-> STM m (WithOrigin SlotNo) -> STM m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM m (WithOrigin SlotNo)
lpGetLatestSlot
          [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accumulateBigLedgerStake ([(PoolStake, NonEmpty RelayAccessPoint)]
 -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers
      let candidate = (WithOrigin SlotNo,
 [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> LedgerPeerSnapshot
LedgerPeerSnapshot (WithOrigin SlotNo
slot, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
ledgerPeers) -- ^ slot here is intentional
      completion $ compareLedgerPeerSnapshotApproximate baseline candidate

-- |This job monitors for any changes in the big ledger peer snapshot
-- and flips ledger state judgement private state so that monitoring action
-- can launch `jobVerifyPeerSnapshot`
--
ledgerPeerSnapshotChange :: (MonadSTM m)
                         => PeerSelectionState peeraddr peerconn
                         -> PeerSelectionActions peeraddr peerconn m
                         -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
ledgerPeerSnapshotChange :: forall (m :: * -> *) peeraddr peerconn.
MonadSTM m =>
PeerSelectionState peeraddr peerconn
-> PeerSelectionActions peeraddr peerconn m
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
ledgerPeerSnapshotChange st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
                              Maybe LedgerPeerSnapshot
ledgerPeerSnapshot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Maybe LedgerPeerSnapshot
ledgerPeerSnapshot :: Maybe LedgerPeerSnapshot
ledgerPeerSnapshot }
                         PeerSelectionActions {
                           STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot } =
  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
    ledgerPeerSnapshot' <- STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot
    case (ledgerPeerSnapshot', ledgerPeerSnapshot) of
      (Maybe LedgerPeerSnapshot
Nothing, Maybe LedgerPeerSnapshot
_) -> STM m (TimedDecision m peeraddr peerconn)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      (Just (LedgerPeerSnapshot (WithOrigin SlotNo
slot, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
_)), Just (LedgerPeerSnapshot (WithOrigin SlotNo
slot', [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
_)))
        | WithOrigin SlotNo
slot WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== WithOrigin SlotNo
slot' -> STM m (TimedDecision m peeraddr peerconn)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      (Maybe LedgerPeerSnapshot, Maybe LedgerPeerSnapshot)
_otherwise ->
        TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedDecision m peeraddr peerconn
 -> STM m (TimedDecision m peeraddr peerconn))
-> TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ \Time
_now ->
                   Decision { decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [],
                              decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [],
                              decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                                ledgerStateJudgement = YoungEnough,
                                ledgerPeerSnapshot = ledgerPeerSnapshot' } }