From 49d4326b4788aab1557fadc429692ff96b88087c Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Mon, 29 May 2023 15:00:59 +0100 Subject: [PATCH 1/2] Added WarmValency to local root configuration Refactor Governor established belowTargetLocal job Refactor progress to established target test --- .../src/Ouroboros/Network/Diffusion/P2P.hs | 4 +- .../Network/PeerSelection/Governor.hs | 2 +- .../PeerSelection/Governor/ActivePeers.hs | 22 ++-- .../Governor/EstablishedPeers.hs | 102 +++++++++--------- .../Network/PeerSelection/Governor/Types.hs | 25 +++-- .../Network/PeerSelection/LocalRootPeers.hs | 87 ++++++++++----- .../Network/PeerSelection/RootPeersDNS.hs | 38 +++++-- .../Ouroboros/Network/PeerSelection/Simple.hs | 6 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 6 +- .../Test/Ouroboros/Network/PeerSelection.hs | 35 +++--- .../Network/PeerSelection/LocalRootPeers.hs | 39 +++++-- .../Network/PeerSelection/RootPeersDNS.hs | 69 ++++++++---- .../test/Test/Ouroboros/Network/Testnet.hs | 54 +++++----- .../Network/Testnet/Simulation/Node.hs | 63 ++++++++--- 14 files changed, 355 insertions(+), 197 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index aee019d96cc..bbd0bafa817 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -108,6 +108,8 @@ import Ouroboros.Network.PeerSelection.Governor.Types TracePeerSelection (..), emptyPublicPeerSelectionState) import Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..), withLedgerPeers) +import Ouroboros.Network.PeerSelection.LocalRootPeers (HotValency, + WarmValency) import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.PeerSelection.PeerStateActions @@ -226,7 +228,7 @@ data ArgumentsExtra m = ArgumentsExtra { -- daPeerSelectionTargets :: PeerSelectionTargets - , daReadLocalRootPeers :: STM m [(Int, Map RelayAccessPoint PeerAdvertise)] + , daReadLocalRootPeers :: STM m [(HotValency, WarmValency, Map RelayAccessPoint PeerAdvertise)] , daReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise) -- | Peer's own PeerSharing value. -- diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs index 50e14fdf533..c9dff884d8f 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs @@ -454,7 +454,7 @@ peerSelectionGovernor :: ( Alternative (STM m) -> m Void peerSelectionGovernor tracer debugTracer countersTracer fuzzRng stateVar actions policy = JobPool.withJobPool $ \jobPool -> do - localPeers <- map (\(target, _) -> (target, 0)) + localPeers <- map (\(h, w, _) -> (h, w, 0)) <$> atomically (readLocalRootPeers actions) peerSelectionGovernorLoop tracer diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs index 02a17c2e713..a50f1525be1 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs @@ -26,6 +26,8 @@ import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as Established import Ouroboros.Network.PeerSelection.Governor.Types import Ouroboros.Network.PeerSelection.KnownPeers (setTepidFlag) import qualified Ouroboros.Network.PeerSelection.KnownPeers as KnownPeers +import Ouroboros.Network.PeerSelection.LocalRootPeers + (HotValency (..)) import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers @@ -81,10 +83,10 @@ belowTargetLocal actions Set.\\ inProgressDemoteWarm numPromoteInProgress = Set.size inProgressPromoteWarm , not (Set.null availableToPromote) - , (target, members, membersActive) <- groupsBelowTarget + , (HotValency hotTarget, members, membersActive) <- groupsBelowTarget , let membersAvailableToPromote = Set.intersection members availableToPromote - numMembersToPromote = target + numMembersToPromote = hotTarget - Set.size membersActive - numPromoteInProgress , not (Set.null membersAvailableToPromote) @@ -135,10 +137,10 @@ belowTargetLocal actions = GuardedSkip Nothing where groupsBelowTarget = - [ (target, members, membersActive) - | (target, members) <- LocalRootPeers.toGroupSets localRootPeers + [ (hotValency, members, membersActive) + | (hotValency, _, members) <- LocalRootPeers.toGroupSets localRootPeers , let membersActive = members `Set.intersection` activePeers - , Set.size membersActive < target + , Set.size membersActive < getHotValency hotValency ] belowTargetOther :: forall peeraddr peerconn m. @@ -357,10 +359,10 @@ aboveTargetLocal actions } -- Are there any groups of local peers that are below target? | let groupsAboveTarget = - [ (target, members, membersActive) - | (target, members) <- LocalRootPeers.toGroupSets localRootPeers + [ (hotValency, members, membersActive) + | (hotValency, _, members) <- LocalRootPeers.toGroupSets localRootPeers , let membersActive = members `Set.intersection` activePeers - , Set.size membersActive > target + , Set.size membersActive > getHotValency hotValency ] , not (null groupsAboveTarget) -- We need this detailed check because it is not enough to check we are @@ -376,11 +378,11 @@ aboveTargetLocal actions Set.\\ inProgressDemoteHot numDemoteInProgress = Set.size inProgressDemoteHot , not (Set.null availableToDemote) - , (target, members, membersActive) <- groupsAboveTarget + , (HotValency hotTarget, members, membersActive) <- groupsAboveTarget , let membersAvailableToDemote = Set.intersection members availableToDemote numMembersToDemote = Set.size membersActive - - target + - hotTarget - numDemoteInProgress , not (Set.null membersAvailableToDemote) , numMembersToDemote > 0 diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs index 89fc7364813..075ea379990 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs @@ -23,6 +23,8 @@ import System.Random (randomR) import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers import Ouroboros.Network.PeerSelection.Governor.Types import qualified Ouroboros.Network.PeerSelection.KnownPeers as KnownPeers +import Ouroboros.Network.PeerSelection.LocalRootPeers + (WarmValency (..)) import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers @@ -59,8 +61,8 @@ belowTarget :: forall peeraddr peerconn m. belowTarget = belowTargetLocal <> belowTargetOther --- | For locally configured root peers we have the (implicit) target that they --- should all be warm peers all the time. +-- | For locally configured root peers we have the explicit target that comes from local +-- configuration. -- belowTargetLocal :: forall peeraddr peerconn m. (MonadSTM m, Ord peeraddr) @@ -77,46 +79,44 @@ belowTargetLocal actions inProgressPromoteCold } - -- Are we below the target for number of /local/ root peers that are - -- established? Our target for established local root peers is all of them! - -- However we still don't want to go over the number of established peers - -- or we'll end up in a cycle. - | numLocalEstablishedPeers + numLocalConnectInProgress - < targetNumberOfLocalPeers - - -- Are there any /local/ root peers that are cold we could possibly pick to - -- connect to? We can subtract the local established ones because by - -- definition they are not cold and our invariant is that they are always - -- in the connect set. We can also subtract the in progress ones since they - -- are also already in the connect set and we cannot pick them again. - , numLocalAvailableToConnect - numLocalEstablishedPeers - - numLocalConnectInProgress > 0 - --TODO: switch style to checking if the set is empty + -- Are there any groups of local peers that are below target? + | not (null groupsBelowTarget) + -- We need this detailed check because it is not enough to check we are + -- below an aggregate target. We can be above target for some groups + -- and below for others. We need to take into account peers which are being + -- promoted to Warm, and peers which are being demoted to Cold. + + -- Are there any groups where we can pick members to promote? + , let groupsAvailableToPromote = + [ (numMembersToPromote, membersAvailableToPromote) + | let availableToPromote = + localAvailableToConnect + Set.\\ localEstablishedPeers + Set.\\ localConnectInProgress + , not (Set.null availableToPromote) + , (WarmValency warmTarget, members, membersEstablished) <- groupsBelowTarget + , let membersAvailableToPromote = Set.intersection members availableToPromote + numMembersToPromote = warmTarget + - Set.size membersEstablished + - numLocalConnectInProgress + , not (Set.null membersAvailableToPromote) + , numMembersToPromote > 0 + ] + , not (null groupsAvailableToPromote) = Guarded Nothing $ do - -- The availableToPromote here is non-empty due to the second guard. - -- The known peers map restricted to the connect set is the same size as - -- the connect set (because it is a subset). The establishedPeers is a - -- subset of the connect set and we also know that there is no overlap - -- between inProgressPromoteCold and establishedPeers. QED. - -- - -- The numPeersToPromote is positive based on the first guard. - -- - let availableToPromote :: Set peeraddr - availableToPromote = localAvailableToConnect - Set.\\ localEstablishedPeers - Set.\\ localConnectInProgress + selectedToPromote <- + Set.unions <$> sequence + [ pickPeers st + policyPickColdPeersToPromote + membersAvailableToPromote + numMembersToPromote + | (numMembersToPromote, + membersAvailableToPromote) <- groupsAvailableToPromote ] - numPeersToPromote = targetNumberOfLocalPeers - - numLocalEstablishedPeers - - numLocalConnectInProgress - selectedToPromote <- pickPeers st - policyPickColdPeersToPromote - availableToPromote - numPeersToPromote return $ \_now -> Decision { decisionTrace = [TracePromoteColdLocalPeers - targetNumberOfLocalPeers - numLocalEstablishedPeers + [ (target, Set.size membersEstablished) + | (target, _, membersEstablished) <- groupsBelowTarget ] selectedToPromote], decisionState = st { inProgressPromoteCold = inProgressPromoteCold @@ -126,28 +126,34 @@ belowTargetLocal actions | peer <- Set.toList selectedToPromote ] } - -- If we could connect to a local root peer except that there are no local - -- root peers currently available then we return the next wakeup time (if any) - -- TODO: Note that this may wake up too soon, since it considers non-local - -- known peers too for the purpose of the wakeup time. - | numLocalEstablishedPeers + numLocalConnectInProgress < targetNumberOfLocalPeers + -- If we could promote except that there are no peers currently available + -- then we return the next wakeup time (if any) + | not (null groupsBelowTarget) + , let potentialToPromote = + -- These are local peers that are cold but not ready. + localRootPeersSet + Set.\\ localEstablishedPeers + Set.\\ KnownPeers.availableToConnect knownPeers + , not (Set.null potentialToPromote) = GuardedSkip (Min <$> KnownPeers.minConnectTime knownPeers) | otherwise = GuardedSkip Nothing where - localRootPeersSet = LocalRootPeers.keysSet localRootPeers - targetNumberOfLocalPeers = LocalRootPeers.size localRootPeers + groupsBelowTarget = + [ (warmValency, members, membersEstablished) + | (_, warmValency, members) <- LocalRootPeers.toGroupSets localRootPeers + , let membersEstablished = members `Set.intersection` EstablishedPeers.toSet establishedPeers + , Set.size membersEstablished < getWarmValency warmValency + ] + localRootPeersSet = LocalRootPeers.keysSet localRootPeers localEstablishedPeers = EstablishedPeers.toSet establishedPeers `Set.intersection` localRootPeersSet localAvailableToConnect = KnownPeers.availableToConnect knownPeers `Set.intersection` localRootPeersSet localConnectInProgress = inProgressPromoteCold `Set.intersection` localRootPeersSet - - numLocalEstablishedPeers = Set.size localEstablishedPeers - numLocalAvailableToConnect = Set.size localAvailableToConnect numLocalConnectInProgress = Set.size localConnectInProgress diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index 96b5d1570db..f5bc0bdcb0e 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -67,7 +67,8 @@ import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as Established import Ouroboros.Network.PeerSelection.KnownPeers (KnownPeers) import qualified Ouroboros.Network.PeerSelection.KnownPeers as KnownPeers import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer) -import Ouroboros.Network.PeerSelection.LocalRootPeers (LocalRootPeers) +import Ouroboros.Network.PeerSelection.LocalRootPeers (HotValency, + LocalRootPeers, WarmValency) import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) @@ -202,7 +203,9 @@ data PeerSelectionActions peeraddr peerconn m = PeerSelectionActions { -- It is structured as a collection of (non-overlapping) groups of peers -- where we are supposed to select n from each group. -- - readLocalRootPeers :: STM m [(Int, Map peeraddr PeerAdvertise)], + readLocalRootPeers :: STM m [( HotValency + , WarmValency + , Map peeraddr PeerAdvertise)], readNewInboundConnection :: STM m (peeraddr, PeerSharing), @@ -377,7 +380,7 @@ data PeerSelectionCounters = PeerSelectionCounters { coldPeers :: Int, warmPeers :: Int, hotPeers :: Int, - localRoots :: [(Int, Int)] + localRoots :: [(HotValency, WarmValency, Int)] } deriving (Eq, Show) peerStateToCounters :: Ord peeraddr => PeerSelectionState peeraddr peerconn -> PeerSelectionCounters @@ -389,13 +392,13 @@ peerStateToCounters st = PeerSelectionCounters { coldPeers, warmPeers, hotPeers, warmPeers = Set.size $ establishedPeersSet Set.\\ activePeers st hotPeers = Set.size $ activePeers st localRoots = - [ (target, active) - | (target, members) <- LocalRootPeers.toGroupSets (localRootPeers st) + [ (h, w, active) + | (h, w, members) <- LocalRootPeers.toGroupSets (localRootPeers st) , let active = Set.size (members `Set.intersection` activePeers st) ] emptyPeerSelectionState :: StdGen - -> [(Int, Int)] + -> [(HotValency, WarmValency, Int)] -> PeerSelectionState peeraddr peerconn emptyPeerSelectionState rng localRoots = PeerSelectionState { @@ -662,8 +665,7 @@ data TracePeerSelection 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 + | TracePromoteColdLocalPeers [(WarmValency, Int)] (Set peeraddr) -- promotion, reason | TracePromoteColdFailed Int Int peeraddr DiffTime SomeException -- | target established, actual established, peer @@ -672,8 +674,9 @@ data TracePeerSelection peeraddr = | 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. + [(HotValency, 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 @@ -693,7 +696,7 @@ data TracePeerSelection 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) + | TraceDemoteLocalHotPeers [(HotValency, Int)] (Set peeraddr) -- | target active, actual active, peer, reason | TraceDemoteHotFailed Int Int peeraddr SomeException -- | target active, actual active, peer diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LocalRootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LocalRootPeers.hs index 0d6852f5dd6..89877d8c08a 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LocalRootPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LocalRootPeers.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} module Ouroboros.Network.PeerSelection.LocalRootPeers ( -- * Types LocalRootPeers (..) + , HotValency (..) + , WarmValency (..) -- Export constructors for defining tests. , invariant -- * Basic operations @@ -12,7 +16,8 @@ module Ouroboros.Network.PeerSelection.LocalRootPeers , null , size , member - , target + , hotTarget + , warmTarget , fromGroups , toGroups , toGroupSets @@ -44,9 +49,23 @@ data LocalRootPeers peeraddr = (Map peeraddr PeerAdvertise) -- The groups, but without the associated PeerAdvertise - [(Int, Set peeraddr)] + [(HotValency, WarmValency, Set peeraddr)] deriving Eq +-- | Newtype wrapper representing hot valency value from local root group +-- configuration +-- +newtype HotValency = HotValency { getHotValency :: Int } + deriving (Show, Eq, Ord) + deriving Num via Int + +-- | Newtype wrapper representing warm valency value from local root group +-- configuration +-- +newtype WarmValency = WarmValency { getWarmValency :: Int } + deriving (Show, Eq, Ord) + deriving Num via Int + -- It is an abstract type, so the derived Show is unhelpful, e.g. for replaying -- test cases. -- @@ -57,14 +76,20 @@ invariant :: Ord peeraddr => LocalRootPeers peeraddr -> Bool invariant (LocalRootPeers m gs) = -- The overlapping representations must be consistent - Set.unions [ g | (_, g) <- gs ] == Map.keysSet m + Set.unions [ g | (_, _, g) <- gs ] == Map.keysSet m -- The localRootPeers groups must not overlap with each other - && Map.size m == sum [ Set.size g | (_, g) <- gs ] + && Map.size m == sum [ Set.size g | (_, _, g) <- gs ] -- Individual group targets must be greater than zero and achievable given -- the group sizes. - && and [ 0 < t && t <= Set.size g | (t, g) <- gs ] + -- + -- Also the warm target needs to be greater than or equal to the hot target + && and [ 0 < h + && getWarmValency w >= getHotValency h + -- If warm valency is achievable, by monotonicity, hot valency also is + && getWarmValency w <= Set.size g + | (h, w, g) <- gs ] empty :: LocalRootPeers peeraddr @@ -79,8 +104,11 @@ size (LocalRootPeers m _) = Map.size m member :: Ord peeraddr => peeraddr -> LocalRootPeers peeraddr -> Bool member p (LocalRootPeers m _) = Map.member p m -target :: LocalRootPeers peeraddr -> Int -target (LocalRootPeers _ gs) = sum [ t | (t, _) <- gs ] +hotTarget :: LocalRootPeers peeraddr -> HotValency +hotTarget (LocalRootPeers _ gs) = sum [ h | (h, _, _) <- gs ] + +warmTarget :: LocalRootPeers peeraddr -> WarmValency +warmTarget (LocalRootPeers _ gs) = sum [ w | (_, w, _) <- gs ] toMap :: LocalRootPeers peeraddr -> Map peeraddr PeerAdvertise toMap (LocalRootPeers m _) = m @@ -88,7 +116,7 @@ toMap (LocalRootPeers m _) = m keysSet :: LocalRootPeers peeraddr -> Set peeraddr keysSet (LocalRootPeers m _) = Map.keysSet m -toGroupSets :: LocalRootPeers peeraddr -> [(Int, Set peeraddr)] +toGroupSets :: LocalRootPeers peeraddr -> [(HotValency, WarmValency, Set peeraddr)] toGroupSets (LocalRootPeers _ gs) = gs @@ -102,22 +130,26 @@ toGroupSets (LocalRootPeers _ gs) = gs -- trace a warning about dodgy config. -- fromGroups :: Ord peeraddr - => [(Int, Map peeraddr PeerAdvertise)] + => [(HotValency, WarmValency, Map peeraddr PeerAdvertise)] -> LocalRootPeers peeraddr fromGroups = - (\gs -> let m' = Map.unions [ g | (_, g) <- gs ] - gs' = [ (t, Map.keysSet g) | (t, g) <- gs ] + (\gs -> let m' = Map.unions [ g | (_, _, g) <- gs ] + gs' = [ (h, w, Map.keysSet g) | (h, w, g) <- gs ] in LocalRootPeers m' gs') . establishStructureInvariant Set.empty where - -- The groups must not overlap; have achievable targets; and be non-empty. + -- The groups must not overlap; + -- have achievable targets; + -- Hot targets need to be smaller than or equal to warm targets + -- and be non-empty. establishStructureInvariant !_ [] = [] - establishStructureInvariant !acc ((t, g): gs) - | t' > 0 = (t', g') : establishStructureInvariant acc' gs - | otherwise = establishStructureInvariant acc' gs + establishStructureInvariant !acc ((h, w, g): gs) + | w' > 0 && h' > 0 = (h', w', g') : establishStructureInvariant acc' gs + | otherwise = establishStructureInvariant acc' gs where !g' = g `Map.withoutKeys` acc - !t' = min t (Map.size g') + !w' = min w (WarmValency (Map.size g')) + !h' = HotValency (getHotValency h `min` getWarmValency w') !acc' = acc <> Map.keysSet g -- | Inverse of 'fromGroups', for the subset of inputs to 'fromGroups' that @@ -125,10 +157,10 @@ fromGroups = -- toGroups :: Ord peeraddr => LocalRootPeers peeraddr - -> [(Int, Map peeraddr PeerAdvertise)] + -> [(HotValency, WarmValency, Map peeraddr PeerAdvertise)] toGroups (LocalRootPeers m gs) = - [ (t, Map.fromSet (m Map.!) g) - | (t, g) <- gs ] + [ (h, w, Map.fromSet (m Map.!) g) + | (h, w, g) <- gs ] -- | Limit the size of the root peers collection to fit within given bounds. @@ -157,12 +189,12 @@ clampToLimit :: Ord peeraddr -> LocalRootPeers peeraddr clampToLimit totalLimit (LocalRootPeers m gs0) = let gs' = limitTotalSize 0 gs0 - m' = m `Map.restrictKeys` Set.unions [ g | (_, g) <- gs' ] + m' = m `Map.restrictKeys` Set.unions [ g | (_, _, g) <- gs' ] in LocalRootPeers m' gs' where limitTotalSize !_ [] = [] - limitTotalSize !n ((t, g) : gs) + limitTotalSize !n ((h, w, g) : gs) -- No space at all! | n == totalLimit @@ -171,10 +203,11 @@ clampToLimit totalLimit (LocalRootPeers m gs0) = -- It fits entirely! | let n' = n + Set.size g , n' <= totalLimit - = (t, g) : limitTotalSize n' gs + = (h, w, g) : limitTotalSize n' gs -- We can fit a bit more if we chop it up! | otherwise , let !g' = Set.take (totalLimit - n) g - !t' = min t (Set.size g') - = (t', g') : [] + !w' = min w (WarmValency (Set.size g')) + !h' = HotValency (getHotValency h `min` getWarmValency w') + = [(h', w', g')] diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index d9042a1f8ad..cc44172a834 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -62,6 +62,8 @@ import qualified Network.DNS as DNS import qualified Network.Socket as Socket import Data.Bifunctor (second) +import Ouroboros.Network.PeerSelection.LocalRootPeers (HotValency, + WarmValency) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) import Ouroboros.Network.PeerSelection.RelayAccessPoint import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions @@ -74,16 +76,24 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions -- data TraceLocalRootPeers peerAddr exception = - TraceLocalRootDomains [(Int, Map RelayAccessPoint PeerAdvertise)] + TraceLocalRootDomains [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] -- ^ 'Int' is the configured valency for the local producer groups | TraceLocalRootWaiting DomainAccessPoint DiffTime | TraceLocalRootResult DomainAccessPoint [(IP, DNS.TTL)] - | TraceLocalRootGroups [(Int, Map peerAddr PeerAdvertise)] + | TraceLocalRootGroups [( HotValency + , WarmValency + , Map peerAddr PeerAdvertise)] -- ^ This traces the results of the local root peer provider | TraceLocalRootDNSMap (Map DomainAccessPoint [peerAddr]) -- ^ This traces the results of the domain name resolution - | TraceLocalRootReconfigured [(Int, Map RelayAccessPoint PeerAdvertise)] -- ^ Old value - [(Int, Map RelayAccessPoint PeerAdvertise)] -- ^ New value + | TraceLocalRootReconfigured [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] -- ^ Old value + [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] -- ^ New value | TraceLocalRootFailure DomainAccessPoint (DNSorIOError exception) --TODO: classify DNS errors, config error vs transitory | TraceLocalRootError DomainAccessPoint SomeException @@ -137,9 +147,13 @@ localRootPeersProvider -> (IP -> Socket.PortNumber -> peerAddr) -> DNS.ResolvConf -> DNSActions resolver exception m - -> STM m [(Int, Map RelayAccessPoint PeerAdvertise)] + -> STM m [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] -- ^ input - -> StrictTVar m [(Int, Map peerAddr PeerAdvertise)] + -> StrictTVar m [( HotValency + , WarmValency + , Map peerAddr PeerAdvertise)] -- ^ output 'TVar' -> m Void localRootPeersProvider tracer @@ -160,7 +174,7 @@ localRootPeersProvider tracer -- | Loop function that monitors DNS Domain resolution threads and restarts -- if either these threads fail or detects the local configuration changed. -- - loop :: DNSSemaphore m -> [(Int, Map RelayAccessPoint PeerAdvertise)] -> m Void + loop :: DNSSemaphore m -> [(HotValency, WarmValency, Map RelayAccessPoint PeerAdvertise)] -> m Void loop dnsSemaphore domainsGroups = do traceWith tracer (TraceLocalRootDomains domainsGroups) rr <- dnsAsyncResolverResource resolvConf @@ -169,7 +183,7 @@ localRootPeersProvider tracer -- on them. domains :: [DomainAccessPoint] domains = [ domain - | (_, m) <- domainsGroups + | (_, _, m) <- domainsGroups , (RelayDomainAccessPoint domain, _) <- Map.toList m ] -- Initial DNS Domain Map has all domains entries empty @@ -318,8 +332,12 @@ localRootPeersProvider tracer -- DomainAccessPoint in the static configuration with the values from the -- map. getLocalRootPeersGroups :: Map DomainAccessPoint [peerAddr] - -> [(Int, Map RelayAccessPoint PeerAdvertise)] - -> [(Int, Map peerAddr PeerAdvertise)] + -> [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] + -> [( HotValency + , WarmValency + , Map peerAddr PeerAdvertise)] getLocalRootPeersGroups dnsMap = -- The idea is to traverse the static configuration. Enter each local -- group and check if any of the RelayAccessPoint has a Domain Name. diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Simple.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Simple.hs index 2b1dcd5c59a..add9b7e23ca 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Simple.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Simple.hs @@ -32,6 +32,8 @@ import qualified Network.Socket as Socket import Ouroboros.Network.PeerSelection.Governor.Types import Ouroboros.Network.PeerSelection.LedgerPeers +import Ouroboros.Network.PeerSelection.LocalRootPeers (HotValency, + WarmValency) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) @@ -58,7 +60,9 @@ withPeerSelectionActions -> DNSSemaphore m -> DNSActions resolver exception m -> STM m PeerSelectionTargets - -> STM m [(Int, Map RelayAccessPoint PeerAdvertise)] + -> STM m [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] -- ^ local root peers -> STM m (Map RelayAccessPoint PeerAdvertise) -- ^ public root peers diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs index d79e4093a88..78deeab97ef 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs @@ -105,6 +105,8 @@ import Ouroboros.Network.Testing.Data.Script (Script (..)) import Simulation.Network.Snocket (AddressType (..), FD) +import Ouroboros.Network.PeerSelection.LocalRootPeers (HotValency, + WarmValency) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -147,7 +149,9 @@ data Arguments m = Arguments , aChainSyncEarlyExit :: Bool , aPeerSelectionTargets :: PeerSelectionTargets - , aReadLocalRootPeers :: STM m [(Int, Map RelayAccessPoint PeerAdvertise)] + , aReadLocalRootPeers :: STM m [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] , aReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise) , aOwnPeerSharing :: PeerSharing , aReadUseLedgerAfter :: STM m UseLedgerAfter diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs index 87db1c9cb94..5bb7aee015c 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs @@ -71,6 +71,8 @@ import Control.Concurrent.Class.MonadSTM.Strict (newTVarIO) import Control.Monad.Class.MonadTime.SI import Control.Monad.IOSim import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..)) +import Ouroboros.Network.PeerSelection.LocalRootPeers + (HotValency (..), LocalRootPeers, WarmValency (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -1973,9 +1975,9 @@ prop_governor_target_established_local env = . runGovernorInMockEnvironment $ env - govLocalRootPeersSig :: Signal (Set PeerAddr) + govLocalRootPeersSig :: Signal (LocalRootPeers PeerAddr) govLocalRootPeersSig = - selectGovState (LocalRootPeers.keysSet . Governor.localRootPeers) + selectGovState Governor.localRootPeers events govEstablishedPeersSig :: Signal (Set PeerAddr) @@ -2024,9 +2026,16 @@ prop_governor_target_established_local env = promotionOpportunities :: Signal (Set PeerAddr) promotionOpportunities = (\local established recentFailures inProgressPromoteCold -> - local Set.\\ established - Set.\\ recentFailures - Set.\\ inProgressPromoteCold + Set.unions + [ -- There are no opportunities if we're at or above target + if Set.size groupEstablished >= warmTarget + then Set.empty + else group Set.\\ established + Set.\\ recentFailures + Set.\\ inProgressPromoteCold + | (_, WarmValency warmTarget, group) <- LocalRootPeers.toGroupSets local + , let groupEstablished = group `Set.intersection` established + ] ) <$> govLocalRootPeersSig <*> govEstablishedPeersSig <*> govEstablishedFailuresSig @@ -2118,11 +2127,11 @@ prop_governor_target_active_local_below env = (\local established active recentFailures -> Set.unions [ -- There are no opportunities if we're at or above target - if Set.size groupActive >= target + if Set.size groupActive >= hotTarget then Set.empty else groupEstablished Set.\\ active Set.\\ recentFailures - | (target, group) <- LocalRootPeers.toGroupSets local + | (HotValency hotTarget, _, group) <- LocalRootPeers.toGroupSets local , let groupActive = group `Set.intersection` active groupEstablished = group `Set.intersection` established ] @@ -2171,10 +2180,10 @@ prop_governor_target_active_local_above env = (\local active -> Set.unions [ -- There are no opportunities if we're at or below target - if Set.size groupActive <= target + if Set.size groupActive <= hotTarget then Set.empty else groupActive - | (target, group) <- LocalRootPeers.toGroupSets local + | (HotValency hotTarget, _, group) <- LocalRootPeers.toGroupSets local , let groupActive = group `Set.intersection` active ] ) <$> govLocalRootPeersSig @@ -2326,7 +2335,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do prop_issue_3550 :: Property prop_issue_3550 = prop_governor_target_established_below $ - GovernorMockEnvironment {peerGraph = PeerGraph [(PeerAddr 4,[],GovernorScripts {peerShareScript = Script (Just ([],PeerShareTimeSlow) :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),(PeerAddr 14,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),(PeerAddr 16,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),(PeerAddr 29,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((ToWarm,NoDelay) :| [(ToCold,NoDelay),(Noop,NoDelay)])})], localRootPeers = LocalRootPeers.fromGroups [(1,Map.fromList [(PeerAddr 16,DoAdvertisePeer)]),(1,Map.fromList [(PeerAddr 4,DoAdvertisePeer)])], publicRootPeers = Map.fromList [(PeerAddr 14, (DoNotAdvertisePeer, IsNotLedgerPeer)),(PeerAddr 29, (DoNotAdvertisePeer, IsNotLedgerPeer))], targets = Script ((PeerSelectionTargets {targetNumberOfRootPeers = 1, targetNumberOfKnownPeers = 4, targetNumberOfEstablishedPeers = 4, targetNumberOfActivePeers = 3},NoDelay) :| []), pickKnownPeersForPeerShare = Script (PickFirst :| []), pickColdPeersToPromote = Script (PickFirst :| []), pickWarmPeersToPromote = Script (PickFirst :| []), pickHotPeersToDemote = Script (PickSome (Set.fromList [PeerAddr 29]) :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), peerSharing = PeerSharingPublic} + GovernorMockEnvironment {peerGraph = PeerGraph [(PeerAddr 4,[],GovernorScripts {peerShareScript = Script (Just ([],PeerShareTimeSlow) :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),(PeerAddr 14,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),(PeerAddr 16,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),(PeerAddr 29,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((ToWarm,NoDelay) :| [(ToCold,NoDelay),(Noop,NoDelay)])})], localRootPeers = LocalRootPeers.fromGroups [(1, 1,Map.fromList [(PeerAddr 16,DoAdvertisePeer)]),(1, 1,Map.fromList [(PeerAddr 4,DoAdvertisePeer)])], publicRootPeers = Map.fromList [(PeerAddr 14, (DoNotAdvertisePeer, IsNotLedgerPeer)),(PeerAddr 29, (DoNotAdvertisePeer, IsNotLedgerPeer))], targets = Script ((PeerSelectionTargets {targetNumberOfRootPeers = 1, targetNumberOfKnownPeers = 4, targetNumberOfEstablishedPeers = 4, targetNumberOfActivePeers = 3},NoDelay) :| []), pickKnownPeersForPeerShare = Script (PickFirst :| []), pickColdPeersToPromote = Script (PickFirst :| []), pickWarmPeersToPromote = Script (PickFirst :| []), pickHotPeersToDemote = Script (PickSome (Set.fromList [PeerAddr 29]) :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), peerSharing = PeerSharingPublic} -- | issue #3515 -- @@ -2338,7 +2347,7 @@ prop_issue_3550 = prop_governor_target_established_below $ -- ``` prop_issue_3515 :: Property prop_issue_3515 = prop_governor_nolivelock $ - GovernorMockEnvironment {peerGraph = PeerGraph [(PeerAddr 10,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((ToCold,NoDelay) :| [(Noop,NoDelay)])})], localRootPeers = LocalRootPeers.fromGroups [(1,Map.fromList [(PeerAddr 10,DoAdvertisePeer)])], publicRootPeers = Map.fromList [], targets = Script ((PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},ShortDelay) :| [(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},ShortDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay)]), pickKnownPeersForPeerShare = Script (PickFirst :| []), pickColdPeersToPromote = Script (PickFirst :| []), pickWarmPeersToPromote = Script (PickFirst :| []), pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), peerSharing = PeerSharingPublic} + GovernorMockEnvironment {peerGraph = PeerGraph [(PeerAddr 10,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((ToCold,NoDelay) :| [(Noop,NoDelay)])})], localRootPeers = LocalRootPeers.fromGroups [(1, 1,Map.fromList [(PeerAddr 10,DoAdvertisePeer)])], publicRootPeers = Map.fromList [], targets = Script ((PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},ShortDelay) :| [(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},ShortDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay)]), pickKnownPeersForPeerShare = Script (PickFirst :| []), pickColdPeersToPromote = Script (PickFirst :| []), pickWarmPeersToPromote = Script (PickFirst :| []), pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), peerSharing = PeerSharingPublic} -- | issue #3494 -- @@ -2349,10 +2358,10 @@ prop_issue_3515 = prop_governor_nolivelock $ -- ``` prop_issue_3494 :: Property prop_issue_3494 = prop_governor_nofail $ - GovernorMockEnvironment {peerGraph = PeerGraph [(PeerAddr 64,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((ToCold,NoDelay) :| [(Noop,NoDelay)])})], localRootPeers = LocalRootPeers.fromGroups [(1,Map.fromList [(PeerAddr 64,DoAdvertisePeer)])], publicRootPeers = Map.fromList [], targets = Script ((PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay) :| [(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},ShortDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},ShortDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay)]), pickKnownPeersForPeerShare = Script (PickFirst :| []), pickColdPeersToPromote = Script (PickFirst :| []), pickWarmPeersToPromote = Script (PickFirst :| []), pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), peerSharing = PeerSharingPublic} + GovernorMockEnvironment {peerGraph = PeerGraph [(PeerAddr 64,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((ToCold,NoDelay) :| [(Noop,NoDelay)])})], localRootPeers = LocalRootPeers.fromGroups [(1, 1,Map.fromList [(PeerAddr 64,DoAdvertisePeer)])], publicRootPeers = Map.fromList [], targets = Script ((PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay) :| [(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},ShortDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},ShortDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 1, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay)]), pickKnownPeersForPeerShare = Script (PickFirst :| []), pickColdPeersToPromote = Script (PickFirst :| []), pickWarmPeersToPromote = Script (PickFirst :| []), pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), peerSharing = PeerSharingPublic} -- | issue #3233 -- prop_issue_3233 :: Property prop_issue_3233 = prop_governor_nolivelock $ - GovernorMockEnvironment {peerGraph = PeerGraph [(PeerAddr 4,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((ToCold,NoDelay) :| [(ToCold,NoDelay),(Noop,NoDelay),(ToWarm,NoDelay),(ToCold,NoDelay),(Noop,NoDelay)])}),(PeerAddr 13,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),(PeerAddr 15,[],GovernorScripts {peerShareScript = Script (Just ([],PeerShareTimeSlow) :| []), connectionScript = Script ((Noop,NoDelay) :| [])})], localRootPeers = LocalRootPeers.fromGroups [(1,Map.fromList [(PeerAddr 15,DoAdvertisePeer)]),(1,Map.fromList [(PeerAddr 13,DoAdvertisePeer)])], publicRootPeers = Map.fromList [(PeerAddr 4, (DoNotAdvertisePeer, IsNotLedgerPeer))], targets = Script ((PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay) :| [(PeerSelectionTargets {targetNumberOfRootPeers = 1, targetNumberOfKnownPeers = 3, targetNumberOfEstablishedPeers = 3, targetNumberOfActivePeers = 0},LongDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 1, targetNumberOfKnownPeers = 3, targetNumberOfEstablishedPeers = 3, targetNumberOfActivePeers = 2},NoDelay)]), pickKnownPeersForPeerShare = Script (PickFirst :| []), pickColdPeersToPromote = Script (PickFirst :| []), pickWarmPeersToPromote = Script (PickFirst :| []), pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), peerSharing = PeerSharingPublic} + GovernorMockEnvironment {peerGraph = PeerGraph [(PeerAddr 4,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((ToCold,NoDelay) :| [(ToCold,NoDelay),(Noop,NoDelay),(ToWarm,NoDelay),(ToCold,NoDelay),(Noop,NoDelay)])}),(PeerAddr 13,[],GovernorScripts {peerShareScript = Script (Nothing :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),(PeerAddr 15,[],GovernorScripts {peerShareScript = Script (Just ([],PeerShareTimeSlow) :| []), connectionScript = Script ((Noop,NoDelay) :| [])})], localRootPeers = LocalRootPeers.fromGroups [(1, 1,Map.fromList [(PeerAddr 15,DoAdvertisePeer)]),(1, 1,Map.fromList [(PeerAddr 13,DoAdvertisePeer)])], publicRootPeers = Map.fromList [(PeerAddr 4, (DoNotAdvertisePeer, IsNotLedgerPeer))], targets = Script ((PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay) :| [(PeerSelectionTargets {targetNumberOfRootPeers = 1, targetNumberOfKnownPeers = 3, targetNumberOfEstablishedPeers = 3, targetNumberOfActivePeers = 0},LongDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 0, targetNumberOfEstablishedPeers = 0, targetNumberOfActivePeers = 0},NoDelay),(PeerSelectionTargets {targetNumberOfRootPeers = 1, targetNumberOfKnownPeers = 3, targetNumberOfEstablishedPeers = 3, targetNumberOfActivePeers = 2},NoDelay)]), pickKnownPeersForPeerShare = Script (PickFirst :| []), pickColdPeersToPromote = Script (PickFirst :| []), pickWarmPeersToPromote = Script (PickFirst :| []), pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), peerSharing = PeerSharingPublic} diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs index 26e72f0169b..58e0bb50c70 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE StandaloneDeriving #-} module Test.Ouroboros.Network.PeerSelection.LocalRootPeers ( arbitraryLocalRootPeers , restrictKeys , tests , LocalRootPeers (..) + , HotValency (..) + , WarmValency (..) ) where import Data.Map.Strict (Map) @@ -15,7 +18,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Ouroboros.Network.PeerSelection.LocalRootPeers - (LocalRootPeers (..)) + (HotValency (..), LocalRootPeers (..), WarmValency (..)) import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers import Ouroboros.Network.PeerSelection.Governor @@ -77,10 +80,21 @@ arbitraryLocalRootPeers peeraddrs = do gassignment advertise ] - targets <- mapM (\g -> choose (0, Map.size g)) groups + targets <- mapM (\g -> do + warmValency <- WarmValency <$> choose (0, Map.size g) + hotValency <- HotValency <$> choose (0, getWarmValency warmValency) + return (hotValency, warmValency) + ) groups - return (LocalRootPeers.fromGroups (zip targets groups)) + return (LocalRootPeers.fromGroups (zipWith (\(h, w) g -> (h, w, g)) + targets + groups)) +instance Arbitrary HotValency where + arbitrary = HotValency <$> arbitrary + +instance Arbitrary WarmValency where + arbitrary = WarmValency <$> arbitrary instance (Arbitrary peeraddr, Ord peeraddr) => Arbitrary (LocalRootPeers peeraddr) where @@ -97,7 +111,7 @@ restrictKeys :: Ord peeraddr -> LocalRootPeers peeraddr restrictKeys lrps ks = LocalRootPeers.fromGroups - . map (\(t,g) -> (t, Map.restrictKeys g ks)) + . map (\(h, w, g) -> (h, w, Map.restrictKeys g ks)) . LocalRootPeers.toGroups $ lrps @@ -110,14 +124,17 @@ prop_arbitrary_LocalRootPeers lrps = LocalRootPeers.invariant lrps where + thrd (_, _, c) = c size = renderRanges 5 (LocalRootPeers.size lrps) numGroups = show (length (LocalRootPeers.toGroups lrps)) - sizeGroups = map (show . Set.size . snd) (LocalRootPeers.toGroupSets lrps) + sizeGroups = map (show . Set.size . thrd) (LocalRootPeers.toGroupSets lrps) targets = [ case () of - _ | t == 0 -> "none" - | t == Set.size g -> "all" - | otherwise -> "some" - | (t, g) <- LocalRootPeers.toGroupSets lrps ] + _ | h == 0 -> "none active" + | w == 0 -> "none established" + | h == HotValency (Set.size g) -> "all active" + | w == WarmValency (Set.size g) -> "all established" + | otherwise -> "some" + | (h, w, g) <- LocalRootPeers.toGroupSets lrps ] prop_shrink_LocalRootPeers :: Fixed (LocalRootPeers PeerAddr) -> Property @@ -125,7 +142,7 @@ prop_shrink_LocalRootPeers x = prop_shrink_valid LocalRootPeers.invariant x .&&. prop_shrink_nonequal x -prop_fromGroups :: [(Int, Map PeerAddr PeerAdvertise)] -> Bool +prop_fromGroups :: [(HotValency, WarmValency, Map PeerAddr PeerAdvertise)] -> Bool prop_fromGroups = LocalRootPeers.invariant . LocalRootPeers.fromGroups prop_fromToGroups :: LocalRootPeers PeerAddr -> Bool diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index a38a9763b67..fc8e3fc0d39 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -21,7 +21,7 @@ import Control.Applicative (Alternative) import Control.Monad (forever, replicateM_) import Data.ByteString.Char8 (pack) import Data.Dynamic (Typeable, fromDynamic) -import Data.Foldable (foldl', toList) +import Data.Foldable (foldl') import Data.Functor (void) import Data.IP (fromHostAddress, toIPv4w, toSockAddr) import qualified Data.List.NonEmpty as NonEmpty @@ -48,6 +48,8 @@ import Control.Monad.IOSim import Control.Tracer (Tracer (Tracer), contramap) import Data.List (intercalate) +import Ouroboros.Network.PeerSelection.LocalRootPeers + (HotValency (..), WarmValency (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.Testing.Data.Script (NonEmpty ((:|)), @@ -84,7 +86,9 @@ tests = -- data MockRoots = MockRoots { - mockLocalRootPeers :: [(Int, Map RelayAccessPoint PeerAdvertise)] + mockLocalRootPeers :: [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] , mockLocalRootPeersDNSMap :: Script (Map Domain [(IP, TTL)]) , mockPublicRootPeers :: Map RelayAccessPoint PeerAdvertise , mockPublicRootPeersDNSMap :: Script (Map Domain [(IP, TTL)]) @@ -100,7 +104,7 @@ genMockRoots = sized $ \relaysNumber -> do relaysPerGroup <- chooseEnum (1, relaysNumber `div` 3) localRootRelays <- vectorOf relaysNumber arbitrary - targets <- vectorOf relaysNumber (chooseEnum (1, 5)) + targets <- vectorOf relaysNumber genTargets peerAdvertise <- blocks relaysPerGroup <$> vectorOf relaysNumber (arbitrary @PeerAdvertise) @@ -110,7 +114,7 @@ genMockRoots = sized $ \relaysNumber -> do localRelaysBlocks = blocks relaysPerGroup taggedLocalRelays localRelaysMap = map Map.fromList $ zipWith zip localRelaysBlocks peerAdvertise - localRootPeers = zip targets localRelaysMap + localRootPeers = zipWith (\(h, w) g -> (h, w, g)) targets localRelaysMap localRootDomains = [ domain | RelayAccessDomain domain _ <- taggedLocalRelays ] @@ -142,6 +146,12 @@ genMockRoots = sized $ \relaysNumber -> do mockPublicRootPeersDNSMap = publicRootPeersDNSMap }) where + genTargets :: Gen (HotValency, WarmValency) + genTargets = do + warmValency <- WarmValency <$> chooseEnum (1, 5) + hotValency <- HotValency <$> chooseEnum (1, getWarmValency warmValency) + return (hotValency, warmValency) + genDomainLookupTable :: Int -> [Domain] -> Gen (Map Domain [(IP, TTL)]) genDomainLookupTable ipsPerDomain localRootDomains = do localRootDomainIPs <- blocks ipsPerDomain @@ -186,7 +196,7 @@ instance Arbitrary MockRoots where let lrpDomains = Set.fromList [ domain | RelayAccessDomain domain _ - <- concatMap (Map.keys . snd) lrp ] + <- concatMap (Map.keys . thrd) lrp ] lrpDNSMap = (`Map.restrictKeys` lrpDomains) <$> mockLocalRootPeersDNSMap ] ++ @@ -200,6 +210,8 @@ instance Arbitrary MockRoots where prpDNSMap = (`Map.restrictKeys` prpDomains) <$> mockPublicRootPeersDNSMap ] + where + thrd (_, _, c) = c -- | Used for debugging in GHCI -- @@ -207,7 +219,7 @@ simpleMockRoots :: MockRoots simpleMockRoots = MockRoots localRootPeers dnsMap Map.empty (singletonScript Map.empty) where localRootPeers = - [ ( 2 + [ ( 2, 2 , Map.fromList [ ( RelayAccessAddress (read "192.0.2.1") (read "3333") , DoAdvertisePeer @@ -436,7 +448,7 @@ mockResolveDomainAddresses tracer (MockRoots _ _ publicRootPeers dnsMapScript) -- data TestTraceEvent = RootPeerDNSLocal (TraceLocalRootPeers SockAddr Failure) - | LocalRootPeersResults [(Int, Map SockAddr PeerAdvertise)] + | LocalRootPeersResults [(HotValency, WarmValency, Map SockAddr PeerAdvertise)] | RootPeerDNSPublic TracePublicRootPeers deriving (Show, Typeable) @@ -471,9 +483,15 @@ selectLocalRootPeersEvents :: [(Time, TestTraceEvent)] selectLocalRootPeersEvents trace = [ (t, e) | (t, RootPeerDNSLocal e) <- trace ] selectLocalRootPeersResults :: [(Time, TestTraceEvent)] - -> [(Time, [(Int, Map SockAddr PeerAdvertise)])] + -> [(Time, [(HotValency, WarmValency, Map SockAddr PeerAdvertise)])] selectLocalRootPeersResults trace = [ (t, r) | (t, LocalRootPeersResults r) <- trace ] +selectLocalRootGroupsEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)] + -> [(Time, [( HotValency + , WarmValency + , Map SockAddr PeerAdvertise)])] +selectLocalRootGroupsEvents trace = [ (t, e) | (t, TraceLocalRootGroups e) <- trace ] + selectLocalRootResultEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)] -> [(Time, (Domain, [IP]))] selectLocalRootResultEvents trace = [ (t, (domain, map fst r)) @@ -519,27 +537,32 @@ prop_local_preservesIPs mockRoots@(MockRoots localRoots _ _ _) $ classify (length tr > 0) "Actually testing something" $ checkAll tr where - checkAll :: [(Time, [(Int, Map SockAddr PeerAdvertise)])] -> Property + checkAll :: [(Time, [( HotValency + , WarmValency + , Map SockAddr PeerAdvertise)])] + -> Property checkAll [] = property True checkAll (x:t) = - let + let thrd (_, _, c) = c -- get local root ip addresses - localRootAddresses :: [(a, Map RelayAccessPoint PeerAdvertise)] + localRootAddresses :: [(a, b, Map RelayAccessPoint PeerAdvertise)] -> Set SockAddr localRootAddresses lrp = Set.fromList [ toSockAddr (ip, port) - | (_, m) <- lrp + | (_, _, m) <- lrp , RelayAccessAddress ip port <- Map.keys m ] -- get ip addresses out of LocalRootGroup trace events - localGroupEventsAddresses :: (a, [(Int, Map SockAddr PeerAdvertise)]) + localGroupEventsAddresses :: (a, [( HotValency + , WarmValency + , Map SockAddr PeerAdvertise)]) -> Set SockAddr localGroupEventsAddresses (_, s) = Set.fromList - $ concatMap (Map.keys . snd) - $ toList s + $ concatMap (Map.keys . thrd) + $ s localRootAddressesSet = localRootAddresses localRoots localGroupEventsAddressesSet = localGroupEventsAddresses x @@ -576,8 +599,8 @@ prop_local_preservesGroupNumberAndTargets mockRoots@(MockRoots lrp _ _ _) -- For all LocalRootGroup results, the targets for each group -- should be preserved, i.e. targets are not modified along the -- trace by localRootPeersProvider. - preservesTargets = all (all (\(a, b) -> fst a == fst b)) - [ zip lrp (toList r) | r <- map snd tr ] + preservesTargets = all (all (\((a, b, _), (a', b', _)) -> a == a' && b == b')) + [ zip lrp r | r <- map snd tr ] in label (show $ length tr `div` 100 * 100) $ preservesGroupNumber .&&. preservesTargets @@ -611,7 +634,7 @@ prop_local_resolvesDomainsCorrectly mockRoots@(MockRoots localRoots lDNSMap _ _) localRootDomains = Set.fromList [ domain - | (_, m) <- localRoots + | (_, _, m) <- localRoots , RelayAccessDomain domain _ <- Map.keys m ] @@ -688,12 +711,12 @@ prop_local_updatesDomainsCorrectly mockRoots@(MockRoots lrp _ _ _) let -- Get all IPs present in last group at position -- 'index' ipsAtIndex = Map.keys - $ foldMap snd lrpg + $ foldMap thrd lrpg -- Get all IPs present in current group at position -- 'index' ipsAtIndex' = Map.keys - $ foldMap snd lrpg' + $ foldMap thrd lrpg' arePreserved = all (`elem` ipsAtIndex') ipsAtIndex @@ -706,7 +729,7 @@ prop_local_updatesDomainsCorrectly mockRoots@(MockRoots lrp _ _ _) -- unique domain addresses we can look for -- which group index does a particular domain -- address belongs - index = foldr (\(i, (_, m)) prev -> + index = foldr (\(i, (_, _, m)) prev -> case Map.lookup (RelayDomainAccessPoint da) m of Nothing -> prev Just _ -> i @@ -720,7 +743,7 @@ prop_local_updatesDomainsCorrectly mockRoots@(MockRoots lrp _ _ _) _ -> error "Impossible happened!" ) $ Map.keys - $ snd + $ thrd $ lrpg !! index :: [IP] -- Check if all ips from the previous DNS -- lookup result are present in the current @@ -734,6 +757,8 @@ prop_local_updatesDomainsCorrectly mockRoots@(MockRoots lrp _ _ _) (True, head tr) (tail tr) in property (fst r) + where + thrd (_, _, c) = c -- -- Public Root Peers Provider Tests diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index 9814c204dac..44ce5f9ed19 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs @@ -73,6 +73,8 @@ import Test.Tasty.QuickCheck (testProperty) import Ouroboros.Network.BlockFetch (TraceFetchClientState (..)) import Ouroboros.Network.Mock.ConcreteBlock (BlockHeader) import Ouroboros.Network.NodeToNode (DiffusionMode (..)) +import Ouroboros.Network.PeerSelection.LocalRootPeers + (HotValency (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -388,17 +390,17 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script (Map.fromList [("test2", [read "9022:64c9:4e9b:9281:913f:3fb4:a447:28e", read "d412:ff8f:ce57:932d:b74c:989:48af:73f4", read "0:6:0:3:0:6:0:5"])]) (TestAddress (IPAddr (read "0:7:0:7::") 65533)) NoPeerSharing - [(1,Map.fromList [(RelayAccessDomain "test2" 65535,DoNotAdvertisePeer),(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,DoNotAdvertisePeer)])] + [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,DoNotAdvertisePeer),(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,DoNotAdvertisePeer)])] PeerSelectionTargets {targetNumberOfRootPeers = 0, targetNumberOfKnownPeers = 2, targetNumberOfEstablishedPeers = 2, targetNumberOfActivePeers = 1} (Script (DNSTimeout {getDNSTimeout = 0.239} :| [DNSTimeout {getDNSTimeout = 0.181},DNSTimeout {getDNSTimeout = 0.185},DNSTimeout {getDNSTimeout = 0.14},DNSTimeout {getDNSTimeout = 0.221}])) (Script (DNSLookupDelay {getDNSLookupDelay = 0.067} :| [DNSLookupDelay {getDNSLookupDelay = 0.097},DNSLookupDelay {getDNSLookupDelay = 0.101},DNSLookupDelay {getDNSLookupDelay = 0.096},DNSLookupDelay {getDNSLookupDelay = 0.051}])) Nothing False , [JoinNetwork 1.742857142857 Nothing - ,Reconfigure 6.33333333333 [(1,Map.fromList [(RelayAccessDomain "test2" 65535,DoAdvertisePeer)]) - ,(1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,DoAdvertisePeer)])] - ,Reconfigure 23.88888888888 [(1,Map.fromList []),(1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,DoAdvertisePeer)])] - ,Reconfigure 4.870967741935 [(1,Map.fromList [(RelayAccessDomain "test2" 65535,DoAdvertisePeer)])] + ,Reconfigure 6.33333333333 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,DoAdvertisePeer)]) + ,(1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,DoAdvertisePeer)])] + ,Reconfigure 23.88888888888 [(1,1,Map.fromList []),(1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,DoAdvertisePeer)])] + ,Reconfigure 4.870967741935 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,DoAdvertisePeer)])] ] ) , ( NodeArgs (1) InitiatorAndResponderDiffusionMode (Just 135) @@ -413,7 +415,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script Nothing False , [JoinNetwork 0.183783783783 Nothing - ,Reconfigure 4.533333333333 [(1,Map.fromList [])] + ,Reconfigure 4.533333333333 [(1,1,Map.fromList [])] ] ) ] @@ -546,7 +548,7 @@ prop_peer_selection_trace_coverage defaultBearerInfo diffScript = "TraceForgetColdPeers" peerSelectionTraceMap (TracePromoteColdPeers _ _ _) = "TracePromoteColdPeers" - peerSelectionTraceMap (TracePromoteColdLocalPeers _ _ _) = + peerSelectionTraceMap (TracePromoteColdLocalPeers _ _) = "TracePromoteColdLocalPeers" peerSelectionTraceMap (TracePromoteColdFailed _ _ _ _ _) = "TracePromoteColdFailed" @@ -820,8 +822,8 @@ unit_4191 = prop_diffusion_dns_can_recover absInfo script ]) (TestAddress (IPAddr (read "0.0.1.236") 65527)) NoPeerSharing - [ (2,Map.fromList [ (RelayAccessDomain "test2" 15,DoNotAdvertisePeer) - , (RelayAccessDomain "test3" 4,DoAdvertisePeer)]) + [ (2,2,Map.fromList [ (RelayAccessDomain "test2" 15,DoNotAdvertisePeer) + , (RelayAccessDomain "test3" 4,DoAdvertisePeer)]) ] PeerSelectionTargets { targetNumberOfRootPeers = 6, @@ -860,10 +862,10 @@ unit_4191 = prop_diffusion_dns_can_recover absInfo script , [ JoinNetwork 6.710144927536 Nothing , Kill 7.454545454545 , JoinNetwork 10.763157894736 (Just (TestAddress (IPAddr (read "4.138.119.62") 65527))) - , Reconfigure 0.415384615384 [(1,Map.fromList []) - , (1,Map.fromList [])] - , Reconfigure 15.550561797752 [(1,Map.fromList []) - , (1,Map.fromList [(RelayAccessDomain "test2" 15,DoAdvertisePeer)])] + , Reconfigure 0.415384615384 [(1,1,Map.fromList []) + , (1,1,Map.fromList [])] + , Reconfigure 15.550561797752 [(1,1,Map.fromList []) + , (1,1,Map.fromList [(RelayAccessDomain "test2" 15,DoAdvertisePeer)])] , Reconfigure 82.85714285714 [] ]) ] @@ -1536,11 +1538,11 @@ prop_diffusion_target_active_below defaultBearerInfo diffScript = if isAlive then Set.unions [ -- There are no opportunities if we're at or above target - if Set.size groupActive >= target + if Set.size groupActive >= hotTarget then Set.empty else groupEstablished Set.\\ active Set.\\ recentFailures - | (target, group) <- LocalRootPeers.toGroupSets local + | (HotValency hotTarget, _, group) <- LocalRootPeers.toGroupSets local , let groupActive = group `Set.intersection` active groupEstablished = group `Set.intersection` established ] @@ -1689,11 +1691,11 @@ prop_diffusion_target_active_local_below defaultBearerInfo diffScript = if isAlive then Set.unions [ -- There are no opportunities if we're at or above target - if Set.size groupActive >= target + if Set.size groupActive >= hotTarget then Set.empty else groupEstablished Set.\\ active Set.\\ recentFailures - | (target, group) <- LocalRootPeers.toGroupSets local + | (HotValency hotTarget, _, group) <- LocalRootPeers.toGroupSets local , let groupActive = group `Set.intersection` active groupEstablished = group `Set.intersection` established ] @@ -1741,21 +1743,21 @@ async_demotion_network_script = ] ) , ( common { naAddr = addr2, - naLocalRootPeers = [(1, Map.fromList [(ra_addr1, DoNotAdvertisePeer)])] } + naLocalRootPeers = [(1,1, Map.fromList [(ra_addr1, DoNotAdvertisePeer)])] } , [JoinNetwork 0 (Just addr2), Kill 5, JoinNetwork 20 (Just addr2)] ) , ( common { naAddr = addr3, - naLocalRootPeers = [(1, Map.fromList [(ra_addr1, DoNotAdvertisePeer)])] } + naLocalRootPeers = [(1,1, Map.fromList [(ra_addr1, DoNotAdvertisePeer)])] } , [JoinNetwork 0 (Just addr3)] ) ] where addr1 = TestAddress (IPAddr (read "10.0.0.1") 3000) ra_addr1 = RelayAccessAddress (read "10.0.0.1") 3000 - localRoots1 = [(2, Map.fromList [(ra_addr2, DoNotAdvertisePeer) - ,(ra_addr3, DoNotAdvertisePeer)])] - localRoots1' = [(2, Map.fromList [(ra_addr2, DoAdvertisePeer) - ,(ra_addr3, DoAdvertisePeer)])] + localRoots1 = [(2,2, Map.fromList [(ra_addr2, DoNotAdvertisePeer) + ,(ra_addr3, DoNotAdvertisePeer)])] + localRoots1' = [(2,2, Map.fromList [(ra_addr2, DoAdvertisePeer) + ,(ra_addr3, DoAdvertisePeer)])] addr2 = TestAddress (IPAddr (read "10.0.0.2") 3000) ra_addr2 = RelayAccessAddress (read "10.0.0.2") 3000 @@ -1978,10 +1980,10 @@ prop_diffusion_target_active_local_above defaultBearerInfo diffScript = if isAlive then Set.unions [ -- There are no opportunities if we're at or below target - if Set.size groupActive <= target + if Set.size groupActive <= hotTarget then Set.empty else groupActive - | (target, group) <- LocalRootPeers.toGroupSets local + | (HotValency hotTarget, _, group) <- LocalRootPeers.toGroupSets local , let groupActive = group `Set.intersection` active ] else Set.empty @@ -2180,7 +2182,7 @@ prop_diffusion_cm_valid_transition_order defaultBearerInfo diffScript = prop_unit_4258 :: Property prop_unit_4258 = let bearerInfo = AbsBearerInfo {abiConnectionDelay = NormalDelay, abiInboundAttenuation = NoAttenuation FastSpeed, abiOutboundAttenuation = NoAttenuation FastSpeed, abiInboundWriteFailure = Nothing, abiOutboundWriteFailure = Nothing, abiAcceptFailure = Just (SmallDelay,AbsIOErrResourceExhausted), abiSDUSize = LargeSDU} - diffScript = DiffusionScript (SimArgs 1 10) [(NodeArgs (-3) InitiatorAndResponderDiffusionMode (Just 224) Map.empty (Map.fromList []) (TestAddress (IPAddr (read "0.0.0.4") 9)) NoPeerSharing [(1,Map.fromList [(RelayAccessAddress "0.0.0.8" 65531,DoNotAdvertisePeer)])] PeerSelectionTargets {targetNumberOfRootPeers = 2, targetNumberOfKnownPeers = 5, targetNumberOfEstablishedPeers = 4, targetNumberOfActivePeers = 1} (Script (DNSTimeout {getDNSTimeout = 0.397} :| [DNSTimeout {getDNSTimeout = 0.382},DNSTimeout {getDNSTimeout = 0.321},DNSTimeout {getDNSTimeout = 0.143},DNSTimeout {getDNSTimeout = 0.256},DNSTimeout {getDNSTimeout = 0.142},DNSTimeout {getDNSTimeout = 0.341},DNSTimeout {getDNSTimeout = 0.236}])) (Script (DNSLookupDelay {getDNSLookupDelay = 0.065} :| [])) Nothing False,[JoinNetwork 4.166666666666 Nothing,Kill 0.3,JoinNetwork 1.517857142857 Nothing,Reconfigure 0.245238095238 [],Reconfigure 4.190476190476 []]),(NodeArgs (-5) InitiatorAndResponderDiffusionMode (Just 269) (Map.fromList [(RelayAccessAddress "0.0.0.4" 9, DoNotAdvertisePeer)]) (Map.fromList []) (TestAddress (IPAddr (read "0.0.0.8") 65531)) NoPeerSharing [(1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,DoNotAdvertisePeer)])] PeerSelectionTargets {targetNumberOfRootPeers = 4, targetNumberOfKnownPeers = 5, targetNumberOfEstablishedPeers = 3, targetNumberOfActivePeers = 1} (Script (DNSTimeout {getDNSTimeout = 0.281} :| [DNSTimeout {getDNSTimeout = 0.177},DNSTimeout {getDNSTimeout = 0.164},DNSTimeout {getDNSTimeout = 0.373}])) (Script (DNSLookupDelay {getDNSLookupDelay = 0.133} :| [DNSLookupDelay {getDNSLookupDelay = 0.128},DNSLookupDelay {getDNSLookupDelay = 0.049},DNSLookupDelay {getDNSLookupDelay = 0.058},DNSLookupDelay {getDNSLookupDelay = 0.042},DNSLookupDelay {getDNSLookupDelay = 0.117},DNSLookupDelay {getDNSLookupDelay = 0.064}])) Nothing False,[JoinNetwork 3.384615384615 Nothing,Reconfigure 3.583333333333 [(1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,DoNotAdvertisePeer)])],Kill 15.55555555555,JoinNetwork 30.53333333333 Nothing,Kill 71.11111111111])] + diffScript = DiffusionScript (SimArgs 1 10) [(NodeArgs (-3) InitiatorAndResponderDiffusionMode (Just 224) Map.empty (Map.fromList []) (TestAddress (IPAddr (read "0.0.0.4") 9)) NoPeerSharing [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.8" 65531,DoNotAdvertisePeer)])] PeerSelectionTargets {targetNumberOfRootPeers = 2, targetNumberOfKnownPeers = 5, targetNumberOfEstablishedPeers = 4, targetNumberOfActivePeers = 1} (Script (DNSTimeout {getDNSTimeout = 0.397} :| [DNSTimeout {getDNSTimeout = 0.382},DNSTimeout {getDNSTimeout = 0.321},DNSTimeout {getDNSTimeout = 0.143},DNSTimeout {getDNSTimeout = 0.256},DNSTimeout {getDNSTimeout = 0.142},DNSTimeout {getDNSTimeout = 0.341},DNSTimeout {getDNSTimeout = 0.236}])) (Script (DNSLookupDelay {getDNSLookupDelay = 0.065} :| [])) Nothing False,[JoinNetwork 4.166666666666 Nothing,Kill 0.3,JoinNetwork 1.517857142857 Nothing,Reconfigure 0.245238095238 [],Reconfigure 4.190476190476 []]),(NodeArgs (-5) InitiatorAndResponderDiffusionMode (Just 269) (Map.fromList [(RelayAccessAddress "0.0.0.4" 9, DoNotAdvertisePeer)]) (Map.fromList []) (TestAddress (IPAddr (read "0.0.0.8") 65531)) NoPeerSharing [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,DoNotAdvertisePeer)])] PeerSelectionTargets {targetNumberOfRootPeers = 4, targetNumberOfKnownPeers = 5, targetNumberOfEstablishedPeers = 3, targetNumberOfActivePeers = 1} (Script (DNSTimeout {getDNSTimeout = 0.281} :| [DNSTimeout {getDNSTimeout = 0.177},DNSTimeout {getDNSTimeout = 0.164},DNSTimeout {getDNSTimeout = 0.373}])) (Script (DNSLookupDelay {getDNSLookupDelay = 0.133} :| [DNSLookupDelay {getDNSLookupDelay = 0.128},DNSLookupDelay {getDNSLookupDelay = 0.049},DNSLookupDelay {getDNSLookupDelay = 0.058},DNSLookupDelay {getDNSLookupDelay = 0.042},DNSLookupDelay {getDNSLookupDelay = 0.117},DNSLookupDelay {getDNSLookupDelay = 0.064}])) Nothing False,[JoinNetwork 3.384615384615 Nothing,Reconfigure 3.583333333333 [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,DoNotAdvertisePeer)])],Kill 15.55555555555,JoinNetwork 30.53333333333 Nothing,Kill 71.11111111111])] in prop_diffusion_cm_valid_transition_order bearerInfo diffScript diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs index 3f33b76fec5..93d0391c2f9 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -122,11 +122,14 @@ import Test.Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.BlockFetch (TraceFetchClientState, TraceLabelPeer (..)) +import Ouroboros.Network.PeerSelection.LocalRootPeers + (HotValency (..), WarmValency (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, timeLimitsPeerSharing) +import Test.Ouroboros.Network.PeerSelection.LocalRootPeers () import Test.QuickCheck -- | Diffusion Simulator Arguments @@ -169,7 +172,9 @@ data NodeArgs = -- ^ 'Arguments' 'aIPAddress' value , naPeerSharing :: PeerSharing -- ^ 'Arguments' 'aIPAddress' value - , naLocalRootPeers :: [(Int, Map RelayAccessPoint PeerAdvertise)] + , naLocalRootPeers :: [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] -- ^ 'Arguments' 'LocalRootPeers' values , naLocalSelectionTargets :: PeerSelectionTargets -- ^ 'Arguments' 'aLocalSelectionTargets' value @@ -211,7 +216,9 @@ instance Show NodeArgs where data Command = JoinNetwork DiffTime (Maybe NtNAddr) | Kill DiffTime | Reconfigure DiffTime - [(Int, Map RelayAccessPoint PeerAdvertise)] + [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] deriving Eq instance Show Command where @@ -248,7 +255,10 @@ genIP ips = genIPv6 = IPv6 . toIPv6 <$> replicateM 8 (choose (0,0xffff)) in oneof ([genIPv4, genIPv6] ++ map pure ips) -genCommands :: [(Int, Map RelayAccessPoint PeerAdvertise)] -> Gen [Command] +genCommands :: [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] + -> Gen [Command] genCommands localRoots = sized $ \size -> do port <- fromIntegral <$> (arbitrary :: Gen Int) commands <- vectorOf size (frequency [ (1, JoinNetwork @@ -268,10 +278,12 @@ genCommands localRoots = sized $ \size -> do ]) return (fixupCommands commands) where - subLocalRootPeers :: Gen [(Int, Map RelayAccessPoint PeerAdvertise)] + subLocalRootPeers :: Gen [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] subLocalRootPeers = do subLRP <- sublistOf localRoots - mapM (mapM (fmap Map.fromList . sublistOf . Map.toList)) subLRP + mapM (\(h, w, g) -> (h, w,) <$> (fmap Map.fromList . sublistOf . Map.toList $ g)) subLRP delay = frequency [ (3, genDelayWithPrecision 100) , (2, (* 10) <$> genDelayWithPrecision 100) @@ -318,7 +330,9 @@ genNodeArgs :: [RelayAccessPoint] -> Int -> ( [RelayAccessPoint] -> RelayAccessPoint - -> Gen [(Int, Map RelayAccessPoint PeerAdvertise)] ) + -> Gen [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] ) -> (NtNAddr, RelayAccessPoint) -> Gen NodeArgs genNodeArgs raps minConnected genLocalRootPeers (ntnAddr, rap) = do @@ -429,7 +443,8 @@ genNonHotDiffusionScript = do -- genLocalRootPeers :: [RelayAccessPoint] -> RelayAccessPoint - -> Gen [(Int, Map RelayAccessPoint PeerAdvertise)] + -> Gen [( HotValency, WarmValency + , Map RelayAccessPoint PeerAdvertise)] genLocalRootPeers l r = do nrGroups <- chooseInt (1, 3) -- Remove self from local root peers @@ -445,13 +460,21 @@ genNonHotDiffusionScript = do target <- forM relayGroups (\x -> if null x - then pure 0 - else chooseInt (1, length x)) + then pure (0, 0) + else genTargets (length x)) - let lrpGroups = zip target relayGroupsMap + let lrpGroups = zipWith (\(h, w) g -> (h, w, g)) + target + relayGroupsMap return lrpGroups + genTargets :: Int -> Gen (HotValency, WarmValency) + genTargets l = do + warmValency <- WarmValency <$> chooseEnum (1, l) + hotValency <- HotValency <$> chooseEnum (1, getWarmValency warmValency) + return (hotValency, warmValency) + -- | Multinode Hot Diffusion Simulator Script -- -- Tries to generate a network with at most 2 nodes that should @@ -496,7 +519,9 @@ genHotDiffusionScript = do -- This only generates 1 group genLocalRootPeers :: [RelayAccessPoint] -> RelayAccessPoint - -> Gen [(Int, Map RelayAccessPoint PeerAdvertise)] + -> Gen [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] genLocalRootPeers l r = do -- Remove self from local root peers let newL = filter (/= r) l @@ -506,9 +531,13 @@ genHotDiffusionScript = do let relaysAdv = zip newL peerAdvertise relayGroupsMap = Map.fromList relaysAdv - target = length relaysAdv + warmTarget = length relaysAdv + + hotTarget <- choose (0 , warmTarget) - return [(target, relayGroupsMap)] + return [( HotValency hotTarget + , WarmValency warmTarget + , relayGroupsMap)] instance Arbitrary DiffusionScript where arbitrary = uncurry DiffusionScript @@ -684,7 +713,9 @@ diffusionSimulation -- | Runs a single node according to a list of commands. runCommand :: Maybe ( Async m Void - , StrictTVar m [(Int, Map RelayAccessPoint PeerAdvertise)]) + , StrictTVar m [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)]) -- ^ If the node is running and corresponding local root configuration -- TVar. -> Snocket m (FD m NtNAddr) NtNAddr @@ -784,7 +815,9 @@ diffusionSimulation -> NodeArgs -> Snocket m (FD m NtNAddr) NtNAddr -> Snocket m (FD m NtCAddr) NtCAddr - -> StrictTVar m [(Int, Map RelayAccessPoint PeerAdvertise)] + -> StrictTVar m [( HotValency + , WarmValency + , Map RelayAccessPoint PeerAdvertise)] -> StrictTVar m (Map Domain [(IP, TTL)]) -> m Void runNode SimArgs From 09c22fa0ad135a44d0dbb5c1f778b85e1a5a24a5 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Thu, 29 Jun 2023 11:11:43 +0100 Subject: [PATCH 2/2] Updated CHANGELOG --- ouroboros-network/CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 73461905a7c..cf94b93e323 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -9,6 +9,7 @@ * Added `readNewInboundConnection` field to `PeerSelectionActions` record. * The constructor `FetchDeclineChainNoIntersection` was renamed to `FetchDeclineChainIntersectionTooDeep` (#4541) +- Include Warm Valency for Local Root Peers ### Non-breaking changes