{-# 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
  , connections
  , localRoots
  , inboundPeers
  ) where

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

import           Control.Concurrent.JobPool (JobPool)
import qualified Control.Concurrent.JobPool 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 (ReconnectDelay)
import qualified Ouroboros.Network.ExitPolicy as ExitPolicy
import           Ouroboros.Network.PeerSelection.Governor.ActivePeers
                     (jobDemoteActivePeer)
import           Ouroboros.Network.PeerSelection.Governor.Types hiding
                     (PeerSelectionCounters (..))
import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers
import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers
import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers 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 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 :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> STM m PeerSelectionTargets
readPeerSelectionTargets :: STM m PeerSelectionTargets
readPeerSelectionTargets}
            st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState{
              Set peeraddr
bigLedgerPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
bigLedgerPeers :: Set peeraddr
bigLedgerPeers,
              LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
              PeerSelectionTargets
targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets :: PeerSelectionTargets
targets
            } =
    forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
      PeerSelectionTargets
targets' <- STM m PeerSelectionTargets
readPeerSelectionTargets
      forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (PeerSelectionTargets
targets' forall a. Eq a => a -> a -> Bool
/= PeerSelectionTargets
targets Bool -> Bool -> Bool
&& PeerSelectionTargets -> Bool
sanePeerSelectionTargets PeerSelectionTargets
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' :: LocalRootPeers peeraddr
localRootPeers' = forall peeraddr.
Ord peeraddr =>
Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToLimit
                              (PeerSelectionTargets -> Int
targetNumberOfKnownPeers PeerSelectionTargets
targets')
                              LocalRootPeers peeraddr
localRootPeers

          -- We have to enforce that local and big ledger peers are disjoint.
          bigLedgerPeers' :: Set peeraddr
bigLedgerPeers' = Set peeraddr
bigLedgerPeers
                            forall a. Ord a => Set a -> Set a -> Set a
Set.\\
                            forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers'

      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [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 :: PeerSelectionTargets
targets        = PeerSelectionTargets
targets',
                          localRootPeers :: LocalRootPeers peeraddr
localRootPeers = LocalRootPeers peeraddr
localRootPeers',
                          bigLedgerPeers :: Set peeraddr
bigLedgerPeers = Set peeraddr
bigLedgerPeers'
                        }
      }


-- | 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'.
    forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
      Completion PeerSelectionState peeraddr peerconn
-> TimedDecision m peeraddr peerconn
completion <- forall (m :: * -> *) group a.
MonadSTM m =>
JobPool group m a -> STM m a
JobPool.waitForJob JobPool () m (Completion m peeraddr peerconn)
jobPool
      forall (m :: * -> *) a. Monad m => a -> m a
return (PeerSelectionState peeraddr peerconn
-> TimedDecision m peeraddr peerconn
completion PeerSelectionState peeraddr peerconn
st)

-- | Monitor new inbound connections
--
inboundPeers :: forall m peeraddr peerconn.
                 (MonadSTM m, Ord peeraddr)
             => PeerSelectionActions peeraddr peerconn m
             -> PeerSelectionState peeraddr peerconn
             -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
inboundPeers :: forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
inboundPeers PeerSelectionActions{
               STM m (peeraddr, PeerSharing)
readNewInboundConnection :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> STM m (peeraddr, PeerSharing)
readNewInboundConnection :: STM m (peeraddr, PeerSharing)
readNewInboundConnection
             }
             st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
               KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers
             } =
  forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
    (peeraddr
addr, PeerSharing
ps) <- STM m (peeraddr, PeerSharing)
readNewInboundConnection
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Time
_ ->
      let -- If peer happens to already be present in the Known Peer set
          -- 'insert' is going to do its due diligence before adding.
          newEntry :: Map peeraddr (Maybe PeerSharing, Maybe a, Maybe a)
newEntry    = forall k a. k -> a -> Map k a
Map.singleton peeraddr
addr (forall a. a -> Maybe a
Just PeerSharing
ps, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
          knownPeers' :: KnownPeers peeraddr
knownPeers' = forall peeraddr.
Ord peeraddr =>
Map
  peeraddr
  (Maybe PeerSharing, Maybe PeerAdvertise, Maybe IsLedgerPeer)
-> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.insert forall {a} {a}. Map peeraddr (Maybe PeerSharing, Maybe a, Maybe a)
newEntry KnownPeers peeraddr
knownPeers
       in Decision {
            decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [forall peeraddr.
peeraddr -> PeerSharing -> TracePeerSelection peeraddr
TraceKnownInboundConnection peeraddr
addr PeerSharing
ps],
            decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs = [],
            decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st { knownPeers :: KnownPeers peeraddr
knownPeers = KnownPeers peeraddr
knownPeers' }
          }

-- | 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 ReconnectDelay)
monitorPeerConnection :: forall peeraddr peerconn (m :: * -> *).
PeerStateActions peeraddr peerconn m
-> peerconn -> STM m (PeerStatus, Maybe ReconnectDelay)
monitorPeerConnection :: peerconn -> STM m (PeerStatus, Maybe ReconnectDelay)
monitorPeerConnection}
            }
            st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
              Set peeraddr
