{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ < 904 {-# OPTIONS_GHC -Wno-name-shadowing #-} #endif -- | This subsystem manages the discovery and selection of /upstream/ peers. -- module Ouroboros.Network.PeerSelection.Churn ( peerChurnGovernor , ChurnCounters (..) ) where import Data.Void (Void) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer (..), traceWith) import System.Random import Control.Applicative (Alternative) import Data.Functor (($>)) import Data.Monoid.Synchronisation (FirstToFinish (..)) import Ouroboros.Network.BlockFetch (FetchMode (..)) import Ouroboros.Network.Diffusion.Policies (churnEstablishConnectionTimeout, closeConnectionTimeout, deactivateTimeout) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) import Ouroboros.Network.PeerSelection.Governor.Types hiding (targets) import Ouroboros.Network.PeerSelection.PeerMetric import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..)) type ModifyPeerSelectionTargets = PeerSelectionTargets -> PeerSelectionTargets type CheckPeerSelectionCounters = PeerSelectionCounters -> PeerSelectionTargets -> Bool data ChurnCounters = ChurnCounter ChurnAction Int -- | Churn governor. -- -- At every churn interval decrease active peers for a short while (1s), so that -- we can pick new ones. Then we churn non-active peers. -- -- On startup the churn governor gives a head start to local root peers over -- root peers. -- peerChurnGovernor :: forall m peeraddr. ( MonadDelay m , Alternative (STM m) , MonadTimer m , MonadCatch m ) => Tracer m (TracePeerSelection peeraddr) -> Tracer m ChurnCounters -> DiffTime -- ^ the base for churn interval in the deadline mode. -> DiffTime -- ^ the base for churn interval in the bulk sync mode. -> DiffTime -- ^ the timeout for outbound governor to find new (thus -- cold) peers through peer sharing mechanism. -> PeerMetrics m peeraddr -> StrictTVar m ChurnMode -> StdGen -> STM m FetchMode -> PeerSelectionTargets -- ^ base targets; set in a configuration file -> StrictTVar m PeerSelectionTargets -> STM m PeerSelectionCounters -> STM m UseBootstrapPeers -> STM m HotValency -> m Void peerChurnGovernor :: forall (m :: * -> *) peeraddr. (MonadDelay m, Alternative (STM m), MonadTimer m, MonadCatch m) => Tracer m (TracePeerSelection peeraddr) -> Tracer m ChurnCounters -> DiffTime -> DiffTime -> DiffTime -> PeerMetrics m peeraddr -> StrictTVar m ChurnMode -> StdGen -> STM m FetchMode -> PeerSelectionTargets -> StrictTVar m PeerSelectionTargets -> STM m PeerSelectionCounters -> STM m UseBootstrapPeers -> STM m HotValency -> m Void peerChurnGovernor Tracer m (TracePeerSelection peeraddr) tracer Tracer m ChurnCounters churnTracer DiffTime deadlineChurnInterval DiffTime bulkChurnInterval DiffTime requestPeersTimeout PeerMetrics m peeraddr _metrics StrictTVar m ChurnMode churnModeVar StdGen inRng STM m FetchMode getFetchMode PeerSelectionTargets base StrictTVar m PeerSelectionTargets peerSelectionVar STM m PeerSelectionCounters readCounters STM m UseBootstrapPeers getUseBootstrapPeers STM m HotValency getLocalRootHotTarget = do -- Wait a while so that not only the closest peers have had the time -- to become warm. Time startTs0 <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime -- TODO: revisit the policy once we have local root peers in the governor. -- The intention is to give local root peers give head start and avoid -- giving advantage to hostile and quick root peers. DiffTime -> m () forall (m :: * -> *). MonadDelay m => DiffTime -> m () threadDelay DiffTime 3 (ChurnMode mode, UseBootstrapPeers ubp, HotValency ltt) <- STM m (ChurnMode, UseBootstrapPeers, HotValency) -> m (ChurnMode, UseBootstrapPeers, HotValency) forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically STM m (ChurnMode, UseBootstrapPeers, HotValency) getExtState Tracer m (TracePeerSelection peeraddr) -> TracePeerSelection peeraddr -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TracePeerSelection peeraddr) tracer (TracePeerSelection peeraddr -> m ()) -> TracePeerSelection peeraddr -> m () forall a b. (a -> b) -> a -> b $ ChurnMode -> TracePeerSelection peeraddr forall peeraddr. ChurnMode -> TracePeerSelection peeraddr TraceChurnMode ChurnMode mode STM m () -> m () forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ do StrictTVar m PeerSelectionTargets -> (PeerSelectionTargets -> PeerSelectionTargets) -> STM m () forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> (a -> a) -> STM m () modifyTVar StrictTVar m PeerSelectionTargets peerSelectionVar ( ChurnMode -> HotValency -> PeerSelectionTargets -> PeerSelectionTargets increaseActivePeers ChurnMode mode HotValency ltt (PeerSelectionTargets -> PeerSelectionTargets) -> (PeerSelectionTargets -> PeerSelectionTargets) -> PeerSelectionTargets -> PeerSelectionTargets forall b c a. (b -> c) -> (a -> b) -> a -> c . ChurnMode -> UseBootstrapPeers -> PeerSelectionTargets -> PeerSelectionTargets increaseEstablishedPeers ChurnMode mode UseBootstrapPeers ubp ) Time endTs0 <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime StdGen -> DiffTime -> m StdGen fuzzyDelay StdGen inRng (Time endTs0 Time -> Time -> DiffTime `diffTime` Time startTs0) m StdGen -> (StdGen -> m Void) -> m Void forall a b. m a -> (a -> m b) -> m b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= StdGen -> m Void churnLoop where getExtState :: STM m (ChurnMode, UseBootstrapPeers, HotValency) getExtState :: STM m (ChurnMode, UseBootstrapPeers, HotValency) getExtState = do ChurnMode cm <- STM m ChurnMode updateChurnMode UseBootstrapPeers bp <- STM m UseBootstrapPeers getUseBootstrapPeers HotValency ltt <- STM m HotValency getLocalRootHotTarget (ChurnMode, UseBootstrapPeers, HotValency) -> STM m (ChurnMode, UseBootstrapPeers, HotValency) forall a. a -> STM m a forall (m :: * -> *) a. Monad m => a -> m a return (ChurnMode cm, UseBootstrapPeers bp, HotValency ltt) updateChurnMode :: STM m ChurnMode updateChurnMode :: STM m ChurnMode updateChurnMode = do FetchMode fm <- STM m FetchMode getFetchMode let mode :: ChurnMode mode = case FetchMode fm of FetchMode FetchModeDeadline -> ChurnMode ChurnModeNormal FetchMode FetchModeBulkSync -> ChurnMode ChurnModeBulkSync StrictTVar m ChurnMode -> ChurnMode -> STM m () forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> a -> STM m () writeTVar StrictTVar m ChurnMode churnModeVar ChurnMode mode ChurnMode -> STM m ChurnMode forall a. a -> STM m a forall (m :: * -> *) a. Monad m => a -> m a return ChurnMode mode -- | Update the targets to a given value, and block until they are reached. -- The time we are blocked is limited by a timeout. -- updateTargets :: ChurnAction -- ^ churn actions for tracing -> (PeerSelectionCounters -> Int) -- ^ counter getter -> DiffTime -- ^ timeout -> ModifyPeerSelectionTargets -- ^ update counters function -> CheckPeerSelectionCounters -- ^ check counters -> m () updateTargets :: ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction churnAction PeerSelectionCounters -> Int getCounter DiffTime timeoutDelay PeerSelectionTargets -> PeerSelectionTargets modifyTargets CheckPeerSelectionCounters checkCounters = do -- update targets, and return the new targets Time startTime <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime (Int c, PeerSelectionTargets targets) <- STM m (Int, PeerSelectionTargets) -> m (Int, PeerSelectionTargets) forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (Int, PeerSelectionTargets) -> m (Int, PeerSelectionTargets)) -> STM m (Int, PeerSelectionTargets) -> m (Int, PeerSelectionTargets) forall a b. (a -> b) -> a -> b $ (,) (Int -> PeerSelectionTargets -> (Int, PeerSelectionTargets)) -> STM m Int -> STM m (PeerSelectionTargets -> (Int, PeerSelectionTargets)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (PeerSelectionCounters -> Int getCounter (PeerSelectionCounters -> Int) -> STM m PeerSelectionCounters -> STM m Int forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> STM m PeerSelectionCounters readCounters) STM m (PeerSelectionTargets -> (Int, PeerSelectionTargets)) -> STM m PeerSelectionTargets -> STM m (Int, PeerSelectionTargets) forall a b. STM m (a -> b) -> STM m a -> STM m b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> StrictTVar m PeerSelectionTargets -> (PeerSelectionTargets -> (PeerSelectionTargets, PeerSelectionTargets)) -> STM m PeerSelectionTargets forall (m :: * -> *) s a. MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a stateTVar StrictTVar m PeerSelectionTargets peerSelectionVar ((\PeerSelectionTargets a -> (PeerSelectionTargets a, PeerSelectionTargets a)) (PeerSelectionTargets -> (PeerSelectionTargets, PeerSelectionTargets)) -> (PeerSelectionTargets -> PeerSelectionTargets) -> PeerSelectionTargets -> (PeerSelectionTargets, PeerSelectionTargets) forall b c a. (b -> c) -> (a -> b) -> a -> c . PeerSelectionTargets -> PeerSelectionTargets modifyTargets) -- create timeout and block on counters m (STM m TimeoutState, m ()) -> ((STM m TimeoutState, m ()) -> m ()) -> ((STM m TimeoutState, m ()) -> m ()) -> m () forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c forall (m :: * -> *) a b c. MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c bracketOnError (DiffTime -> m (STM m TimeoutState, m ()) forall (m :: * -> *). MonadTimer m => DiffTime -> m (STM m TimeoutState, m ()) registerDelayCancellable DiffTime timeoutDelay) (\(STM m TimeoutState _readTimeout, m () cancelTimeout) -> m () cancelTimeout) (\( STM m TimeoutState readTimeout, m () cancelTimeout) -> do -- block until counters reached the targets, or the timeout fires Either Int Int a <- STM m (Either Int Int) -> m (Either Int Int) forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (Either Int Int) -> m (Either Int Int)) -> STM m (Either Int Int) -> m (Either Int Int) forall a b. (a -> b) -> a -> b $ do PeerSelectionCounters counters <- STM m PeerSelectionCounters readCounters FirstToFinish (STM m) (Either Int Int) -> STM m (Either Int Int) forall (m :: * -> *) a. FirstToFinish m a -> m a runFirstToFinish (FirstToFinish (STM m) (Either Int Int) -> STM m (Either Int Int)) -> FirstToFinish (STM m) (Either Int Int) -> STM m (Either Int Int) forall a b. (a -> b) -> a -> b $ STM m (Either Int Int) -> FirstToFinish (STM m) (Either Int Int) forall (m :: * -> *) a. m a -> FirstToFinish m a FirstToFinish (Bool -> STM m () forall (m :: * -> *). MonadSTM m => Bool -> STM m () check (CheckPeerSelectionCounters checkCounters PeerSelectionCounters counters PeerSelectionTargets targets) STM m () -> Either Int Int -> STM m (Either Int Int) forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> (Int -> Either Int Int forall a b. b -> Either a b Right (Int -> Either Int Int) -> Int -> Either Int Int forall a b. (a -> b) -> a -> b $ PeerSelectionCounters -> Int getCounter PeerSelectionCounters counters )) FirstToFinish (STM m) (Either Int Int) -> FirstToFinish (STM m) (Either Int Int) -> FirstToFinish (STM m) (Either Int Int) forall a. Semigroup a => a -> a -> a <> STM m (Either Int Int) -> FirstToFinish (STM m) (Either Int Int) forall (m :: * -> *) a. m a -> FirstToFinish m a FirstToFinish (STM m TimeoutState readTimeout STM m TimeoutState -> (TimeoutState -> STM m (Either Int Int)) -> STM m (Either Int Int) forall a b. STM m a -> (a -> STM m b) -> STM m b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case TimeoutState TimeoutPending -> STM m (Either Int Int) forall a. STM m a forall (m :: * -> *) a. MonadSTM m => STM m a retry TimeoutState _ -> Either Int Int -> STM m (Either Int Int) forall a. a -> STM m a forall (f :: * -> *) a. Applicative f => a -> f a pure (Int -> Either Int Int forall a b. a -> Either a b Left (Int -> Either Int Int) -> Int -> Either Int Int forall a b. (a -> b) -> a -> b $ PeerSelectionCounters -> Int getCounter PeerSelectionCounters counters)) case Either Int Int a of Right Int c' -> do let r :: Int r = Int c' Int -> Int -> Int forall a. Num a => a -> a -> a - Int c Time endTime <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime Tracer m (TracePeerSelection peeraddr) -> TracePeerSelection peeraddr -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TracePeerSelection peeraddr) tracer (DiffTime -> ChurnAction -> Int -> TracePeerSelection peeraddr forall peeraddr. DiffTime -> ChurnAction -> Int -> TracePeerSelection peeraddr TraceChurnAction (Time endTime Time -> Time -> DiffTime `diffTime` Time startTime) ChurnAction churnAction Int r) Tracer m ChurnCounters -> ChurnCounters -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m ChurnCounters churnTracer (ChurnAction -> Int -> ChurnCounters ChurnCounter ChurnAction churnAction Int r) Left Int c' -> do Time endTime <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime m () cancelTimeout let r :: Int r = Int c' Int -> Int -> Int forall a. Num a => a -> a -> a - Int c Tracer m (TracePeerSelection peeraddr) -> TracePeerSelection peeraddr -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TracePeerSelection peeraddr) tracer (DiffTime -> ChurnAction -> Int -> TracePeerSelection peeraddr forall peeraddr. DiffTime -> ChurnAction -> Int -> TracePeerSelection peeraddr TraceChurnTimeout (Time endTime Time -> Time -> DiffTime `diffTime` Time startTime) ChurnAction churnAction Int r) Tracer m ChurnCounters -> ChurnCounters -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m ChurnCounters churnTracer (ChurnAction -> Int -> ChurnCounters ChurnCounter ChurnAction churnAction Int r) ) -- -- Functions to modify `PeerSelectionTargets` and check -- `PeerSelectionCounters`. -- -- TODO: #3396 revisit the policy for genesis increaseActivePeers :: ChurnMode -> HotValency -> ModifyPeerSelectionTargets increaseActivePeers :: ChurnMode -> HotValency -> PeerSelectionTargets -> PeerSelectionTargets increaseActivePeers ChurnMode mode (HotValency Int ltt) PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfActivePeers = case mode of ChurnMode ChurnModeNormal -> PeerSelectionTargets -> Int targetNumberOfActivePeers PeerSelectionTargets base ChurnMode ChurnModeBulkSync -> Int -> Int -> Int forall a. Ord a => a -> a -> a min ((Int -> Int -> Int forall a. Ord a => a -> a -> a max Int 1 Int ltt) Int -> Int -> Int forall a. Num a => a -> a -> a + Int 1) (PeerSelectionTargets -> Int targetNumberOfActivePeers PeerSelectionTargets base) } checkActivePeersIncreased :: CheckPeerSelectionCounters checkActivePeersIncreased :: CheckPeerSelectionCounters checkActivePeersIncreased PeerSelectionCounters { Int numberOfActivePeers :: Int numberOfActivePeers :: PeerSelectionCounters -> Int numberOfActivePeers } PeerSelectionTargets { Int targetNumberOfActivePeers :: PeerSelectionTargets -> Int targetNumberOfActivePeers :: Int targetNumberOfActivePeers } = Int numberOfActivePeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int targetNumberOfActivePeers decreaseActivePeers :: ChurnMode -> HotValency -> ModifyPeerSelectionTargets decreaseActivePeers :: ChurnMode -> HotValency -> PeerSelectionTargets -> PeerSelectionTargets decreaseActivePeers ChurnMode mode (HotValency Int ltt) PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfActivePeers = case mode of ChurnMode ChurnModeNormal -> Int -> Int decrease (Int -> Int) -> Int -> Int forall a b. (a -> b) -> a -> b $ PeerSelectionTargets -> Int targetNumberOfActivePeers PeerSelectionTargets base ChurnMode ChurnModeBulkSync -> Int -> Int -> Int forall a. Ord a => a -> a -> a min (Int -> Int -> Int forall a. Ord a => a -> a -> a max Int 1 Int ltt) (PeerSelectionTargets -> Int targetNumberOfActivePeers PeerSelectionTargets base Int -> Int -> Int forall a. Num a => a -> a -> a - Int 1) } checkActivePeersDecreased :: CheckPeerSelectionCounters checkActivePeersDecreased :: CheckPeerSelectionCounters checkActivePeersDecreased PeerSelectionCounters { Int numberOfActivePeers :: PeerSelectionCounters -> Int numberOfActivePeers :: Int numberOfActivePeers } PeerSelectionTargets { Int targetNumberOfActivePeers :: PeerSelectionTargets -> Int targetNumberOfActivePeers :: Int targetNumberOfActivePeers } = Int numberOfActivePeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfActivePeers increaseEstablishedPeers :: ChurnMode -> UseBootstrapPeers -> ModifyPeerSelectionTargets increaseEstablishedPeers :: ChurnMode -> UseBootstrapPeers -> PeerSelectionTargets -> PeerSelectionTargets increaseEstablishedPeers ChurnMode mode UseBootstrapPeers ubp PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfEstablishedPeers = case (mode, ubp) of (ChurnMode ChurnModeBulkSync, UseBootstrapPeers [RelayAccessPoint] _) -> Int -> Int -> Int forall a. Ord a => a -> a -> a min (PeerSelectionTargets -> Int targetNumberOfActivePeers PeerSelectionTargets targets Int -> Int -> Int forall a. Num a => a -> a -> a + Int 1) (PeerSelectionTargets -> Int targetNumberOfEstablishedPeers PeerSelectionTargets base) (ChurnMode, UseBootstrapPeers) _ -> PeerSelectionTargets -> Int targetNumberOfEstablishedPeers PeerSelectionTargets base } checkEstablishedPeersIncreased :: CheckPeerSelectionCounters checkEstablishedPeersIncreased :: CheckPeerSelectionCounters checkEstablishedPeersIncreased PeerSelectionCounters { Int numberOfEstablishedPeers :: Int numberOfEstablishedPeers :: PeerSelectionCounters -> Int numberOfEstablishedPeers } PeerSelectionTargets { Int targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int targetNumberOfEstablishedPeers :: Int targetNumberOfEstablishedPeers } = Int numberOfEstablishedPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int targetNumberOfEstablishedPeers increaseEstablishedBigLedgerPeers :: ModifyPeerSelectionTargets increaseEstablishedBigLedgerPeers :: PeerSelectionTargets -> PeerSelectionTargets increaseEstablishedBigLedgerPeers PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfEstablishedBigLedgerPeers = targetNumberOfEstablishedBigLedgerPeers base } checkEstablishedBigLedgerPeersIncreased :: CheckPeerSelectionCounters checkEstablishedBigLedgerPeersIncreased :: CheckPeerSelectionCounters checkEstablishedBigLedgerPeersIncreased PeerSelectionCounters { Int numberOfEstablishedBigLedgerPeers :: Int numberOfEstablishedBigLedgerPeers :: PeerSelectionCounters -> Int numberOfEstablishedBigLedgerPeers } PeerSelectionTargets { Int targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int targetNumberOfEstablishedBigLedgerPeers :: Int targetNumberOfEstablishedBigLedgerPeers } = Int numberOfEstablishedBigLedgerPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int targetNumberOfEstablishedBigLedgerPeers decreaseEstablishedPeers :: ChurnMode -> UseBootstrapPeers -> ModifyPeerSelectionTargets decreaseEstablishedPeers :: ChurnMode -> UseBootstrapPeers -> PeerSelectionTargets -> PeerSelectionTargets decreaseEstablishedPeers ChurnMode mode UseBootstrapPeers ubp PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfEstablishedPeers = case (mode, ubp) of (ChurnMode ChurnModeBulkSync, UseBootstrapPeers [RelayAccessPoint] _) -> Int -> Int -> Int forall a. Ord a => a -> a -> a min (PeerSelectionTargets -> Int targetNumberOfActivePeers PeerSelectionTargets targets) (PeerSelectionTargets -> Int targetNumberOfEstablishedPeers PeerSelectionTargets base Int -> Int -> Int forall a. Num a => a -> a -> a - Int 1) (ChurnMode, UseBootstrapPeers) _ -> Int -> Int decrease (PeerSelectionTargets -> Int targetNumberOfEstablishedPeers PeerSelectionTargets base Int -> Int -> Int forall a. Num a => a -> a -> a - PeerSelectionTargets -> Int targetNumberOfActivePeers PeerSelectionTargets base) Int -> Int -> Int forall a. Num a => a -> a -> a + PeerSelectionTargets -> Int targetNumberOfActivePeers PeerSelectionTargets base } checkEstablishedPeersDecreased :: CheckPeerSelectionCounters checkEstablishedPeersDecreased :: CheckPeerSelectionCounters checkEstablishedPeersDecreased PeerSelectionCounters { Int numberOfEstablishedPeers :: PeerSelectionCounters -> Int numberOfEstablishedPeers :: Int numberOfEstablishedPeers } PeerSelectionTargets { Int targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int targetNumberOfEstablishedPeers :: Int targetNumberOfEstablishedPeers } = Int numberOfEstablishedPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfEstablishedPeers increaseActiveBigLedgerPeers :: ChurnMode -> ModifyPeerSelectionTargets increaseActiveBigLedgerPeers :: ChurnMode -> PeerSelectionTargets -> PeerSelectionTargets increaseActiveBigLedgerPeers ChurnMode mode PeerSelectionTargets targets = PeerSelectionTargets targets { -- TODO: when chain-skipping will be implemented and chain-sync client -- will take into account big ledger peers, we don't need pattern -- match on the churn mode, but use -- `targetNumberOfActiveBigLedgerPeers` (issue #4609). targetNumberOfActiveBigLedgerPeers = case mode of ChurnMode ChurnModeNormal -> PeerSelectionTargets -> Int targetNumberOfActiveBigLedgerPeers PeerSelectionTargets base ChurnMode ChurnModeBulkSync -> Int -> Int -> Int forall a. Ord a => a -> a -> a min Int 1 (PeerSelectionTargets -> Int targetNumberOfActiveBigLedgerPeers PeerSelectionTargets base) } checkActiveBigLedgerPeersIncreased :: CheckPeerSelectionCounters checkActiveBigLedgerPeersIncreased :: CheckPeerSelectionCounters checkActiveBigLedgerPeersIncreased PeerSelectionCounters { Int numberOfActiveBigLedgerPeers :: Int numberOfActiveBigLedgerPeers :: PeerSelectionCounters -> Int numberOfActiveBigLedgerPeers } PeerSelectionTargets { Int targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int targetNumberOfActiveBigLedgerPeers :: Int targetNumberOfActiveBigLedgerPeers } = Int numberOfActiveBigLedgerPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int targetNumberOfActiveBigLedgerPeers decreaseActiveBigLedgerPeers :: ChurnMode -> ModifyPeerSelectionTargets decreaseActiveBigLedgerPeers :: ChurnMode -> PeerSelectionTargets -> PeerSelectionTargets decreaseActiveBigLedgerPeers ChurnMode mode PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfActiveBigLedgerPeers = case mode of ChurnMode ChurnModeNormal -> Int -> Int decrease (Int -> Int) -> Int -> Int forall a b. (a -> b) -> a -> b $ PeerSelectionTargets -> Int targetNumberOfActiveBigLedgerPeers PeerSelectionTargets base ChurnMode ChurnModeBulkSync -> Int -> Int -> Int forall a. Ord a => a -> a -> a min Int 1 (PeerSelectionTargets -> Int targetNumberOfActiveBigLedgerPeers PeerSelectionTargets base) } checkActiveBigLedgerPeersDecreased :: CheckPeerSelectionCounters checkActiveBigLedgerPeersDecreased :: CheckPeerSelectionCounters checkActiveBigLedgerPeersDecreased PeerSelectionCounters { Int numberOfActiveBigLedgerPeers :: PeerSelectionCounters -> Int numberOfActiveBigLedgerPeers :: Int numberOfActiveBigLedgerPeers } PeerSelectionTargets { Int targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int targetNumberOfActiveBigLedgerPeers :: Int targetNumberOfActiveBigLedgerPeers } = Int numberOfActiveBigLedgerPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfActiveBigLedgerPeers decreaseEstablishedBigLedgerPeers :: ModifyPeerSelectionTargets decreaseEstablishedBigLedgerPeers :: PeerSelectionTargets -> PeerSelectionTargets decreaseEstablishedBigLedgerPeers PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfEstablishedBigLedgerPeers = decrease (targetNumberOfEstablishedBigLedgerPeers base - targetNumberOfActiveBigLedgerPeers base) + targetNumberOfActiveBigLedgerPeers base } checkEstablishedBigLedgerPeersDecreased :: CheckPeerSelectionCounters checkEstablishedBigLedgerPeersDecreased :: CheckPeerSelectionCounters checkEstablishedBigLedgerPeersDecreased PeerSelectionCounters { Int numberOfEstablishedBigLedgerPeers :: PeerSelectionCounters -> Int numberOfEstablishedBigLedgerPeers :: Int numberOfEstablishedBigLedgerPeers } PeerSelectionTargets { Int targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int targetNumberOfEstablishedBigLedgerPeers :: Int targetNumberOfEstablishedBigLedgerPeers } = Int numberOfEstablishedBigLedgerPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfEstablishedBigLedgerPeers decreaseKnownPeers :: ModifyPeerSelectionTargets decreaseKnownPeers :: PeerSelectionTargets -> PeerSelectionTargets decreaseKnownPeers PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfRootPeers = decrease (targetNumberOfRootPeers base - targetNumberOfEstablishedPeers base) + targetNumberOfEstablishedPeers base , targetNumberOfKnownPeers = decrease (targetNumberOfKnownPeers base - targetNumberOfEstablishedPeers base) + targetNumberOfEstablishedPeers base } checkKnownPeersDecreased :: PeerSelectionCounters -> PeerSelectionTargets -> Bool checkKnownPeersDecreased :: CheckPeerSelectionCounters checkKnownPeersDecreased PeerSelectionCounters { Int numberOfKnownPeers :: Int numberOfKnownPeers :: PeerSelectionCounters -> Int numberOfKnownPeers } PeerSelectionTargets { Int targetNumberOfKnownPeers :: PeerSelectionTargets -> Int targetNumberOfKnownPeers :: Int targetNumberOfKnownPeers } = -- note: we are not checking target root peers, since it is a one-sided -- target Int numberOfKnownPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfKnownPeers decreaseKnownBigLedgerPeers :: ModifyPeerSelectionTargets decreaseKnownBigLedgerPeers :: PeerSelectionTargets -> PeerSelectionTargets decreaseKnownBigLedgerPeers PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfKnownBigLedgerPeers = decrease (targetNumberOfKnownBigLedgerPeers base - targetNumberOfEstablishedBigLedgerPeers base) + targetNumberOfEstablishedBigLedgerPeers base } checkKnownBigLedgerPeersDecreased :: PeerSelectionCounters -> PeerSelectionTargets -> Bool checkKnownBigLedgerPeersDecreased :: CheckPeerSelectionCounters checkKnownBigLedgerPeersDecreased PeerSelectionCounters { Int numberOfKnownBigLedgerPeers :: Int numberOfKnownBigLedgerPeers :: PeerSelectionCounters -> Int numberOfKnownBigLedgerPeers } PeerSelectionTargets { Int targetNumberOfKnownBigLedgerPeers :: PeerSelectionTargets -> Int targetNumberOfKnownBigLedgerPeers :: Int targetNumberOfKnownBigLedgerPeers } = Int numberOfKnownBigLedgerPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfKnownBigLedgerPeers increaseKnownPeers :: ModifyPeerSelectionTargets increaseKnownPeers :: PeerSelectionTargets -> PeerSelectionTargets increaseKnownPeers PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfRootPeers = targetNumberOfRootPeers base , targetNumberOfKnownPeers = targetNumberOfKnownPeers base } checkKnownPeersIncreased :: CheckPeerSelectionCounters checkKnownPeersIncreased :: CheckPeerSelectionCounters checkKnownPeersIncreased PeerSelectionCounters { Int numberOfRootPeers :: Int numberOfRootPeers :: PeerSelectionCounters -> Int numberOfRootPeers, Int numberOfKnownPeers :: PeerSelectionCounters -> Int numberOfKnownPeers :: Int numberOfKnownPeers } PeerSelectionTargets { Int targetNumberOfRootPeers :: PeerSelectionTargets -> Int targetNumberOfRootPeers :: Int targetNumberOfRootPeers, Int targetNumberOfKnownPeers :: PeerSelectionTargets -> Int targetNumberOfKnownPeers :: Int targetNumberOfKnownPeers } = Int numberOfRootPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int targetNumberOfRootPeers Bool -> Bool -> Bool && Int numberOfKnownPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int targetNumberOfKnownPeers increaseKnownBigLedgerPeers :: ModifyPeerSelectionTargets increaseKnownBigLedgerPeers :: PeerSelectionTargets -> PeerSelectionTargets increaseKnownBigLedgerPeers PeerSelectionTargets targets = PeerSelectionTargets targets { targetNumberOfKnownBigLedgerPeers = targetNumberOfKnownBigLedgerPeers base } checkKnownBigLedgerPeersIncreased :: CheckPeerSelectionCounters checkKnownBigLedgerPeersIncreased :: CheckPeerSelectionCounters checkKnownBigLedgerPeersIncreased PeerSelectionCounters { Int numberOfKnownBigLedgerPeers :: PeerSelectionCounters -> Int numberOfKnownBigLedgerPeers :: Int numberOfKnownBigLedgerPeers } PeerSelectionTargets { Int targetNumberOfKnownBigLedgerPeers :: PeerSelectionTargets -> Int targetNumberOfKnownBigLedgerPeers :: Int targetNumberOfKnownBigLedgerPeers } = Int numberOfKnownBigLedgerPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int targetNumberOfKnownBigLedgerPeers -- -- Main loop -- churnLoop :: StdGen -> m Void churnLoop :: StdGen -> m Void churnLoop !StdGen rng = do Time startTs <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime (ChurnMode churnMode, UseBootstrapPeers ubp, HotValency ltt) <- STM m (ChurnMode, UseBootstrapPeers, HotValency) -> m (ChurnMode, UseBootstrapPeers, HotValency) forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically STM m (ChurnMode, UseBootstrapPeers, HotValency) getExtState Tracer m (TracePeerSelection peeraddr) -> TracePeerSelection peeraddr -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TracePeerSelection peeraddr) tracer (TracePeerSelection peeraddr -> m ()) -> TracePeerSelection peeraddr -> m () forall a b. (a -> b) -> a -> b $ ChurnMode -> TracePeerSelection peeraddr forall peeraddr. ChurnMode -> TracePeerSelection peeraddr TraceChurnMode ChurnMode churnMode -- Purge the worst active peers. ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction DecreasedActivePeers PeerSelectionCounters -> Int numberOfActivePeers DiffTime deactivateTimeout -- chainsync might timeout after 5mins (ChurnMode -> HotValency -> PeerSelectionTargets -> PeerSelectionTargets decreaseActivePeers ChurnMode churnMode HotValency ltt) CheckPeerSelectionCounters checkActivePeersDecreased -- Pick new active peers. ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction IncreasedActivePeers PeerSelectionCounters -> Int numberOfActivePeers DiffTime shortTimeout (ChurnMode -> HotValency -> PeerSelectionTargets -> PeerSelectionTargets increaseActivePeers ChurnMode churnMode HotValency ltt) CheckPeerSelectionCounters checkActivePeersIncreased -- Purge the worst active big ledger peers. ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction DecreasedActiveBigLedgerPeers PeerSelectionCounters -> Int numberOfActiveBigLedgerPeers DiffTime deactivateTimeout -- chainsync might timeout after 5mins (ChurnMode -> PeerSelectionTargets -> PeerSelectionTargets decreaseActiveBigLedgerPeers ChurnMode churnMode) (CheckPeerSelectionCounters checkActiveBigLedgerPeersDecreased) -- Pick new active big ledger peers. ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction IncreasedActiveBigLedgerPeers PeerSelectionCounters -> Int numberOfActiveBigLedgerPeers DiffTime shortTimeout (ChurnMode -> PeerSelectionTargets -> PeerSelectionTargets increaseActiveBigLedgerPeers ChurnMode churnMode) CheckPeerSelectionCounters checkActiveBigLedgerPeersIncreased -- Forget the worst performing established peers. ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction DecreasedEstablishedPeers PeerSelectionCounters -> Int numberOfEstablishedPeers (DiffTime 1 DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a + DiffTime closeConnectionTimeout) (ChurnMode -> UseBootstrapPeers -> PeerSelectionTargets -> PeerSelectionTargets decreaseEstablishedPeers ChurnMode churnMode UseBootstrapPeers ubp) (CheckPeerSelectionCounters checkEstablishedPeersDecreased) -- Forget the worst performing established big ledger peers. ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction DecreasedEstablishedBigLedgerPeers PeerSelectionCounters -> Int numberOfEstablishedBigLedgerPeers (DiffTime 1 DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a + DiffTime closeConnectionTimeout) PeerSelectionTargets -> PeerSelectionTargets decreaseEstablishedBigLedgerPeers CheckPeerSelectionCounters checkEstablishedBigLedgerPeersDecreased -- Forget the worst performing known peers (root peers, ledger peers) ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction DecreasedKnownPeers PeerSelectionCounters -> Int numberOfKnownPeers DiffTime shortTimeout PeerSelectionTargets -> PeerSelectionTargets decreaseKnownPeers CheckPeerSelectionCounters checkKnownPeersDecreased -- Pick new known peers ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction IncreasedKnownPeers PeerSelectionCounters -> Int numberOfKnownPeers (DiffTime 2 DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a * DiffTime requestPeersTimeout DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a + DiffTime shortTimeout) PeerSelectionTargets -> PeerSelectionTargets increaseKnownPeers CheckPeerSelectionCounters checkKnownPeersIncreased -- Forget the worst performing known big ledger peers. ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction DecreasedKnownBigLedgerPeers PeerSelectionCounters -> Int numberOfKnownBigLedgerPeers DiffTime shortTimeout PeerSelectionTargets -> PeerSelectionTargets decreaseKnownBigLedgerPeers CheckPeerSelectionCounters checkKnownBigLedgerPeersDecreased -- Pick new known big ledger peers ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction IncreasedKnownBigLedgerPeers PeerSelectionCounters -> Int numberOfKnownBigLedgerPeers (DiffTime 2 DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a * DiffTime requestPeersTimeout DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a + DiffTime shortTimeout) PeerSelectionTargets -> PeerSelectionTargets increaseKnownBigLedgerPeers CheckPeerSelectionCounters checkKnownBigLedgerPeersIncreased -- Pick new non-active peers ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction IncreasedEstablishedPeers PeerSelectionCounters -> Int numberOfEstablishedPeers DiffTime churnEstablishConnectionTimeout (ChurnMode -> UseBootstrapPeers -> PeerSelectionTargets -> PeerSelectionTargets increaseEstablishedPeers ChurnMode churnMode UseBootstrapPeers ubp) CheckPeerSelectionCounters checkEstablishedPeersIncreased -- Pick new non-active big ledger peers ChurnAction -> (PeerSelectionCounters -> Int) -> DiffTime -> (PeerSelectionTargets -> PeerSelectionTargets) -> CheckPeerSelectionCounters -> m () updateTargets ChurnAction IncreasedEstablishedBigLedgerPeers PeerSelectionCounters -> Int numberOfEstablishedBigLedgerPeers DiffTime churnEstablishConnectionTimeout PeerSelectionTargets -> PeerSelectionTargets increaseEstablishedBigLedgerPeers CheckPeerSelectionCounters checkEstablishedBigLedgerPeersIncreased Time endTs <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime StdGen -> DiffTime -> m StdGen fuzzyDelay StdGen rng (Time endTs Time -> Time -> DiffTime `diffTime` Time startTs) m StdGen -> (StdGen -> m Void) -> m Void forall a b. m a -> (a -> m b) -> m b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= StdGen -> m Void churnLoop -- -- Auxiliary functions and constants -- -- Randomly delay between churnInterval and churnInterval + maxFuzz seconds. fuzzyDelay :: StdGen -> DiffTime -> m StdGen fuzzyDelay :: StdGen -> DiffTime -> m StdGen fuzzyDelay StdGen rng DiffTime execTime = do FetchMode mode <- STM m FetchMode -> m FetchMode forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically STM m FetchMode getFetchMode case FetchMode mode of FetchMode FetchModeDeadline -> StdGen -> DiffTime -> m StdGen longDelay StdGen rng DiffTime execTime FetchMode FetchModeBulkSync -> StdGen -> DiffTime -> m StdGen shortDelay StdGen rng DiffTime execTime fuzzyDelay' :: DiffTime -> Double -> StdGen -> DiffTime -> m StdGen fuzzyDelay' :: DiffTime -> Double -> StdGen -> DiffTime -> m StdGen fuzzyDelay' DiffTime baseDelay Double maxFuzz StdGen rng DiffTime execTime = do let (Double fuzz, StdGen rng') = (Double, Double) -> StdGen -> (Double, StdGen) forall g. RandomGen g => (Double, Double) -> g -> (Double, g) forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g) randomR (Double 0, Double maxFuzz) StdGen rng delay :: DiffTime delay = Double -> DiffTime forall a b. (Real a, Fractional b) => a -> b realToFrac Double fuzz DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a + DiffTime baseDelay DiffTime -> DiffTime -> DiffTime forall a. Num a => a -> a -> a - DiffTime execTime Tracer m (TracePeerSelection peeraddr) -> TracePeerSelection peeraddr -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TracePeerSelection peeraddr) tracer (TracePeerSelection peeraddr -> m ()) -> TracePeerSelection peeraddr -> m () forall a b. (a -> b) -> a -> b $ DiffTime -> TracePeerSelection peeraddr forall peeraddr. DiffTime -> TracePeerSelection peeraddr TraceChurnWait DiffTime delay DiffTime -> m () forall (m :: * -> *). MonadDelay m => DiffTime -> m () threadDelay DiffTime delay StdGen -> m StdGen forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return StdGen rng' longDelay :: StdGen -> DiffTime -> m StdGen longDelay :: StdGen -> DiffTime -> m StdGen longDelay = DiffTime -> Double -> StdGen -> DiffTime -> m StdGen fuzzyDelay' DiffTime deadlineChurnInterval Double 600 shortDelay :: StdGen -> DiffTime -> m StdGen shortDelay :: StdGen -> DiffTime -> m StdGen shortDelay = DiffTime -> Double -> StdGen -> DiffTime -> m StdGen fuzzyDelay' DiffTime bulkChurnInterval Double 60 -- Ideally this would be as low as possible but the governor might be in -- the process of promoting/demoting a peer and it will take some time -- before it can act on new targets set by churn shortTimeout :: DiffTime shortTimeout :: DiffTime shortTimeout = DiffTime 60 -- Replace 20% or at least one peer every churnInterval. decrease :: Int -> Int decrease :: Int -> Int decrease Int v = Int -> Int -> Int forall a. Ord a => a -> a -> a max Int 0 (Int -> Int) -> Int -> Int forall a b. (a -> b) -> a -> b $ Int v Int -> Int -> Int forall a. Num a => a -> a -> a - Int -> Int -> Int forall a. Ord a => a -> a -> a max Int 1 (Int v Int -> Int -> Int forall a. Integral a => a -> a -> a `div` Int 5)