{-# 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 Ouroboros.Network.ExitPolicy (ReconnectDelay (ReconnectDelay)) import qualified Ouroboros.Network.ExitPolicy as ExitPolicy 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.waitForJob 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) -- | Monitor connections. -- connections :: forall m peeraddr peerconn. (MonadSTM m, Ord peeraddr) => PeerSelectionActions peeraddr peerconn m -> PeerSelectionPolicy peeraddr m -> PeerSelectionState peeraddr peerconn -> Guarded (STM m) (TimedDecision m peeraddr peerconn) connections :: PeerSelectionActions peeraddr peerconn m -> PeerSelectionPolicy peeraddr 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, ReconnectDelay) monitorPeerConnection :: forall peeraddr peerconn (m :: * -> *). PeerStateActions peeraddr peerconn m -> peerconn -> STM m (PeerStatus, ReconnectDelay) monitorPeerConnection :: peerconn -> STM m (PeerStatus, ReconnectDelay) monitorPeerConnection} } PeerSelectionPolicy { DiffTime policyErrorDelay :: forall peeraddr (m :: * -> *). PeerSelectionPolicy peeraddr m -> DiffTime policyErrorDelay :: DiffTime policyErrorDelay } 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, ReconnectDelay) monitorStatus <- (peerconn -> STM m (PeerStatus, ReconnectDelay)) -> Map peeraddr peerconn -> STM m (Map peeraddr (PeerStatus, ReconnectDelay)) forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse peerconn -> STM m (PeerStatus, ReconnectDelay) 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, ReconnectDelay) demotions = Map peeraddr (PeerStatus, ReconnectDelay) -> Map peeraddr (PeerStatus, ReconnectDelay) asynchronousDemotions Map peeraddr (PeerStatus, ReconnectDelay) monitorStatus Bool -> STM m () forall (m :: * -> *). MonadSTM m => Bool -> STM m () check (Bool -> Bool not (Map peeraddr (PeerStatus, ReconnectDelay) -> Bool forall k a. Map k a -> Bool Map.null Map peeraddr (PeerStatus, ReconnectDelay) demotions)) let (Map peeraddr (PeerStatus, ReconnectDelay) demotedToWarm, Map peeraddr (PeerStatus, ReconnectDelay) demotedToCold) = ((PeerStatus, ReconnectDelay) -> Bool) -> Map peeraddr (PeerStatus, ReconnectDelay) -> (Map peeraddr (PeerStatus, ReconnectDelay), Map peeraddr (PeerStatus, ReconnectDelay)) 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) (PeerStatus -> Bool) -> ((PeerStatus, ReconnectDelay) -> PeerStatus) -> (PeerStatus, ReconnectDelay) -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . (PeerStatus, ReconnectDelay) -> PeerStatus forall a b. (a, b) -> a fst) Map peeraddr (PeerStatus, ReconnectDelay) 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, ReconnectDelay) -> Set peeraddr forall k a. Map k a -> Set k Map.keysSet Map peeraddr (PeerStatus, 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' = 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 _, ReconnectDelay a) -> (Double -> DiffTime forall a b. (Real a, Fractional b) => a -> b realToFrac Double aFuzz DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a + ReconnectDelay -> DiffTime ExitPolicy.reconnectDelay ReconnectDelay a) DiffTime -> Time -> Time `addTime` Time now) ((PeerStatus, ReconnectDelay) -> Time) -> Map peeraddr (PeerStatus, ReconnectDelay) -> Map peeraddr Time forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ((PeerStatus, ReconnectDelay) -> Bool) -> Map peeraddr (PeerStatus, ReconnectDelay) -> Map peeraddr (PeerStatus, ReconnectDelay) forall a k. (a -> Bool) -> Map k a -> Map k a Map.filter (\(PeerStatus _, ReconnectDelay a) -> ReconnectDelay a ReconnectDelay -> ReconnectDelay -> Bool forall a. Eq a => a -> a -> Bool /= DiffTime -> ReconnectDelay ReconnectDelay DiffTime 0) Map peeraddr (PeerStatus, ReconnectDelay) 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, ReconnectDelay) -> Set peeraddr forall k a. Map k a -> Set k Map.keysSet Map peeraddr (PeerStatus, ReconnectDelay) 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, ReconnectDelay) -> Set peeraddr forall k a. Map k a -> Set k Map.keysSet Map peeraddr (PeerStatus, ReconnectDelay) 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 policyErrorDelay) 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, ReconnectDelay) -> Set peeraddr forall k a. Map k a -> Set k Map.keysSet Map peeraddr (PeerStatus, ReconnectDelay) demotedToCold in Bool -> Decision m peeraddr peerconn -> Decision m peeraddr peerconn forall a. (?callStack::CallStack) => Bool -> a -> a assert (Set peeraddr activePeers' Set peeraddr -> Set peeraddr -> Bool forall a. Ord a => Set a -> Set a -> Bool `Set.isSubsetOf` Map peeraddr peerconn -> Set peeraddr forall k a. Map k a -> Set k Map.keysSet (EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn forall peeraddr peerconn. EstablishedPeers peeraddr peerconn -> Map peeraddr peerconn EstablishedPeers.toMap EstablishedPeers peeraddr peerconn establishedPeers')) Decision :: 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 ((PeerStatus, ReconnectDelay) -> PeerStatus forall a b. (a, b) -> a fst ((PeerStatus, ReconnectDelay) -> PeerStatus) -> Map peeraddr (PeerStatus, ReconnectDelay) -> Map peeraddr PeerStatus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Map peeraddr (PeerStatus, ReconnectDelay) 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, ReconnectDelay) -> Set peeraddr forall k a. Map k a -> Set k Map.keysSet Map peeraddr (PeerStatus, 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, ReconnectDelay) -> Map peeraddr (PeerStatus, ReconnectDelay) asynchronousDemotions :: Map peeraddr (PeerStatus, ReconnectDelay) -> Map peeraddr (PeerStatus, ReconnectDelay) asynchronousDemotions = (peeraddr -> (PeerStatus, ReconnectDelay) -> Maybe (PeerStatus, ReconnectDelay)) -> Map peeraddr (PeerStatus, ReconnectDelay) -> Map peeraddr (PeerStatus, ReconnectDelay) forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b Map.mapMaybeWithKey peeraddr -> (PeerStatus, ReconnectDelay) -> Maybe (PeerStatus, 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, ReconnectDelay) -> Maybe (PeerStatus, 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, ReconnectDelay) -> Maybe (PeerStatus, ReconnectDelay) asyncDemotion peeraddr peeraddr (PeerStatus PeerWarm, ReconnectDelay 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, ReconnectDelay) -> Maybe (PeerStatus, ReconnectDelay) forall a. a -> Maybe a Just (PeerStatus PeerWarm, 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, ReconnectDelay 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 = (PeerStatus, ReconnectDelay) -> Maybe (PeerStatus, ReconnectDelay) forall a. a -> Maybe a Just (PeerStatus PeerCold, ReconnectDelay returnCommand) -- a hot -> cold transition has occurred if it is now cold, and it was hot asyncDemotion peeraddr peeraddr (PeerStatus PeerCold, ReconnectDelay 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, ReconnectDelay) -> Maybe (PeerStatus, ReconnectDelay) forall a. a -> Maybe a Just (PeerStatus PeerCold, ReconnectDelay returnCommand) asyncDemotion peeraddr _ (PeerStatus, ReconnectDelay) _ = Maybe (PeerStatus, 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 :: 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 [(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} PeerSelectionPolicy peeraddr m policy 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 KnownPeers peeraddr knownPeers -- We do not immediately remove old ones from the -- known peers set because we may have established -- connections -- 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 -> PeerSelectionPolicy peeraddr m -> peeraddr -> peerconn -> Job () m (Completion m peeraddr peerconn) 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) <- Map peeraddr peerconn -> [(peeraddr, peerconn)] forall k a. Map k a -> [(k, a)] Map.assocs Map peeraddr peerconn selectedToDemote' ] }