bigLedgerPeers :: Set peeraddr
bigLedgerPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
bigLedgerPeers,
              LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers,
              Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers :: Set peeraddr
activePeers,
              EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
              Set peeraddr
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot,
              Set peeraddr
inProgressDemoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm,
              Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm,
              StdGen
fuzzRng :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> StdGen
fuzzRng :: StdGen
fuzzRng
            } =
    forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ do
      Map peeraddr (PeerStatus, Maybe ReconnectDelay)
monitorStatus <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse peerconn -> STM m (PeerStatus, Maybe ReconnectDelay)
monitorPeerConnection
                                (forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers)
      let demotions :: Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotions = Map peeraddr (PeerStatus, Maybe ReconnectDelay)
-> Map peeraddr (PeerStatus, Maybe ReconnectDelay)
asynchronousDemotions Map peeraddr (PeerStatus, Maybe ReconnectDelay)
monitorStatus
      forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotions))
      let (Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotedToWarm, Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotedToCold) = forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition ((forall a. Eq a => a -> a -> Bool
==PeerStatus
PeerWarm) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotions
          -- fuzz reconnect delays
          (Double
aFuzz, StdGen
fuzzRng')  = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (-Double
5, Double
5 :: Double) StdGen
fuzzRng
          (Double
rFuzz, StdGen
fuzzRng'') = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (-Double
2, Double
2 :: Double) StdGen
fuzzRng'
          demotions' :: Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotions' = (\a :: (PeerStatus, Maybe ReconnectDelay)
a@(PeerStatus
peerState, Maybe ReconnectDelay
reconnectDelay) -> case PeerStatus
peerState of
                         PeerStatus
PeerHot  -> (PeerStatus, Maybe ReconnectDelay)
a
                         PeerStatus
PeerWarm -> ( PeerStatus
peerState
                                     , (\ReconnectDelay
x -> (ReconnectDelay
x forall a. Num a => a -> a -> a
+ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
aFuzz) forall a. Ord a => a -> a -> a
`max` ReconnectDelay
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ReconnectDelay
reconnectDelay
                                     )
                         PeerStatus
PeerCold -> ( PeerStatus
peerState
                                     , (\ReconnectDelay
x -> (ReconnectDelay
x forall a. Num a => a -> a -> a
+ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
rFuzz) forall a. Ord a => a -> a -> a
`max` ReconnectDelay
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ReconnectDelay
reconnectDelay
                                     )
                       ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotions
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Time
now ->
        let -- Remove all asynchronous demotions from 'activePeers'
            activePeers' :: Set peeraddr
activePeers'       = Set peeraddr
activePeers forall a. Ord a => Set a -> Set a -> Set a
Set.\\ forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe ReconnectDelay)
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'  = forall peeraddr peerconn.
Ord peeraddr =>
Map peeraddr Time
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
EstablishedPeers.setActivateTimes
                                   ( (\(PeerStatus
_, Maybe ReconnectDelay
a) -> ReconnectDelay -> DiffTime
ExitPolicy.reconnectDelay (forall a. a -> Maybe a -> a
fromMaybe ReconnectDelay
0 Maybe ReconnectDelay
a) DiffTime -> Time -> Time
`addTime` Time
now)
                                      -- 'monitorPeerConnection' returns
                                      -- 'Nothing' iff all mini-protocols are
                                      -- either still running or 'NotRunning'
                                      -- (e.g.  this possible for warm or hot
                                      -- peers).  In such case we don't want to
                                      -- `setActivateTimes`
                                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\(PeerStatus
_, Maybe ReconnectDelay
a) -> Maybe ReconnectDelay
a forall a. Eq a => a -> a -> Bool
/= forall a. Maybe a
Nothing)
                                                     Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotedToWarm
                                   )
                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall peeraddr peerconn.
Ord peeraddr =>
Set peeraddr
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
EstablishedPeers.deletePeers
                                  (forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotedToCold)
                               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'        = forall peeraddr.
Ord peeraddr =>
Map peeraddr Time -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.setConnectTimes
                                    ( (\(PeerStatus
_, Maybe ReconnectDelay
a) -> ReconnectDelay -> DiffTime
ExitPolicy.reconnectDelay (forall a. a -> Maybe a -> a
fromMaybe ReconnectDelay
0 Maybe ReconnectDelay
a) DiffTime -> Time -> Time
`addTime` Time
now)
                                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotedToCold
                                    )
                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr'
                                   ((forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
KnownPeers.incrementFailCount)
                                   (forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers PeerSelectionState peeraddr peerconn
st)
                               forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotedToCold
            (Map peeraddr (PeerStatus, Maybe ReconnectDelay)
localDemotions, Map peeraddr (PeerStatus, Maybe ReconnectDelay)
nonLocalDemotions) =
              forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey
                (\peeraddr
peer (PeerStatus, Maybe ReconnectDelay)
_ -> peeraddr
peer forall peeraddr.
Ord peeraddr =>
peeraddr -> LocalRootPeers peeraddr -> Bool
`LocalRootPeers.member` LocalRootPeers peeraddr
localRootPeers)
                Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotions'

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

        in forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr
activePeers' forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf`
                     forall k a. Map k a -> Set k
Map.keysSet (forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers'))
            Decision {
              decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [ forall peeraddr.
Map peeraddr (PeerStatus, Maybe ReconnectDelay)
-> TracePeerSelection peeraddr
TraceDemoteLocalAsynchronous Map peeraddr (PeerStatus, Maybe ReconnectDelay)
localDemotions
                              | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map peeraddr (PeerStatus, Maybe ReconnectDelay)
localDemotions ]
                           forall a. Semigroup a => a -> a -> a
<> [ forall peeraddr.
Map peeraddr (PeerStatus, Maybe ReconnectDelay)
-> TracePeerSelection peeraddr
TraceDemoteAsynchronous Map peeraddr (PeerStatus, Maybe ReconnectDelay)
publicRootDemotions
                              | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map peeraddr (PeerStatus, Maybe ReconnectDelay)
publicRootDemotions ]
                           forall a. Semigroup a => a -> a -> a
<> [ forall peeraddr.
Map peeraddr (PeerStatus, Maybe ReconnectDelay)
-> TracePeerSelection peeraddr
TraceDemoteBigLedgerPeersAsynchronous
                                  Map peeraddr (PeerStatus, Maybe ReconnectDelay)
bigLedgerPeersDemotions
                              | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map peeraddr (PeerStatus, Maybe ReconnectDelay)
bigLedgerPeersDemotions ],
              decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [],
              decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                                activePeers :: Set peeraddr
activePeers       = Set peeraddr
activePeers',
                                establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers  = EstablishedPeers peeraddr peerconn
establishedPeers',
                                knownPeers :: KnownPeers peeraddr
knownPeers        = KnownPeers peeraddr
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 :: Set peeraddr
inProgressPromoteWarm
                                                  = Set peeraddr
inProgressPromoteWarm
                                                      forall a. Ord a => Set a -> Set a -> Set a
Set.\\ forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (PeerStatus, Maybe ReconnectDelay)
demotedToCold,

                                -- 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.

                                fuzzRng :: StdGen
fuzzRng = StdGen
fuzzRng''
                              }
          }
  where
    -- 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 ReconnectDelay) -> Map peeraddr (PeerStatus, Maybe ReconnectDelay)
    asynchronousDemotions :: Map peeraddr (PeerStatus, Maybe ReconnectDelay)
-> Map peeraddr (PeerStatus, Maybe ReconnectDelay)
asynchronousDemotions = forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey peeraddr
-> (PeerStatus, Maybe ReconnectDelay)
-> Maybe (PeerStatus, Maybe ReconnectDelay)
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 ReconnectDelay) -> Maybe (PeerStatus, Maybe ReconnectDelay)

    -- 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 ReconnectDelay)
