{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} module Ouroboros.Network.PeerSelection.Governor.Types ( -- * P2P governor policies PeerSelectionPolicy (..) , PeerSelectionTargets (..) , nullPeerSelectionTargets , sanePeerSelectionTargets , PickPolicy , pickPeers -- * P2P governor low level API -- These records are needed to run the peer selection. , PeerStateActions (..) , PeerSelectionActions (..) , ChurnMode (..) -- * P2P governor internals , PeerSelectionState (..) , emptyPeerSelectionState , assertPeerSelectionState , establishedPeersStatus , Guarded (GuardedSkip, Guarded) , Decision (..) , TimedDecision , MkGuardedDecision , Completion (..) , PeerSelectionCounters (..) , peerStateToCounters -- * Traces , TracePeerSelection (..) , DebugPeerSelection (..) ) where import Data.Cache (Cache (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Monoid.Synchronisation (FirstToFinish (..)) import Data.Semigroup (Min (..)) import Data.Set (Set) import qualified Data.Set as Set import Control.Applicative (Alternative) import Control.Concurrent.JobPool (Job) import Control.Exception (SomeException, assert) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime import System.Random (StdGen) import Ouroboros.Network.ExitPolicy import Ouroboros.Network.PeerSelection.EstablishedPeers (EstablishedPeers) import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers import Ouroboros.Network.PeerSelection.KnownPeers (KnownPeers) import qualified Ouroboros.Network.PeerSelection.KnownPeers as KnownPeers import Ouroboros.Network.PeerSelection.LocalRootPeers (LocalRootPeers) import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers import Ouroboros.Network.PeerSelection.Types -- | A peer pick policy is an action that picks a subset of elements from a -- map of peers. -- -- The pre-condition is that the map of available choices will be non-empty, -- and the requested number to pick will be strictly positive. -- -- The post-condition is that the picked set is non-empty but must not be -- bigger than the requested number. -- type PickPolicy peeraddr m = -- Extra peer attributes available to use in the picking policy. -- As more attributes are needed, extend this with more such functions. (peeraddr -> PeerSource) -- Where the peer is known from -> (peeraddr -> Int) -- Connection failure count -> (peeraddr -> Bool) -- Found to be tepid flag -> Set peeraddr -- The set to pick from -> Int -- Max number to choose, fewer is ok. -> STM m (Set peeraddr) -- The set picked. data PeerSelectionPolicy peeraddr m = PeerSelectionPolicy { PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m policyPickKnownPeersForGossip :: PickPolicy peeraddr m, PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m policyPickColdPeersToPromote :: PickPolicy peeraddr m, PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m policyPickWarmPeersToPromote :: PickPolicy peeraddr m, PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m policyPickHotPeersToDemote :: PickPolicy peeraddr m, PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m policyPickWarmPeersToDemote :: PickPolicy peeraddr m, PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m policyPickColdPeersToForget :: PickPolicy peeraddr m, PeerSelectionPolicy peeraddr m -> DiffTime policyFindPublicRootTimeout :: !DiffTime, PeerSelectionPolicy peeraddr m -> Int policyMaxInProgressGossipReqs :: !Int, PeerSelectionPolicy peeraddr m -> DiffTime policyGossipRetryTime :: !DiffTime, PeerSelectionPolicy peeraddr m -> DiffTime policyGossipBatchWaitTime :: !DiffTime, PeerSelectionPolicy peeraddr m -> DiffTime policyGossipOverallTimeout :: !DiffTime, -- | Reconnection delay, passed from `ExitPolicy`. -- PeerSelectionPolicy peeraddr m -> DiffTime policyErrorDelay :: !DiffTime } -- | Adjustable targets for the peer selection mechanism. -- -- These are used by the peer selection governor as targets. They are used by -- the peer churn governor loop as knobs to adjust, to influence the peer -- selection governor. -- -- The /known/, /established/ and /active/ peer targets are targets both from -- below and from above: the governor will attempt to grow or shrink the sets -- to hit these targets. -- -- Unlike the other targets, the /root/ peer target is \"one sided\", it is -- only a target from below. The governor does not try to shrink the root set -- to hit it, it simply stops looking for more. -- -- There is also an implicit target that enough local root peers are selected -- as active. This comes from the configuration for local roots, and is not an -- independently adjustable target. -- data PeerSelectionTargets = PeerSelectionTargets { PeerSelectionTargets -> Int targetNumberOfRootPeers :: !Int, PeerSelectionTargets -> Int targetNumberOfKnownPeers :: !Int, PeerSelectionTargets -> Int targetNumberOfEstablishedPeers :: !Int, PeerSelectionTargets -> Int targetNumberOfActivePeers :: !Int -- Expressed as intervals rather than frequencies -- targetChurnIntervalKnownPeers :: !DiffTime, -- targetChurnIntervalEstablishedPeers :: !DiffTime, -- targetChurnIntervalActivePeers :: !DiffTime } deriving (PeerSelectionTargets -> PeerSelectionTargets -> Bool (PeerSelectionTargets -> PeerSelectionTargets -> Bool) -> (PeerSelectionTargets -> PeerSelectionTargets -> Bool) -> Eq PeerSelectionTargets forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: PeerSelectionTargets -> PeerSelectionTargets -> Bool $c/= :: PeerSelectionTargets -> PeerSelectionTargets -> Bool == :: PeerSelectionTargets -> PeerSelectionTargets -> Bool $c== :: PeerSelectionTargets -> PeerSelectionTargets -> Bool Eq, Int -> PeerSelectionTargets -> ShowS [PeerSelectionTargets] -> ShowS PeerSelectionTargets -> String (Int -> PeerSelectionTargets -> ShowS) -> (PeerSelectionTargets -> String) -> ([PeerSelectionTargets] -> ShowS) -> Show PeerSelectionTargets forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PeerSelectionTargets] -> ShowS $cshowList :: [PeerSelectionTargets] -> ShowS show :: PeerSelectionTargets -> String $cshow :: PeerSelectionTargets -> String showsPrec :: Int -> PeerSelectionTargets -> ShowS $cshowsPrec :: Int -> PeerSelectionTargets -> ShowS Show) nullPeerSelectionTargets :: PeerSelectionTargets nullPeerSelectionTargets :: PeerSelectionTargets nullPeerSelectionTargets = PeerSelectionTargets :: Int -> Int -> Int -> Int -> PeerSelectionTargets PeerSelectionTargets { targetNumberOfRootPeers :: Int targetNumberOfRootPeers = Int 0, targetNumberOfKnownPeers :: Int targetNumberOfKnownPeers = Int 0, targetNumberOfEstablishedPeers :: Int targetNumberOfEstablishedPeers = Int 0, targetNumberOfActivePeers :: Int targetNumberOfActivePeers = Int 0 -- targetChurnIntervalKnownPeers = 0, -- targetChurnIntervalEstablishedPeers = 0, -- targetChurnIntervalActivePeers = 0 } sanePeerSelectionTargets :: PeerSelectionTargets -> Bool sanePeerSelectionTargets :: PeerSelectionTargets -> Bool sanePeerSelectionTargets PeerSelectionTargets{Int targetNumberOfActivePeers :: Int targetNumberOfEstablishedPeers :: Int targetNumberOfKnownPeers :: Int targetNumberOfRootPeers :: Int targetNumberOfActivePeers :: PeerSelectionTargets -> Int targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int targetNumberOfKnownPeers :: PeerSelectionTargets -> Int targetNumberOfRootPeers :: PeerSelectionTargets -> Int ..} = Int 0 Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfActivePeers Bool -> Bool -> Bool && Int targetNumberOfActivePeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfEstablishedPeers Bool -> Bool -> Bool && Int targetNumberOfEstablishedPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfKnownPeers Bool -> Bool -> Bool && Int targetNumberOfRootPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfKnownPeers Bool -> Bool -> Bool && Int 0 Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int targetNumberOfRootPeers Bool -> Bool -> Bool && Int targetNumberOfActivePeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 100 Bool -> Bool -> Bool && Int targetNumberOfEstablishedPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 1000 Bool -> Bool -> Bool && Int targetNumberOfKnownPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 10000 -- | Actions performed by the peer selection governor. -- -- These being pluggable allows: -- -- * choice of known peer root sets -- * running both in simulation and for real -- data PeerSelectionActions peeraddr peerconn m = PeerSelectionActions { PeerSelectionActions peeraddr peerconn m -> STM m PeerSelectionTargets readPeerSelectionTargets :: STM m PeerSelectionTargets, -- | Read the current set of locally or privately known root peers. -- -- In general this is expected to be updated asynchronously by some -- other thread. It is intended to cover the use case of peers from -- local configuration. It could be dynamic due to DNS resolution, or -- due to dynamic configuration updates. -- -- It is structured as a collection of (non-overlapping) groups of peers -- where we are supposed to select n from each group. -- PeerSelectionActions peeraddr peerconn m -> STM m [(Int, Map peeraddr PeerAdvertise)] readLocalRootPeers :: STM m [(Int, Map peeraddr PeerAdvertise)], -- | Request a sample of public root peers. -- -- It is intended to cover use cases including: -- -- * federated relays from a DNS pool -- * stake pool relays published in the blockchain -- * a pre-distributed snapshot of stake pool relays from the blockchain -- PeerSelectionActions peeraddr peerconn m -> Int -> m (Set peeraddr, DiffTime) requestPublicRootPeers :: Int -> m (Set peeraddr, DiffTime), -- | The action to contact a known peer and request a sample of its -- known peers. -- -- This is synchronous, but it should expect to be interrupted by a -- timeout asynchronous exception. Failures are throw as exceptions. -- PeerSelectionActions peeraddr peerconn m -> peeraddr -> m [peeraddr] requestPeerGossip :: peeraddr -> m [peeraddr], -- | Core actions run by the governor to change 'PeerStatus'. -- PeerSelectionActions peeraddr peerconn m -> PeerStateActions peeraddr peerconn m peerStateActions :: PeerStateActions peeraddr peerconn m } -- | Callbacks which are performed to change peer state. -- data PeerStateActions peeraddr peerconn m = PeerStateActions { -- | Monitor peer state. -- PeerStateActions peeraddr peerconn m -> peerconn -> STM m (PeerStatus, ReconnectDelay) monitorPeerConnection :: peerconn -> STM m (PeerStatus, ReconnectDelay), -- | Establish new connection: cold to warm. -- PeerStateActions peeraddr peerconn m -> peeraddr -> m peerconn establishPeerConnection :: peeraddr -> m peerconn, -- | Activate a connection: warm to hot promotion. -- PeerStateActions peeraddr peerconn m -> peerconn -> m () activatePeerConnection :: peerconn -> m (), -- | Deactive a peer: hot to warm demotion. -- PeerStateActions peeraddr peerconn m -> peerconn -> m () deactivatePeerConnection :: peerconn -> m (), -- | Close a connection: warm to cold transition. -- PeerStateActions peeraddr peerconn m -> peerconn -> m () closePeerConnection :: peerconn -> m () } ----------------------- -- Peer Selection State -- -- | The internal state used by the 'peerSelectionGovernor'. -- -- The local and public root sets are disjoint, and their union is the -- overall root set. -- data PeerSelectionState peeraddr peerconn = PeerSelectionState { PeerSelectionState peeraddr peerconn -> PeerSelectionTargets targets :: !PeerSelectionTargets, -- | The current set of local root peers. This is structured as a -- bunch of groups, with a target for each group. This gives us a set of -- n-of-m choices, e.g. \"pick 2 from this group and 1 from this group\". -- -- The targets must of course be achievable, and to keep things simple, -- the groups must be disjoint. -- PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr localRootPeers :: !(LocalRootPeers peeraddr), PeerSelectionState peeraddr peerconn -> Set peeraddr publicRootPeers :: !(Set peeraddr), -- | -- PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr knownPeers :: !(KnownPeers peeraddr), -- | -- PeerSelectionState peeraddr peerconn -> EstablishedPeers peeraddr peerconn establishedPeers :: !(EstablishedPeers peeraddr peerconn), -- | -- PeerSelectionState peeraddr peerconn -> Set peeraddr activePeers :: !(Set peeraddr), -- | A counter to manage the exponential backoff strategy for when to -- retry querying for more public root peers. It is negative for retry -- counts after failure, and positive for retry counts that are -- successful but make no progress. -- PeerSelectionState peeraddr peerconn -> Int publicRootBackoffs :: !Int, -- | The earliest time we would be prepared to request more public root -- peers. This is used with the 'publicRootBackoffs' to manage the -- exponential backoff. -- PeerSelectionState peeraddr peerconn -> Time publicRootRetryTime :: !Time, PeerSelectionState peeraddr peerconn -> Bool inProgressPublicRootsReq :: !Bool, PeerSelectionState peeraddr peerconn -> Int inProgressGossipReqs :: !Int, PeerSelectionState peeraddr peerconn -> Set peeraddr inProgressPromoteCold :: !(Set peeraddr), PeerSelectionState peeraddr peerconn -> Set peeraddr inProgressPromoteWarm :: !(Set peeraddr), PeerSelectionState peeraddr peerconn -> Set peeraddr inProgressDemoteWarm :: !(Set peeraddr), PeerSelectionState peeraddr peerconn -> Set peeraddr inProgressDemoteHot :: !(Set peeraddr), -- | Rng for fuzzy delay PeerSelectionState peeraddr peerconn -> StdGen fuzzRng :: !StdGen, -- | 'PeerSelectionCounters' counters cache. Allows to only trace -- values when necessary. -- PeerSelectionState peeraddr peerconn -> Cache PeerSelectionCounters countersCache :: !(Cache PeerSelectionCounters) -- TODO: need something like this to distinguish between lots of bad peers -- and us getting disconnected from the network locally. We don't want a -- network disconnect to cause us to flush our full known peer set by -- considering them all to have bad connectivity. -- Should also take account of DNS failures for root peer set. -- lastSucessfulNetworkEvent :: Time } deriving (Int -> PeerSelectionState peeraddr peerconn -> ShowS [PeerSelectionState peeraddr peerconn] -> ShowS PeerSelectionState peeraddr peerconn -> String (Int -> PeerSelectionState peeraddr peerconn -> ShowS) -> (PeerSelectionState peeraddr peerconn -> String) -> ([PeerSelectionState peeraddr peerconn] -> ShowS) -> Show (PeerSelectionState peeraddr peerconn) forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a forall peeraddr peerconn. (Ord peeraddr, Show peeraddr, Show peerconn) => Int -> PeerSelectionState peeraddr peerconn -> ShowS forall peeraddr peerconn. (Ord peeraddr, Show peeraddr, Show peerconn) => [PeerSelectionState peeraddr peerconn] -> ShowS forall peeraddr peerconn. (Ord peeraddr, Show peeraddr, Show peerconn) => PeerSelectionState peeraddr peerconn -> String showList :: [PeerSelectionState peeraddr peerconn] -> ShowS $cshowList :: forall peeraddr peerconn. (Ord peeraddr, Show peeraddr, Show peerconn) => [PeerSelectionState peeraddr peerconn] -> ShowS show :: PeerSelectionState peeraddr peerconn -> String $cshow :: forall peeraddr peerconn. (Ord peeraddr, Show peeraddr, Show peerconn) => PeerSelectionState peeraddr peerconn -> String showsPrec :: Int -> PeerSelectionState peeraddr peerconn -> ShowS $cshowsPrec :: forall peeraddr peerconn. (Ord peeraddr, Show peeraddr, Show peerconn) => Int -> PeerSelectionState peeraddr peerconn -> ShowS Show, a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a (a -> b) -> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b (forall a b. (a -> b) -> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b) -> (forall a b. a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a) -> Functor (PeerSelectionState peeraddr) forall a b. a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a forall a b. (a -> b) -> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b forall peeraddr a b. a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a forall peeraddr a b. (a -> b) -> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a $c<$ :: forall peeraddr a b. a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a fmap :: (a -> b) -> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b $cfmap :: forall peeraddr a b. (a -> b) -> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b Functor) data PeerSelectionCounters = PeerSelectionCounters { PeerSelectionCounters -> Int coldPeers :: Int, PeerSelectionCounters -> Int warmPeers :: Int, PeerSelectionCounters -> Int hotPeers :: Int } deriving (PeerSelectionCounters -> PeerSelectionCounters -> Bool (PeerSelectionCounters -> PeerSelectionCounters -> Bool) -> (PeerSelectionCounters -> PeerSelectionCounters -> Bool) -> Eq PeerSelectionCounters forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: PeerSelectionCounters -> PeerSelectionCounters -> Bool $c/= :: PeerSelectionCounters -> PeerSelectionCounters -> Bool == :: PeerSelectionCounters -> PeerSelectionCounters -> Bool $c== :: PeerSelectionCounters -> PeerSelectionCounters -> Bool Eq, Int -> PeerSelectionCounters -> ShowS [PeerSelectionCounters] -> ShowS PeerSelectionCounters -> String (Int -> PeerSelectionCounters -> ShowS) -> (PeerSelectionCounters -> String) -> ([PeerSelectionCounters] -> ShowS) -> Show PeerSelectionCounters forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PeerSelectionCounters] -> ShowS $cshowList :: [PeerSelectionCounters] -> ShowS show :: PeerSelectionCounters -> String $cshow :: PeerSelectionCounters -> String showsPrec :: Int -> PeerSelectionCounters -> ShowS $cshowsPrec :: Int -> PeerSelectionCounters -> ShowS Show) peerStateToCounters :: Ord peeraddr => PeerSelectionState peeraddr peerconn -> PeerSelectionCounters peerStateToCounters :: PeerSelectionState peeraddr peerconn -> PeerSelectionCounters peerStateToCounters PeerSelectionState peeraddr peerconn st = PeerSelectionCounters :: Int -> Int -> Int -> PeerSelectionCounters PeerSelectionCounters { Int coldPeers :: Int coldPeers :: Int coldPeers, Int warmPeers :: Int warmPeers :: Int warmPeers, Int hotPeers :: Int hotPeers :: Int hotPeers } where knownPeersSet :: Set peeraddr knownPeersSet = KnownPeers peeraddr -> Set peeraddr forall peeraddr. KnownPeers peeraddr -> Set peeraddr KnownPeers.toSet (PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr knownPeers PeerSelectionState peeraddr peerconn st) establishedPeersSet :: Set peeraddr establishedPeersSet = EstablishedPeers peeraddr peerconn -> Set peeraddr forall peeraddr peerconn. EstablishedPeers peeraddr peerconn -> Set peeraddr EstablishedPeers.toSet (PeerSelectionState peeraddr peerconn -> EstablishedPeers peeraddr peerconn forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> EstablishedPeers peeraddr peerconn establishedPeers PeerSelectionState peeraddr peerconn st) coldPeers :: Int coldPeers = Set peeraddr -> Int forall a. Set a -> Int Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int forall a b. (a -> b) -> a -> b $ Set peeraddr knownPeersSet Set peeraddr -> Set peeraddr -> Set peeraddr forall a. Ord a => Set a -> Set a -> Set a Set.\\ Set peeraddr establishedPeersSet warmPeers :: Int warmPeers = Set peeraddr -> Int forall a. Set a -> Int Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int forall a b. (a -> b) -> a -> b $ Set peeraddr establishedPeersSet Set peeraddr -> Set peeraddr -> Set peeraddr forall a. Ord a => Set a -> Set a -> Set a Set.\\ PeerSelectionState peeraddr peerconn -> Set peeraddr forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr activePeers PeerSelectionState peeraddr peerconn st hotPeers :: Int hotPeers = Set peeraddr -> Int forall a. Set a -> Int Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int forall a b. (a -> b) -> a -> b $ PeerSelectionState peeraddr peerconn -> Set peeraddr forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr activePeers PeerSelectionState peeraddr peerconn st emptyPeerSelectionState :: StdGen -> PeerSelectionState peeraddr peerconn emptyPeerSelectionState :: StdGen -> PeerSelectionState peeraddr peerconn emptyPeerSelectionState StdGen rng = PeerSelectionState :: forall peeraddr peerconn. PeerSelectionTargets -> LocalRootPeers peeraddr -> Set peeraddr -> KnownPeers peeraddr -> EstablishedPeers peeraddr peerconn -> Set peeraddr -> Int -> Time -> Bool -> Int -> Set peeraddr -> Set peeraddr -> Set peeraddr -> Set peeraddr -> StdGen -> Cache PeerSelectionCounters -> PeerSelectionState peeraddr peerconn PeerSelectionState { targets :: PeerSelectionTargets targets = PeerSelectionTargets nullPeerSelectionTargets, localRootPeers :: LocalRootPeers peeraddr localRootPeers = LocalRootPeers peeraddr forall peeraddr. LocalRootPeers peeraddr LocalRootPeers.empty, publicRootPeers :: Set peeraddr publicRootPeers = Set peeraddr forall a. Set a Set.empty, knownPeers :: KnownPeers peeraddr knownPeers = KnownPeers peeraddr forall peeraddr. KnownPeers peeraddr KnownPeers.empty, establishedPeers :: EstablishedPeers peeraddr peerconn establishedPeers = EstablishedPeers peeraddr peerconn forall peeraddr perconn. EstablishedPeers peeraddr perconn EstablishedPeers.empty, activePeers :: Set peeraddr activePeers = Set peeraddr forall a. Set a Set.empty, publicRootBackoffs :: Int publicRootBackoffs = Int 0, publicRootRetryTime :: Time publicRootRetryTime = DiffTime -> Time Time DiffTime 0, inProgressPublicRootsReq :: Bool inProgressPublicRootsReq = Bool False, inProgressGossipReqs :: Int inProgressGossipReqs = Int 0, inProgressPromoteCold :: Set peeraddr inProgressPromoteCold = Set peeraddr forall a. Set a Set.empty, inProgressPromoteWarm :: Set peeraddr inProgressPromoteWarm = Set peeraddr forall a. Set a Set.empty, inProgressDemoteWarm :: Set peeraddr inProgressDemoteWarm = Set peeraddr forall a. Set a Set.empty, inProgressDemoteHot :: Set peeraddr inProgressDemoteHot = Set peeraddr forall a. Set a Set.empty, fuzzRng :: StdGen fuzzRng = StdGen rng, countersCache :: Cache PeerSelectionCounters countersCache = PeerSelectionCounters -> Cache PeerSelectionCounters forall a. a -> Cache a Cache (Int -> Int -> Int -> PeerSelectionCounters PeerSelectionCounters Int 0 Int 0 Int 0) } assertPeerSelectionState :: Ord peeraddr => PeerSelectionState peeraddr peerconn -> a -> a assertPeerSelectionState :: PeerSelectionState peeraddr peerconn -> a -> a assertPeerSelectionState PeerSelectionState{Bool Int Set peeraddr StdGen Cache PeerSelectionCounters Time EstablishedPeers peeraddr peerconn KnownPeers peeraddr LocalRootPeers peeraddr PeerSelectionTargets countersCache :: Cache PeerSelectionCounters fuzzRng :: StdGen inProgressDemoteHot :: Set peeraddr inProgressDemoteWarm :: Set peeraddr inProgressPromoteWarm :: Set peeraddr inProgressPromoteCold :: Set peeraddr inProgressGossipReqs :: Int inProgressPublicRootsReq :: Bool publicRootRetryTime :: Time publicRootBackoffs :: Int activePeers :: Set peeraddr establishedPeers :: EstablishedPeers peeraddr peerconn knownPeers :: KnownPeers peeraddr publicRootPeers :: Set peeraddr localRootPeers :: LocalRootPeers peeraddr targets :: PeerSelectionTargets countersCache :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Cache PeerSelectionCounters fuzzRng :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> StdGen inProgressDemoteHot :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr inProgressDemoteWarm :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr inProgressPromoteWarm :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr inProgressPromoteCold :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr inProgressGossipReqs :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Int inProgressPublicRootsReq :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Bool publicRootRetryTime :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Time publicRootBackoffs :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Int activePeers :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr establishedPeers :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> EstablishedPeers peeraddr peerconn knownPeers :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr publicRootPeers :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr localRootPeers :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr targets :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> PeerSelectionTargets ..} = Bool -> a -> a forall a. (?callStack::CallStack) => Bool -> a -> a assert (KnownPeers peeraddr -> Bool forall peeraddr. Ord peeraddr => KnownPeers peeraddr -> Bool KnownPeers.invariant KnownPeers peeraddr knownPeers) (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a forall a. (?callStack::CallStack) => Bool -> a -> a assert (EstablishedPeers peeraddr peerconn -> Bool forall peeraddr peerconn. Ord peeraddr => EstablishedPeers peeraddr peerconn -> Bool EstablishedPeers.invariant EstablishedPeers peeraddr peerconn establishedPeers) (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a forall a. (?callStack::CallStack) => Bool -> a -> a assert (LocalRootPeers peeraddr -> Bool forall peeraddr. Ord peeraddr => LocalRootPeers peeraddr -> Bool LocalRootPeers.invariant LocalRootPeers peeraddr localRootPeers) -- The activePeers is a subset of the establishedPeers -- which is a subset of the known peers (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 activePeersSet Set peeraddr establishedReadySet) (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 establishedPeersSet Set peeraddr knownPeersSet) -- The localRootPeers and publicRootPeers must not overlap. (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a forall a. (?callStack::CallStack) => Bool -> a -> a assert (Set peeraddr -> Bool forall a. Set a -> Bool Set.null (Set peeraddr -> Set peeraddr -> Set peeraddr forall a. Ord a => Set a -> Set a -> Set a Set.intersection Set peeraddr localRootPeersSet Set peeraddr publicRootPeers)) -- The localRootPeers are a subset of the knownPeers, -- and with correct source info in the knownPeers (either -- 'PeerSroucePublicRoot' or 'PeerSourceLocalRoot', as local and public -- root peers might overlap). (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 localRootPeersSet Set peeraddr knownPeersSet) -- The publicRootPeers are a subset of the knownPeers, -- and with correct source info in the knownPeers. (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 Set peeraddr knownPeersSet) -- The targets should respect the containment relationships of the root, -- known, established and active peers (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a forall a. (?callStack::CallStack) => Bool -> a -> a assert (PeerSelectionTargets -> Bool sanePeerSelectionTargets PeerSelectionTargets targets) -- All the local root peers are always a subset of the known peers. The -- target for known peers is a target from both below and above. Thus the -- number of local root peers must be less than or equal to the known peers -- target, otherwise we could get stuck. (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a forall a. (?callStack::CallStack) => Bool -> a -> a assert (LocalRootPeers peeraddr -> Int forall peeraddr. LocalRootPeers peeraddr -> Int LocalRootPeers.size LocalRootPeers peeraddr localRootPeers Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= PeerSelectionTargets -> Int targetNumberOfKnownPeers PeerSelectionTargets targets) -- Interestingly, although the local root peers are also a subset of the -- root peers, the equivalent constraint does not apply to the target -- number of root peers. The reason is that the root peers target is only -- a target from below, not from above. It is ok to have more than the -- target number of root peers. -- --That is, we do /not/ need or want this invariant: -- LocalRootPeers.size localRootPeers <= targetNumberOfRootPeers -- -- It is also not necessary for all the targets to be achievable. It is -- just necessary that we do not get stuck. So although we have an implicit -- target that all local root peers become established, and a certain -- number of them become active, these targets do not need to be achievable. -- --That is, we do /not/ need or want this invariant: -- LocalRootPeers.size localRootPeers <= targetNumberOfEstablishedPeers -- LocalRootPeers.target localRootPeers <= targetNumberOfActivePeers -- -- All currently established peers are in the availableToConnect set since -- the alternative is a record of failure, but these are not (yet) failed. (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 establishedPeersSet (KnownPeers peeraddr -> Set peeraddr forall peeraddr. KnownPeers peeraddr -> Set peeraddr KnownPeers.availableToConnect KnownPeers peeraddr knownPeers)) -- No constraint for publicRootBackoffs, publicRootRetryTime -- or inProgressPublicRootsReq (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a forall a. (?callStack::CallStack) => Bool -> a -> a assert (Int inProgressGossipReqs Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int 0) (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 inProgressPromoteCold Set peeraddr coldPeersSet) (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 inProgressPromoteWarm Set peeraddr warmPeersSet) (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 inProgressDemoteWarm Set peeraddr warmPeersSet) (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a 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 inProgressDemoteHot Set peeraddr hotPeersSet) (a -> a) -> (a -> a) -> a -> a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bool -> a -> a forall a. (?callStack::CallStack) => Bool -> a -> a assert (Set peeraddr -> Bool forall a. Set a -> Bool Set.null (Set peeraddr -> Set peeraddr -> Set peeraddr forall a. Ord a => Set a -> Set a -> Set a Set.intersection Set peeraddr inProgressPromoteWarm Set peeraddr inProgressDemoteWarm)) where knownPeersSet :: Set peeraddr knownPeersSet = KnownPeers peeraddr -> Set peeraddr forall peeraddr. KnownPeers peeraddr -> Set peeraddr KnownPeers.toSet KnownPeers peeraddr knownPeers localRootPeersSet :: Set peeraddr localRootPeersSet = LocalRootPeers peeraddr -> Set peeraddr forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr LocalRootPeers.keysSet LocalRootPeers peeraddr localRootPeers establishedPeersSet :: Set peeraddr establishedPeersSet = EstablishedPeers peeraddr peerconn -> Set peeraddr forall peeraddr peerconn. EstablishedPeers peeraddr peerconn -> Set peeraddr EstablishedPeers.toSet EstablishedPeers peeraddr peerconn establishedPeers establishedReadySet :: Set peeraddr establishedReadySet = EstablishedPeers peeraddr peerconn -> Set peeraddr forall peeraddr peerconn. Ord peeraddr => EstablishedPeers peeraddr peerconn -> Set peeraddr EstablishedPeers.readyPeers EstablishedPeers peeraddr peerconn establishedPeers activePeersSet :: Set peeraddr activePeersSet = Set peeraddr activePeers coldPeersSet :: Set peeraddr coldPeersSet = Set peeraddr knownPeersSet Set peeraddr -> Set peeraddr -> Set peeraddr forall a. Ord a => Set a -> Set a -> Set a Set.\\ Set peeraddr establishedPeersSet warmPeersSet :: Set peeraddr warmPeersSet = Set peeraddr establishedPeersSet Set peeraddr -> Set peeraddr -> Set peeraddr forall a. Ord a => Set a -> Set a -> Set a Set.\\ Set peeraddr activePeersSet hotPeersSet :: Set peeraddr hotPeersSet = Set peeraddr activePeersSet -- | A view of the status of each established peer, for testing and debugging. -- establishedPeersStatus :: Ord peeraddr => PeerSelectionState peeraddr peerconn -> Map peeraddr PeerStatus establishedPeersStatus :: PeerSelectionState peeraddr peerconn -> Map peeraddr PeerStatus establishedPeersStatus PeerSelectionState{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} = -- map union-override, left to right (peeraddr -> PeerStatus) -> Set peeraddr -> Map peeraddr PeerStatus forall k a. (k -> a) -> Set k -> Map k a Map.fromSet (\peeraddr _ -> PeerStatus PeerHot) Set peeraddr activePeers Map peeraddr PeerStatus -> Map peeraddr PeerStatus -> Map peeraddr PeerStatus forall a. Semigroup a => a -> a -> a <> (peeraddr -> PeerStatus) -> Set peeraddr -> Map peeraddr PeerStatus forall k a. (k -> a) -> Set k -> Map k a Map.fromSet (\peeraddr _ -> PeerStatus PeerWarm) (EstablishedPeers peeraddr peerconn -> Set peeraddr forall peeraddr peerconn. EstablishedPeers peeraddr peerconn -> Set peeraddr EstablishedPeers.toSet EstablishedPeers peeraddr peerconn establishedPeers) -------------------------------- -- PickPolicy wrapper function -- -- | Check pre-conditions and post-conditions on the pick policies, -- and supply additional peer atributes from the current state. -- pickPeers :: (Ord peeraddr, Functor m) => PeerSelectionState peeraddr peerconn -> ( (peeraddr -> PeerSource) -> (peeraddr -> Int) -> (peeraddr -> Bool) -> Set peeraddr -> Int -> m (Set peeraddr)) -> Set peeraddr -> Int -> m (Set peeraddr) pickPeers :: PeerSelectionState peeraddr peerconn -> ((peeraddr -> PeerSource) -> (peeraddr -> Int) -> (peeraddr -> Bool) -> Set peeraddr -> Int -> m (Set peeraddr)) -> Set peeraddr -> Int -> m (Set peeraddr) pickPeers PeerSelectionState{LocalRootPeers peeraddr localRootPeers :: LocalRootPeers peeraddr localRootPeers :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr localRootPeers, Set peeraddr publicRootPeers :: Set peeraddr publicRootPeers :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> Set peeraddr publicRootPeers, KnownPeers peeraddr knownPeers :: KnownPeers peeraddr knownPeers :: forall peeraddr peerconn. PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr knownPeers} (peeraddr -> PeerSource) -> (peeraddr -> Int) -> (peeraddr -> Bool) -> Set peeraddr -> Int -> m (Set peeraddr) pick Set peeraddr available Int num = Bool -> m (Set peeraddr) -> m (Set peeraddr) forall a. (?callStack::CallStack) => Bool -> a -> a assert Bool precondition (m (Set peeraddr) -> m (Set peeraddr)) -> m (Set peeraddr) -> m (Set peeraddr) forall a b. (a -> b) -> a -> b $ (Set peeraddr -> Set peeraddr) -> m (Set peeraddr) -> m (Set peeraddr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (\Set peeraddr picked -> Bool -> Set peeraddr -> Set peeraddr forall a. (?callStack::CallStack) => Bool -> a -> a assert (Set peeraddr -> Bool postcondition Set peeraddr picked) Set peeraddr picked) ((peeraddr -> PeerSource) -> (peeraddr -> Int) -> (peeraddr -> Bool) -> Set peeraddr -> Int -> m (Set peeraddr) pick peeraddr -> PeerSource peerSource peeraddr -> Int peerConnectFailCount peeraddr -> Bool peerTepidFlag Set peeraddr available Int numClamped) where precondition :: Bool precondition = Bool -> Bool not (Set peeraddr -> Bool forall a. Set a -> Bool Set.null Set peeraddr available) Bool -> Bool -> Bool && Int num Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 0 postcondition :: Set peeraddr -> Bool postcondition Set peeraddr picked = Bool -> Bool not (Set peeraddr -> Bool forall a. Set a -> Bool Set.null Set peeraddr picked) Bool -> Bool -> Bool && Set peeraddr -> Int forall a. Set a -> Int Set.size Set peeraddr picked Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int numClamped Bool -> Bool -> Bool && Set peeraddr picked Set peeraddr -> Set peeraddr -> Bool forall a. Ord a => Set a -> Set a -> Bool `Set.isSubsetOf` Set peeraddr available numClamped :: Int numClamped = Int -> Int -> Int forall a. Ord a => a -> a -> a min Int num (Set peeraddr -> Int forall a. Set a -> Int Set.size Set peeraddr available) peerSource :: peeraddr -> PeerSource peerSource peeraddr p | peeraddr -> LocalRootPeers peeraddr -> Bool forall peeraddr. Ord peeraddr => peeraddr -> LocalRootPeers peeraddr -> Bool LocalRootPeers.member peeraddr p LocalRootPeers peeraddr localRootPeers = PeerSource PeerSourceLocalRoot | peeraddr -> Set peeraddr -> Bool forall a. Ord a => a -> Set a -> Bool Set.member peeraddr p Set peeraddr publicRootPeers = PeerSource PeerSourcePublicRoot | peeraddr -> KnownPeers peeraddr -> Bool forall peeraddr. Ord peeraddr => peeraddr -> KnownPeers peeraddr -> Bool KnownPeers.member peeraddr p KnownPeers peeraddr knownPeers = PeerSource PeerSourceGossip | Bool otherwise = PeerSource forall a. a errorUnavailable peerConnectFailCount :: peeraddr -> Int peerConnectFailCount peeraddr p = Int -> Maybe Int -> Int forall a. a -> Maybe a -> a fromMaybe Int forall a. a errorUnavailable (Maybe Int -> Int) -> Maybe Int -> Int forall a b. (a -> b) -> a -> b $ peeraddr -> KnownPeers peeraddr -> Maybe Int forall peeraddr. Ord peeraddr => peeraddr -> KnownPeers peeraddr -> Maybe Int KnownPeers.lookupFailCount peeraddr p KnownPeers peeraddr knownPeers peerTepidFlag :: peeraddr -> Bool peerTepidFlag peeraddr p = Bool -> Maybe Bool -> Bool forall a. a -> Maybe a -> a fromMaybe Bool forall a. a errorUnavailable (Maybe Bool -> Bool) -> Maybe Bool -> Bool forall a b. (a -> b) -> a -> b $ peeraddr -> KnownPeers peeraddr -> Maybe Bool forall peeraddr. Ord peeraddr => peeraddr -> KnownPeers peeraddr -> Maybe Bool KnownPeers.lookupTepidFlag peeraddr p KnownPeers peeraddr knownPeers errorUnavailable :: a errorUnavailable = String -> a forall a. (?callStack::CallStack) => String -> a error (String -> a) -> String -> a forall a b. (a -> b) -> a -> b $ String "A pick policy requested an attribute for peer address " String -> ShowS forall a. [a] -> [a] -> [a] ++ String " which is outside of the set given to pick from" --------------------------- -- Peer Selection Decisions -- -- | The governor is using @Guarded m (Decision m peeraddr peerconn)@ where 'm' -- is an 'STM' monad, to drive its progress. -- data Guarded m a = -- | 'GuardedSkip' is used to instruct that there is no action to be made -- by the governor. -- -- Let us note that the combined value which is computed by -- @guardedDecisions@ term in -- 'Ouroboros.Newtork.PeerSelection.Governor.peerSelectionGovernorLoop' will -- never return it: this is bacause there are monitoring decisions which -- never return this constructor, e.g. 'Monitor.targetPeers', -- 'Monitor.jobs', 'Monitor.connections', and thus the governor has always -- something to do. -- GuardedSkip !(Maybe (Min Time)) -- | 'Guarded' is used to provide an action through 'FirstToFinish' -- synchronisation, possibly with a timeout, to -- the governor main loop. -- | Guarded' !(Maybe (Min Time)) (FirstToFinish m a) -- | 'Guarded' constructor which provides an action, possibly with a timeout, -- to the governor main loop. It hides the use of 'FirstToFinish' -- synchronisation. -- pattern Guarded :: Maybe (Min Time) -> m a -> Guarded m a pattern $bGuarded :: Maybe (Min Time) -> m a -> Guarded m a $mGuarded :: forall r (m :: * -> *) a. Guarded m a -> (Maybe (Min Time) -> m a -> r) -> (Void# -> r) -> r Guarded a b <- Guarded' a (FirstToFinish b) where Guarded Maybe (Min Time) a m a b = Maybe (Min Time) -> FirstToFinish m a -> Guarded m a forall (m :: * -> *) a. Maybe (Min Time) -> FirstToFinish m a -> Guarded m a Guarded' Maybe (Min Time) a (m a -> FirstToFinish m a forall (m :: * -> *) a. m a -> FirstToFinish m a FirstToFinish m a b) {-# COMPLETE GuardedSkip, Guarded #-} -- | 'Guarded' constructor is absorbing in the sense that -- -- > Guarded x y <> a = Guarded x' y' -- > a <> Guarded x y = Guarded x' y' -- -- In the algebraic sense, @'Guarded' (Just minBound) (return x)@ is a left -- absorbing element when "m ~ STM m'@ for some monad @m'@. There is no right -- absorbing element since there is no right absorbing elemnt in @STM m'@. -- -- Ref. [absorbing element](https://en.wikipedia.org/wiki/Absorbing_element) -- instance Alternative m => Semigroup (Guarded m a) where Guarded' Maybe (Min Time) ta FirstToFinish m a a <> :: Guarded m a -> Guarded m a -> Guarded m a <> Guarded' Maybe (Min Time) tb FirstToFinish m a b = Maybe (Min Time) -> FirstToFinish m a -> Guarded m a forall (m :: * -> *) a. Maybe (Min Time) -> FirstToFinish m a -> Guarded m a Guarded' (Maybe (Min Time) ta Maybe (Min Time) -> Maybe (Min Time) -> Maybe (Min Time) forall a. Semigroup a => a -> a -> a <> Maybe (Min Time) tb) (FirstToFinish m a a FirstToFinish m a -> FirstToFinish m a -> FirstToFinish m a forall a. Semigroup a => a -> a -> a <> FirstToFinish m a b) Guarded' Maybe (Min Time) ta FirstToFinish m a a <> GuardedSkip Maybe (Min Time) tb = Maybe (Min Time) -> FirstToFinish m a -> Guarded m a forall (m :: * -> *) a. Maybe (Min Time) -> FirstToFinish m a -> Guarded m a Guarded' (Maybe (Min Time) ta Maybe (Min Time) -> Maybe (Min Time) -> Maybe (Min Time) forall a. Semigroup a => a -> a -> a <> Maybe (Min Time) tb) FirstToFinish m a a GuardedSkip Maybe (Min Time) ta <> Guarded' Maybe (Min Time) tb FirstToFinish m a b = Maybe (Min Time) -> FirstToFinish m a -> Guarded m a forall (m :: * -> *) a. Maybe (Min Time) -> FirstToFinish m a -> Guarded m a Guarded' (Maybe (Min Time) ta Maybe (Min Time) -> Maybe (Min Time) -> Maybe (Min Time) forall a. Semigroup a => a -> a -> a <> Maybe (Min Time) tb) FirstToFinish m a b GuardedSkip Maybe (Min Time) ta <> GuardedSkip Maybe (Min Time) tb = Maybe (Min Time) -> Guarded m a forall (m :: * -> *) a. Maybe (Min Time) -> Guarded m a GuardedSkip (Maybe (Min Time) ta Maybe (Min Time) -> Maybe (Min Time) -> Maybe (Min Time) forall a. Semigroup a => a -> a -> a <> Maybe (Min Time) tb) data Decision m peeraddr peerconn = Decision { -- | A trace event to classify the decision and action Decision m peeraddr peerconn -> TracePeerSelection peeraddr decisionTrace :: TracePeerSelection peeraddr, -- | An updated state to use immediately Decision m peeraddr peerconn -> PeerSelectionState peeraddr peerconn decisionState :: PeerSelectionState peeraddr peerconn, -- | An optional 'Job' to execute asynchronously. This job leads to -- a further 'Decision'. This gives a state update to apply upon -- completion, but also allows chaining further job actions. -- Decision m peeraddr peerconn -> [Job () m (Completion m peeraddr peerconn)] decisionJobs :: [Job () m (Completion m peeraddr peerconn)] } -- | Decision which has access to the current time, rather than the time when -- the governor's loop blocked to make a decision. -- type TimedDecision m peeraddr peerconn = Time -> Decision m peeraddr peerconn -- | Type alias for function types which are used to create governor decisions. -- Allmost all decisions are following this pattern. -- type MkGuardedDecision peeraddr peerconn m = PeerSelectionPolicy peeraddr m -> PeerSelectionState peeraddr peerconn -> Guarded (STM m) (TimedDecision m peeraddr peerconn) newtype Completion m peeraddr peerconn = Completion (PeerSelectionState peeraddr peerconn -> Time -> Decision m peeraddr peerconn) data TracePeerSelection peeraddr = TraceLocalRootPeersChanged (LocalRootPeers peeraddr) (LocalRootPeers peeraddr) | TraceTargetsChanged PeerSelectionTargets PeerSelectionTargets | TracePublicRootsRequest Int Int | TracePublicRootsResults (Set peeraddr) Int DiffTime | TracePublicRootsFailure SomeException Int DiffTime -- | target known peers, actual known peers, peers available for gossip, -- peers selected for gossip | TraceGossipRequests Int Int (Set peeraddr) (Set peeraddr) | TraceGossipResults [(peeraddr, Either SomeException [peeraddr])] --TODO: classify failures -- | target known peers, actual known peers, selected peer | TraceForgetColdPeers Int Int (Set peeraddr) -- | target established, actual established, selected peers | TracePromoteColdPeers Int Int (Set peeraddr) -- | target local established, actual local established, selected peers | TracePromoteColdLocalPeers Int Int (Set peeraddr) -- | target established, actual established, peer, delay until next -- promotion, reason | TracePromoteColdFailed Int Int peeraddr DiffTime SomeException -- | target established, actual established, peer | TracePromoteColdDone Int Int peeraddr -- | target active, actual active, selected peers | TracePromoteWarmPeers Int Int (Set peeraddr) -- | Promote local peers to warm | TracePromoteWarmLocalPeers [(Int, Int)] -- ^ local per-group `(target active, actual active)`, -- only limited to groups which are below their target. (Set peeraddr) -- ^ selected peers -- | target active, actual active, peer, reason | TracePromoteWarmFailed Int Int peeraddr SomeException -- | target active, actual active, peer | TracePromoteWarmDone Int Int peeraddr -- | aborted promotion of a warm peer; likely it was asynchronously -- demoted in the meantime. -- -- target active, actual active, peer | TracePromoteWarmAborted Int Int peeraddr -- | target established, actual established, selected peers | TraceDemoteWarmPeers Int Int (Set peeraddr) -- | target established, actual established, peer, reason | TraceDemoteWarmFailed Int Int peeraddr SomeException -- | target established, actual established, peer | TraceDemoteWarmDone Int Int peeraddr -- | target active, actual active, selected peers | TraceDemoteHotPeers Int Int (Set peeraddr) -- | local per-group (target active, actual active), selected peers | TraceDemoteLocalHotPeers [(Int, Int)] (Set peeraddr) -- | target active, actual active, peer, reason | TraceDemoteHotFailed Int Int peeraddr SomeException -- | target active, actual active, peer | TraceDemoteHotDone Int Int peeraddr | TraceDemoteAsynchronous (Map peeraddr PeerStatus) | TraceGovernorWakeup | TraceChurnWait DiffTime | TraceChurnMode ChurnMode deriving Int -> TracePeerSelection peeraddr -> ShowS [TracePeerSelection peeraddr] -> ShowS TracePeerSelection peeraddr -> String (Int -> TracePeerSelection peeraddr -> ShowS) -> (TracePeerSelection peeraddr -> String) -> ([TracePeerSelection peeraddr] -> ShowS) -> Show (TracePeerSelection peeraddr) forall peeraddr. (Show peeraddr, Ord peeraddr) => Int -> TracePeerSelection peeraddr -> ShowS forall peeraddr. (Show peeraddr, Ord peeraddr) => [TracePeerSelection peeraddr] -> ShowS forall peeraddr. (Show peeraddr, Ord peeraddr) => TracePeerSelection peeraddr -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TracePeerSelection peeraddr] -> ShowS $cshowList :: forall peeraddr. (Show peeraddr, Ord peeraddr) => [TracePeerSelection peeraddr] -> ShowS show :: TracePeerSelection peeraddr -> String $cshow :: forall peeraddr. (Show peeraddr, Ord peeraddr) => TracePeerSelection peeraddr -> String showsPrec :: Int -> TracePeerSelection peeraddr -> ShowS $cshowsPrec :: forall peeraddr. (Show peeraddr, Ord peeraddr) => Int -> TracePeerSelection peeraddr -> ShowS Show data DebugPeerSelection peeraddr where TraceGovernorState :: forall peeraddr peerconn. Show peerconn => Time -- blocked time -> Maybe DiffTime -- wait time -> PeerSelectionState peeraddr peerconn -> DebugPeerSelection peeraddr deriving instance (Ord peeraddr, Show peeraddr) => Show (DebugPeerSelection peeraddr) data ChurnMode = ChurnModeBulkSync | ChurnModeNormal deriving Int -> ChurnMode -> ShowS [ChurnMode] -> ShowS ChurnMode -> String (Int -> ChurnMode -> ShowS) -> (ChurnMode -> String) -> ([ChurnMode] -> ShowS) -> Show ChurnMode forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ChurnMode] -> ShowS $cshowList :: [ChurnMode] -> ShowS show :: ChurnMode -> String $cshow :: ChurnMode -> String showsPrec :: Int -> ChurnMode -> ShowS $cshowsPrec :: Int -> ChurnMode -> ShowS Show