{-# 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
  ) where

import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
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
import           System.Random (randomR)

import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers
import           Ouroboros.Network.PeerSelection.Governor.ActivePeers
                     (jobDemoteActivePeer)
import           Ouroboros.Network.PeerSelection.Governor.Types
import qualified Ouroboros.Network.PeerSelection.KnownPeers as KnownPeers
import qualified Ouroboros.Network.PeerSelection.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 :: 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{
              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
            } =
    Maybe (Min Time)
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded Maybe (Min Time)
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      PeerSelectionTargets
targets' <- STM m PeerSelectionTargets
readPeerSelectionTargets
      Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (PeerSelectionTargets
targets' PeerSelectionTargets -> PeerSelectionTargets -> Bool
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".

      -- 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.
      let localRootPeers' :: LocalRootPeers peeraddr
localRootPeers' = Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToLimit
                              (PeerSelectionTargets -> Int
targetNumberOfKnownPeers PeerSelectionTargets
targets')
                              LocalRootPeers peeraddr
localRootPeers
      --TODO: trace when the clamping kicks in, and warn operators

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


-- | 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 :: JobPool () m (Completion m peeraddr peerconn)
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
jobs JobPool () m (Completion m peeraddr peerconn)
jobPool PeerSelectionState peeraddr peerconn
st =
    -- This case is simple because the job pool returns a 'Completion' which is
    -- just a function from the current state to a new 'Decision'.
    Maybe (Min Time)
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded Maybe (Min Time)
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      Completion PeerSelectionState peeraddr peerconn
-> TimedDecision m peeraddr peerconn
completion <- JobPool () m (Completion m peeraddr peerconn)
-> STM m (Completion m peeraddr peerconn)
forall (m :: * -> *) group a.
MonadSTM m =>
JobPool group m a -> STM m a
JobPool.collect JobPool () m (Completion m peeraddr peerconn)
jobPool
      TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeerSelectionState peeraddr peerconn
-> TimedDecision m peeraddr peerconn
completion PeerSelectionState peeraddr peerconn
st)


-- | Reconnect delay for peers which asynchronously transitioned to cold state.
--
reconnectDelay :: DiffTime
reconnectDelay :: DiffTime
reconnectDelay = DiffTime
10
--TODO: make this a policy param

-- | Activation delay after a peer was asynchronously demoted to warm state.
--
activateDelay :: DiffTime
activateDelay :: DiffTime
activateDelay = DiffTime
60
--TODO: make this a policy param


-- | 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 :: 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
monitorPeerConnection :: forall peeraddr peerconn (m :: * -> *).
PeerStateActions peeraddr peerconn m
-> peerconn -> STM m PeerStatus
monitorPeerConnection :: peerconn -> STM m PeerStatus
monitorPeerConnection}
            }
            st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
              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
            } =
    Maybe (Min Time)
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded Maybe (Min Time)
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      Map peeraddr PeerStatus
monitorStatus <- (peerconn -> STM m PeerStatus)
-> Map peeraddr peerconn -> STM m (Map peeraddr PeerStatus)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse peerconn -> STM m PeerStatus
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
demotions = Map peeraddr PeerStatus -> Map peeraddr PeerStatus
asynchronousDemotions Map peeraddr PeerStatus
monitorStatus
      Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> Bool
not (Map peeraddr PeerStatus -> Bool
forall k a. Map k a -> Bool
Map.null Map peeraddr PeerStatus
demotions))
      let (Map peeraddr PeerStatus
demotedToWarm, Map peeraddr PeerStatus
demotedToCold) = (PeerStatus -> Bool)
-> Map peeraddr PeerStatus
-> (Map peeraddr PeerStatus, Map peeraddr PeerStatus)
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (PeerStatus -> PeerStatus -> Bool
forall a. Eq a => a -> a -> Bool
==PeerStatus
PeerWarm) Map peeraddr PeerStatus
demotions
      TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedDecision m peeraddr peerconn
 -> STM m (TimedDecision m peeraddr peerconn))
-> TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ \Time
now ->
        let (Double
aFuzz, StdGen
fuzzRng')      = (Double, Double) -> StdGen -> (Double, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (-Double
5, Double
5 :: Double) StdGen
fuzzRng
            (Double
rFuzz, StdGen
fuzzRng'')     = (Double, Double) -> StdGen -> (Double, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (-Double
2, Double
2 :: Double) StdGen
fuzzRng'
            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 -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerStatus
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'  = Set peeraddr
-> Time
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall peeraddr peerconn.
Ord peeraddr =>
Set peeraddr
-> Time
-> EstablishedPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
EstablishedPeers.setActivateTime
                                  (Map peeraddr PeerStatus -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerStatus
demotedToWarm)
                                  ((Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
aFuzz DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
activateDelay)
                                   DiffTime -> Time -> Time
`addTime` Time
now)
                               (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 -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerStatus
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'        = Set peeraddr -> Time -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Set peeraddr -> Time -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.setConnectTime
                                   (Map peeraddr PeerStatus -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerStatus
demotedToCold)
                                   ((Double -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
rFuzz DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
reconnectDelay)
                                    DiffTime -> Time -> Time
`addTime` Time
now)
                               (KnownPeers peeraddr -> KnownPeers peeraddr)
-> (Set peeraddr -> KnownPeers peeraddr)
-> Set peeraddr
-> KnownPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr)
-> KnownPeers peeraddr -> Set peeraddr -> KnownPeers peeraddr
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr'
                                   (((Int, KnownPeers peeraddr) -> KnownPeers peeraddr
forall a b. (a, b) -> b
snd ((Int, KnownPeers peeraddr) -> KnownPeers peeraddr)
-> (KnownPeers peeraddr -> (Int, KnownPeers peeraddr))
-> KnownPeers peeraddr
-> KnownPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((KnownPeers peeraddr -> (Int, KnownPeers peeraddr))
 -> KnownPeers peeraddr -> KnownPeers peeraddr)
-> (peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr))
-> peeraddr
-> KnownPeers peeraddr
-> KnownPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> (Int, KnownPeers peeraddr)
KnownPeers.incrementFailCount)
                                   (PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers PeerSelectionState peeraddr peerconn
st)
                               (Set peeraddr -> KnownPeers peeraddr)
-> Set peeraddr -> KnownPeers peeraddr
forall a b. (a -> b) -> a -> b
$ (Map peeraddr PeerStatus -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerStatus
demotedToCold)

        in Bool
-> Decision m peeraddr peerconn -> Decision m peeraddr peerconn
forall a. (?callStack::CallStack) => Bool -> a -> a
assert
            (let establishedPeersSet' :: Set peeraddr
establishedPeersSet' =
                   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')
             in Set peeraddr
activePeers' Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set peeraddr
establishedPeersSet'
             Bool -> Bool -> Bool
&&    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')
                Set peeraddr -> Set peeraddr -> Bool
forall a. Eq a => a -> a -> Bool
== Set peeraddr
establishedPeersSet')

            Decision :: forall (m :: * -> *) peeraddr peerconn.
TracePeerSelection peeraddr
-> PeerSelectionState peeraddr peerconn
-> [Job () m (Completion m peeraddr peerconn)]
-> Decision m peeraddr peerconn
Decision {
              decisionTrace :: TracePeerSelection peeraddr
decisionTrace = Map peeraddr PeerStatus -> TracePeerSelection peeraddr
forall peeraddr.
Map peeraddr PeerStatus -> TracePeerSelection peeraddr
TraceDemoteAsynchronous Map peeraddr PeerStatus
demotions,
              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
                                                      Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Map peeraddr PeerStatus -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerStatus
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 -> Map peeraddr PeerStatus
    asynchronousDemotions :: Map peeraddr PeerStatus -> Map peeraddr PeerStatus
asynchronousDemotions = (peeraddr -> PeerStatus -> Maybe PeerStatus)
-> Map peeraddr PeerStatus -> Map peeraddr PeerStatus
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey peeraddr -> PeerStatus -> Maybe PeerStatus
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 PeerStatus

    -- 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 PeerStatus
asyncDemotion peeraddr
peeraddr PeerStatus
PeerWarm
      | 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 PeerStatus
forall a. a -> Maybe a
Just PeerStatus
PeerWarm

    -- 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
      | 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 = PeerStatus -> Maybe PeerStatus
forall a. a -> Maybe a
Just PeerStatus
PeerCold

    -- a hot -> cold transition has occurred if it is now cold, and it was hot
    asyncDemotion peeraddr
peeraddr PeerStatus
PeerCold
      | 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 PeerStatus
forall a. a -> Maybe a
Just PeerStatus
PeerCold

    asyncDemotion peeraddr
_        PeerStatus
_                          = Maybe PeerStatus
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
           -> PeerSelectionState peeraddr peerconn
           -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
localRoots :: PeerSelectionActions peeraddr peerconn m
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
localRoots actions :: PeerSelectionActions peeraddr peerconn m
actions@PeerSelectionActions{STM m [(Int, Map peeraddr PeerAdvertise)]
readLocalRootPeers :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> STM m [(Int, Map peeraddr PeerAdvertise)]
readLocalRootPeers :: STM m [(Int, Map peeraddr PeerAdvertise)]
readLocalRootPeers}
           st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState{
             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}
           } =
    Maybe (Min Time)
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded Maybe (Min Time)
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ do
      -- We have to enforce the invariant that the number of root peers is
      -- not more than the target number of known peers. It's unlikely in
      -- practice so it's ok to resolve it arbitrarily using clampToLimit.
      [(Int, Map peeraddr PeerAdvertise)]
localRootPeersRaw <- STM m [(Int, Map peeraddr PeerAdvertise)]
readLocalRootPeers
      let localRootPeers' :: LocalRootPeers peeraddr
localRootPeers' = Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Int -> LocalRootPeers peeraddr -> LocalRootPeers peeraddr
LocalRootPeers.clampToLimit
                              Int
targetNumberOfKnownPeers
                          (LocalRootPeers peeraddr -> LocalRootPeers peeraddr)
-> ([(Int, Map peeraddr PeerAdvertise)] -> LocalRootPeers peeraddr)
-> [(Int, Map peeraddr PeerAdvertise)]
-> LocalRootPeers peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Map peeraddr PeerAdvertise)] -> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
[(Int, Map peeraddr PeerAdvertise)] -> LocalRootPeers peeraddr
LocalRootPeers.fromGroups
                          ([(Int, Map peeraddr PeerAdvertise)] -> LocalRootPeers peeraddr)
