{-# 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
  , 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.ExitPolicy (RepromoteDelay)
import Ouroboros.Network.ExitPolicy qualified as ExitPolicy
import Ouroboros.Network.PeerSelection.Governor.ActivePeers
           (jobDemoteActivePeer)
import Ouroboros.Network.PeerSelection.Governor.Types hiding
           (PeerSelectionCounters)
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
           (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..),
           compareLedgerPeerSnapshotApproximate)
import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
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
           (LocalRootConfig (..))
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers
import Ouroboros.Network.PeerSelection.Types

-- | 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'.
--
targetPeers :: (MonadSTM m, Ord peeraddr)
            => PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn m
            -> PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn
            -> Guarded (STM m) (TimedDecision m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
targetPeers :: forall (m :: * -> *) peeraddr extraState extraFlags extraPeers
       extraAPI extraCounters peerconn extraDebugState.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
targetPeers PeerSelectionActions{ STM m PeerSelectionTargets
readPeerSelectionTargets :: STM m PeerSelectionTargets
readPeerSelectionTargets :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> STM m PeerSelectionTargets
readPeerSelectionTargets,
                                  PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI :: PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI
                                }
            st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState{
              PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers,
              LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers,
              PeerSelectionTargets
targets :: PeerSelectionTargets
targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets
            } =
    Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      targets' <- STM m PeerSelectionTargets
readPeerSelectionTargets
      check (targets' /= targets && sanePeerSelectionTargets targets')
      -- We simply ignore target updates that are not "sane".

      let -- 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.
          --
          -- 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 extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr
forall peeraddr extraFlags.
Ord peeraddr =>
Int
-> LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr
LocalRootPeers.clampToLimit
                              (PeerSelectionTargets -> Int
targetNumberOfKnownPeers PeerSelectionTargets
targets')
                              LocalRootPeers extraFlags peeraddr
localRootPeers

          -- We have to enforce that local and big ledger peers are disjoint.
          publicRootPeers' =
            (extraPeers -> Set peeraddr -> extraPeers)
-> PublicRootPeers extraPeers peeraddr
-> Set peeraddr
-> PublicRootPeers extraPeers peeraddr
forall peeraddr extraPeers.
Ord peeraddr =>
(extraPeers -> Set peeraddr -> extraPeers)
-> PublicRootPeers extraPeers peeraddr
-> Set peeraddr
-> PublicRootPeers extraPeers peeraddr
PublicRootPeers.difference (PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr -> extraPeers
forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI)
              PublicRootPeers extraPeers peeraddr
publicRootPeers (LocalRootPeers extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags peeraddr
localRootPeers')

      return $ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [PeerSelectionTargets
-> PeerSelectionTargets
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
PeerSelectionTargets
-> PeerSelectionTargets
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceTargetsChanged PeerSelectionTargets
targets PeerSelectionTargets
targets'],
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers 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 extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
     -> PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn
     -> Guarded (STM m) (TimedDecision m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
jobs :: forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
MonadSTM m =>
JobPool
  ()
  m
  (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobs JobPool
  ()
  m
  (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
jobPool PeerSelectionState
  extraState extraFlags extraPeers 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
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      Completion completion <- JobPool
  ()
  m
  (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
-> STM
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) group a.
MonadSTM m =>
JobPool group m a -> STM m a
JobPool.waitForJob JobPool
  ()
  m
  (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
jobPool
      return (completion st)


-- | Monitor connections.
--
connections :: forall m extraState extraDebugState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn.
               (MonadSTM m, Ord peeraddr)
            => PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn m
            -> PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn
            -> Guarded (STM m) (TimedDecision m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
connections :: forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
connections PeerSelectionActions{
              peerStateActions :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerStateActions peeraddr peerconn m
peerStateActions = PeerStateActions {peerconn -> 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
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
              PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
              LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers,
              Set peeraddr
activePeers :: Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers,
              EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers,
              Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteHot,
              Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteWarm,
              Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteWarm,
              Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteToCold,
              StdGen
stdGen :: StdGen
stdGen :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> StdGen
stdGen
            } =
    Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      -- 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
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st)
                               (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 extraFlags peeraddr -> Bool
forall peeraddr extraFlags.
Ord peeraddr =>
peeraddr -> LocalRootPeers extraFlags peeraddr -> Bool
`LocalRootPeers.member` LocalRootPeers extraFlags 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
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     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 extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [ Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers peeraddr]
-> [TracePeerSelection
      extraDebugState extraFlags extraPeers peeraddr]
-> [TracePeerSelection
      extraDebugState extraFlags extraPeers peeraddr]
forall a. Semigroup a => a -> a -> a
<> [ Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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 extraDebugState extraFlags extraPeers peeraddr]
-> [TracePeerSelection
      extraDebugState extraFlags extraPeers peeraddr]
-> [TracePeerSelection
      extraDebugState extraFlags extraPeers peeraddr]
forall a. Semigroup a => a -> a -> a
<> [ Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Map peeraddr (PeerStatus, Maybe RepromoteDelay)
-> TracePeerSelection
     extraDebugState extraFlags extraPeers 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
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [],
              decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers 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 extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers 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.
--
localRoots :: forall extraState extraDebugState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn m.
              (MonadSTM m, Ord peeraddr, Eq extraFlags)
           => PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn m
           -> PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn
           -> Guarded (STM m) (TimedDecision m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
localRoots :: forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr, Eq extraFlags) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
localRoots actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@PeerSelectionActions{ STM m (Config extraFlags peeraddr)
readLocalRootPeers :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> STM m (Config extraFlags peeraddr)
readLocalRootPeers :: STM m (Config extraFlags peeraddr)
readLocalRootPeers
                                       , extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                                           extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers :: extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers
                                         , extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet
                                         }
                                       }
           st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState{
             LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers,
             PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
             KnownPeers peeraddr
knownPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
             EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
             Set peeraddr
activePeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
activePeers :: Set peeraddr
activePeers,
             Set peeraddr
inProgressDemoteHot :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
             Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold,
             targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets{Int
targetNumberOfKnownPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers}
           } =
    Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      -- 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.
      localRootPeersRaw <- STM m (Config extraFlags peeraddr)
readLocalRootPeers
      let localRootPeers' = Int
-> LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr
forall peeraddr extraFlags.
Ord peeraddr =>
Int
-> LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr
LocalRootPeers.clampToLimit
                              Int
targetNumberOfKnownPeers
                          (LocalRootPeers extraFlags peeraddr
 -> LocalRootPeers extraFlags peeraddr)
-> (Config extraFlags peeraddr
    -> LocalRootPeers extraFlags peeraddr)
-> Config extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config extraFlags peeraddr -> LocalRootPeers extraFlags peeraddr
forall peeraddr extraFlags.
Ord peeraddr =>
[(HotValency, WarmValency,
  Map peeraddr (LocalRootConfig extraFlags))]
-> LocalRootPeers extraFlags peeraddr
LocalRootPeers.fromGroups
                          (Config extraFlags peeraddr -> LocalRootPeers extraFlags peeraddr)
-> Config extraFlags peeraddr -> LocalRootPeers extraFlags peeraddr
forall a b. (a -> b) -> a -> b
$ Config extraFlags peeraddr
localRootPeersRaw
      check (localRootPeers' /= localRootPeers)
      --TODO: trace when the clamping kicks in, and warn operators

      let added, removed :: Map peeraddr (LocalRootConfig extraFlags)
          added        = LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
LocalRootPeers.toMap LocalRootPeers extraFlags peeraddr
localRootPeers' Map peeraddr (LocalRootConfig extraFlags)
-> Map peeraddr (LocalRootConfig extraFlags)
-> Map peeraddr (LocalRootConfig extraFlags)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\
                         LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
LocalRootPeers.toMap LocalRootPeers extraFlags peeraddr
localRootPeers
          removed      = LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
LocalRootPeers.toMap LocalRootPeers extraFlags peeraddr
localRootPeers  Map peeraddr (LocalRootConfig extraFlags)
-> Map peeraddr (LocalRootConfig extraFlags)
-> Map peeraddr (LocalRootConfig extraFlags)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\
                         LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
LocalRootPeers.toMap LocalRootPeers extraFlags peeraddr
localRootPeers'
          -- LocalRoots are not ledger!
          addedInfoMap = (LocalRootConfig extraFlags -> (Maybe a, Maybe PeerAdvertise))
-> Map peeraddr (LocalRootConfig extraFlags)
-> Map peeraddr (Maybe a, Maybe PeerAdvertise)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
                           (\LocalRootConfig { PeerAdvertise
peerAdvertise :: PeerAdvertise
peerAdvertise :: forall extraFlags. LocalRootConfig extraFlags -> PeerAdvertise
peerAdvertise } ->
                             (Maybe a
forall a. Maybe a
Nothing, PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
peerAdvertise))
                           Map peeraddr (LocalRootConfig extraFlags)
added
          removedSet   = Map peeraddr (LocalRootConfig extraFlags) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (LocalRootConfig extraFlags)
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 extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags peeraddr
localRootPeers'

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

          -- 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
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     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
                    ((extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall peeraddr extraPeers.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet extraPeers -> Set peeraddr
extraPeersToSet
                                           PublicRootPeers extraPeers peeraddr
publicRootPeers')
                   (KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers'))
        (Decision
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> (Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     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 extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags peeraddr
localRootPeers')
                   (KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers'))

        (Decision
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a b. (a -> b) -> a -> b
$ Decision {
            decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceLocalRootPeersChanged LocalRootPeers extraFlags peeraddr
localRootPeers
                                                        LocalRootPeers extraFlags peeraddr
localRootPeers'],
            decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                              localRootPeers      = localRootPeers',
                              publicRootPeers     = publicRootPeers',
                              knownPeers          = knownPeers',
                              inProgressDemoteHot = inProgressDemoteHot
                                                 <> selectedToDemote
                            },
            decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [ PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall extraState extraDebugState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> peeraddr
-> peerconn
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobDemoteActivePeer PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions peeraddr
peeraddr peerconn
peerconn
                            | (peeraddr
peeraddr, peerconn
peerconn) <- Map peeraddr peerconn -> [(peeraddr, peerconn)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToDemote' ]
          }

-- |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 extraAPI m
                      -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
jobVerifyPeerSnapshot :: forall (m :: * -> *) extraAPI extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
MonadSTM m =>
LedgerPeerSnapshot
-> LedgerPeersConsensusInterface extraAPI m
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        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 extraAPI (m :: * -> *).
LedgerPeersConsensusInterface extraAPI m
-> STM m (WithOrigin SlotNo)
lpGetLatestSlot,
                        STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers :: forall extraAPI (m :: * -> *).
LedgerPeersConsensusInterface extraAPI m
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers }
  = m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
-> (SomeException
    -> m (Completion
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> ()
-> String
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
forall {m :: * -> *} {extraState} {extraDebugState} {extraFlags}
       {extraPeers} {peeraddr} {peerconn}.
m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
job (m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
-> SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. a -> b -> a
const (Bool
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall {m :: * -> *} {m :: * -> *} {extraState} {extraDebugState}
       {extraFlags} {extraPeers} {peeraddr} {peerconn}.
Monad m =>
Bool
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
completion Bool
False)) () String
"jobVerifyPeerSnapshot"
  where
    completion :: Bool
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
completion Bool
result = Completion
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> ((PeerSelectionState
       extraState extraFlags extraPeers peeraddr peerconn
     -> Time
     -> Decision
          m
          extraState
          extraDebugState
          extraFlags
          extraPeers
          peeraddr
          peerconn)
    -> Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
(PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
Completion ((PeerSelectionState
    extraState extraFlags extraPeers peeraddr peerconn
  -> Time
  -> Decision
       m
       extraState
       extraDebugState
       extraFlags
       extraPeers
       peeraddr
       peerconn)
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ \PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st Time
_now ->
      Decision {
        decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Bool
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Bool
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceVerifyPeerSnapshot Bool
result],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st,
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [] }

    job :: m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
job = 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)
                         => (extraState -> extraState)
                         -> PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn m
                         -> PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn
                         -> Guarded (STM m) (TimedDecision m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
ledgerPeerSnapshotChange :: forall (m :: * -> *) extraState extraFlags extraPeers extraAPI
       extraCounters peeraddr peerconn extraDebugState.
MonadSTM m =>
(extraState -> extraState)
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
ledgerPeerSnapshotChange extraState -> extraState
extraStateChange
                         PeerSelectionActions {
                           STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot
                         }
                         st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                           Maybe LedgerPeerSnapshot
ledgerPeerSnapshot :: Maybe LedgerPeerSnapshot
ledgerPeerSnapshot :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Maybe LedgerPeerSnapshot
ledgerPeerSnapshot,
                           extraState
extraState :: extraState
extraState :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraState
extraState
                         } =
  Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
    ledgerPeerSnapshot' <- STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot
    case (ledgerPeerSnapshot', ledgerPeerSnapshot) of
      (Maybe LedgerPeerSnapshot
Nothing, Maybe LedgerPeerSnapshot
_) -> STM
  m
  (TimedDecision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     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
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      (Maybe LedgerPeerSnapshot, Maybe LedgerPeerSnapshot)
_otherwise ->
        TimedDecision
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedDecision
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> STM
      m
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> TimedDecision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ \Time
_now ->
                   Decision { decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [],
                              decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [],
                              decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                                extraState = extraStateChange extraState,
                                ledgerPeerSnapshot = ledgerPeerSnapshot'
                              }
                            }