-> Maybe (PeerStatus, Maybe ReconnectDelay)
asyncDemotion peeraddr
peeraddr (PeerStatus
PeerWarm, Maybe ReconnectDelay
returnCommand)
      | peeraddr
peeraddr forall a. Ord a => a -> Set a -> Bool
`Set.member`    Set peeraddr
activePeers
      , peeraddr
peeraddr forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteHot  = forall a. a -> Maybe a
Just (PeerStatus
PeerWarm, Maybe ReconnectDelay
returnCommand)

    -- a warm -> cold transition has occurred if it is now cold, and it was
    -- warm, but not in the set we were deliberately demoting synchronously
    asyncDemotion peeraddr
peeraddr (PeerStatus
PeerCold, Maybe ReconnectDelay
returnCommand)
      | peeraddr
peeraddr forall peeraddr peerconn.
Ord peeraddr =>
peeraddr -> EstablishedPeers peeraddr peerconn -> Bool
`EstablishedPeers.member` EstablishedPeers peeraddr peerconn
establishedPeers
      , peeraddr
peeraddr forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
activePeers
      , peeraddr
peeraddr forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set peeraddr
inProgressDemoteWarm = forall a. a -> Maybe a
Just (PeerStatus
PeerCold, Maybe ReconnectDelay
returnCommand)

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

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


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