-> [(Int, Map peeraddr PeerAdvertise)] -> LocalRootPeers peeraddr
forall a b. (a -> b) -> a -> b
$ [(Int, Map peeraddr PeerAdvertise)]
localRootPeersRaw
      Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (LocalRootPeers peeraddr
localRootPeers' LocalRootPeers peeraddr -> LocalRootPeers peeraddr -> Bool
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       = LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise
forall peeraddr.
LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers' Map peeraddr PeerAdvertise
-> Map peeraddr PeerAdvertise -> Map peeraddr PeerAdvertise
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\
                        LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise
forall peeraddr.
LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers
          removed :: Map peeraddr PeerAdvertise
removed     = LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise
forall peeraddr.
LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers  Map peeraddr PeerAdvertise
-> Map peeraddr PeerAdvertise -> Map peeraddr PeerAdvertise
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\
                        LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise
forall peeraddr.
LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise
LocalRootPeers.toMap LocalRootPeers peeraddr
localRootPeers'
          addedSet :: Set peeraddr
addedSet    = Map peeraddr PeerAdvertise -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerAdvertise
added
          removedSet :: Set peeraddr
removedSet  = Map peeraddr PeerAdvertise -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerAdvertise
removed
          knownPeers' :: KnownPeers peeraddr
knownPeers' = Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.insert Set peeraddr
addedSet
                        -- We do not immediately remove old ones from the
                        -- known peers set because we may have established
                        -- connections
                      (KnownPeers peeraddr -> KnownPeers peeraddr)
-> KnownPeers peeraddr -> KnownPeers peeraddr
forall a b. (a -> b) -> a -> b
$ KnownPeers peeraddr
knownPeers

          -- 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 Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\
                             LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers'

          -- 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 Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set peeraddr
removedSet
          selectedToDemote' :: Map peeraddr peerconn
selectedToDemote' = EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn
EstablishedPeers.toMap EstablishedPeers peeraddr peerconn
establishedPeers
                               Map peeraddr peerconn -> Set peeraddr -> Map peeraddr peerconn
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
selectedToDemote
      TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedDecision m peeraddr peerconn
 -> STM m (TimedDecision m peeraddr peerconn))
-> TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ \Time
_now ->

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

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