-- | Monitor local roots using 'readLocalRootPeers' 'STM' action.
--
localRoots :: forall peeraddr peerconn m.
              (MonadSTM m, Ord peeraddr)
           => PeerSelectionActions peeraddr peerconn m
           -> PeerSelectionPolicy peeraddr m
           -> PeerSelectionState peeraddr peerconn
           -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
localRoots :: forall peeraddr peerconn (m :: * -> *).
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
localRoots actions :: PeerSelectionActions peeraddr peerconn m
actions@PeerSelectionActions{ STM m [(HotValency, WarmValency, Map peeraddr PeerAdvertise)]
readLocalRootPeers :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> STM m [(HotValency, WarmValency, Map peeraddr PeerAdvertise)]
readLocalRootPeers :: STM m [(HotValency, WarmValency, Map peeraddr PeerAdvertise)]
readLocalRootPeers
                                       }
           PeerSelectionPolicy peeraddr m
policy
           st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState{
             Set peeraddr
bigLedgerPeers :: Set peeraddr
bigLedgerPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
bigLedgerPeers,
             LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers,
             Set peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
publicRootPeers :: Set peeraddr
publicRootPeers,
             KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers,
             EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers,
             Set peeraddr
activePeers :: Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers,
             Set peeraddr
inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot,
             targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets{Int
targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownPeers}
           } =
    forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded forall a. Maybe a
Nothing 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.
      [(HotValency, WarmValency, Map peeraddr PeerAdvertise)]
localRootPeersRaw <- STM m [(HotValency, WarmValency, Map peeraddr PeerAdvertise)]
readLocalRootPeers
      let localRootPeers' :: LocalRootPeers peeraddr
localRootPeers' = forall peeraddr.
Ord peeraddr =>
Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToLimit
                              Int
targetNumberOfKnownPeers
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall peeraddr.
Ord peeraddr =>
[(HotValency, WarmValency, Map peeraddr PeerAdvertise)]
-> LocalRootPeers peeraddr
LocalRootPeers.fromGroups
                          forall a b. (a -> b) -> a -> b
$ [(HotValency, WarmValency, Map peeraddr PeerAdvertise)]
localRootPeersRaw
      forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (LocalRootPeers peeraddr
localRootPeers' forall a. Eq a => a -> a -> Bool
/= LocalRootPeers peeraddr
localRootPeers)
      --TODO: trace when the clamping kicks in, and warn operators

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

          localRootPeersSet :: Set peeraddr
localRootPeersSet = 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' :: Set peeraddr
publicRootPeers' = Set peeraddr
publicRootPeers forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
localRootPeersSet

          -- We have to adjust the bigLedgerPeers to maintain the invariant that
          -- the local and big ledger peer sets are non-overlapping.
          bigLedgerPeers' :: Set peeraddr
bigLedgerPeers'  = Set peeraddr
bigLedgerPeers forall a. Ord a => Set a -> Set a -> Set a
Set.\\ 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
selectedToDemote  = Set peeraddr
activePeers forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set peeraddr
removedSet
          selectedToDemote' :: Map peeraddr peerconn
selectedToDemote' = forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers
                               forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` (Set peeraddr
selectedToDemote forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteHot)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Time
_now ->

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

        forall a b. (a -> b) -> a -> b
$ Decision {
            decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [forall peeraddr.
LocalRootPeers peeraddr
-> LocalRootPeers peeraddr -> TracePeerSelection peeraddr
TraceLocalRootPeersChanged LocalRootPeers peeraddr
localRootPeers
                                                        LocalRootPeers peeraddr
localRootPeers'],
            decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                              bigLedgerPeers :: Set peeraddr
bigLedgerPeers      = Set peeraddr
bigLedgerPeers',
                              localRootPeers :: LocalRootPeers peeraddr
localRootPeers      = LocalRootPeers peeraddr
localRootPeers',
                              publicRootPeers :: Set peeraddr
publicRootPeers     = Set peeraddr
publicRootPeers',
                              knownPeers :: KnownPeers peeraddr
knownPeers          = KnownPeers peeraddr
knownPeers',
                              inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot = Set peeraddr
inProgressDemoteHot
                                                 forall a. Semigroup a => a -> a -> a
<> Set peeraddr
selectedToDemote
                            },
            decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [ forall peeraddr peerconn (m :: * -> *).
(Monad m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> PeerSelectionPolicy peeraddr m
-> peeraddr
-> peerconn
-> Job () m (Completion m peeraddr peerconn)
jobDemoteActivePeer PeerSelectionActions peeraddr peerconn m
actions PeerSelectionPolicy peeraddr m
policy peeraddr
peeraddr peerconn
peerconn
                          | (peeraddr
peeraddr, peerconn
peerconn) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr peerconn
selectedToDemote' ]
          }