From 913d1849807e5b9e80cbd4afe6bf0272ef037be8 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Mon, 29 May 2023 15:00:59 +0100 Subject: [PATCH] Added WarmValency to local root configuration Refactor Governor established belowTargetLocal job Refactor progress to established target test --- .../src/Ouroboros/Network/Diffusion/P2P.hs | 5 +- .../PeerSelection/Governor/ActivePeers.hs | 22 ++-- .../Governor/EstablishedPeers.hs | 106 ++++++++++-------- .../Network/PeerSelection/Governor/Types.hs | 20 ++-- .../Network/PeerSelection/LocalRootPeers.hs | 76 +++++++++---- .../Network/PeerSelection/RootPeersDNS.hs | 29 +++-- .../Ouroboros/Network/PeerSelection/Simple.hs | 5 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 5 +- .../Test/Ouroboros/Network/PeerSelection.hs | 35 +++--- .../Network/PeerSelection/LocalRootPeers.hs | 30 +++-- .../Network/PeerSelection/RootPeersDNS.hs | 25 ++++- .../test/Test/Ouroboros/Network/Testnet.hs | 48 ++++---- .../Network/Testnet/Simulation/Node.hs | 48 +++++--- 13 files changed, 292 insertions(+), 162 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index 68cb1dfcb80..e50415133c5 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -104,6 +104,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 @@ -220,7 +222,8 @@ 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/ActivePeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs index 02a17c2e713..e7c6b44d1bf 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..0b36bd98398 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) @@ -74,49 +76,48 @@ belowTargetLocal actions localRootPeers, knownPeers, establishedPeers, + inProgressDemoteWarm, 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. + + -- Are there any groups where we can pick members to promote? + , let groupsAvailableToPromote = + [ (numMembersToPromote, membersAvailableToPromote) + | let availableToPromote = + localAvailableToConnect + Set.\\ localEstablishedPeers + Set.\\ localConnectInProgress + Set.\\ localDemoteInProgress + , not (Set.null availableToPromote) + , (WarmValency warmTarget, members, membersLocalEstablished) <- groupsBelowTarget + , let membersAvailableToPromote = Set.intersection members availableToPromote + numMembersToPromote = warmTarget + - Set.size membersLocalEstablished + - 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 +127,35 @@ 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. + LocalRootPeers.keysSet localRootPeers + 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 + localDemoteInProgress = inProgressDemoteWarm + `Set.intersection` localRootPeersSet 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 88b2ea1cc6f..3fa101d4ff6 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,8 @@ 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)], -- | Read the current Peer Sharing willingness value -- @@ -375,7 +377,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 @@ -393,7 +395,7 @@ peerStateToCounters st = PeerSelectionCounters { coldPeers, warmPeers, hotPeers, ] emptyPeerSelectionState :: StdGen - -> [(Int, Int)] + -> [((HotValency, WarmValency), Int)] -> PeerSelectionState peeraddr peerconn emptyPeerSelectionState rng localRoots = PeerSelectionState { @@ -659,8 +661,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 @@ -669,8 +670,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 @@ -690,7 +692,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..e1a8729fe00 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 @@ -29,6 +34,7 @@ import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set +import Data.Coerce (coerce) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) @@ -44,9 +50,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. -- @@ -64,7 +84,13 @@ invariant (LocalRootPeers m 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 +105,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 +117,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,7 +131,7 @@ 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 ] @@ -110,14 +139,20 @@ fromGroups = 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' = if getHotValency h > getWarmValency w' + then coerce w' + else h !acc' = acc <> Map.keysSet g -- | Inverse of 'fromGroups', for the subset of inputs to 'fromGroups' that @@ -125,7 +160,7 @@ 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 ] @@ -162,7 +197,7 @@ clampToLimit totalLimit (LocalRootPeers m gs0) = where limitTotalSize !_ [] = [] - limitTotalSize !n ((t, g) : gs) + limitTotalSize !n ((t@(h, w), g) : gs) -- No space at all! | n == totalLimit @@ -176,5 +211,8 @@ clampToLimit totalLimit (LocalRootPeers m gs0) = -- 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' = if getHotValency h > getWarmValency w' + then coerce w' + else h + = [((h', w'), g')] diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index d458bcd2a8f..2f96da12a8a 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -58,6 +58,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 @@ -70,16 +72,20 @@ 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 @@ -102,9 +108,11 @@ 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 @@ -121,7 +129,8 @@ localRootPeersProvider tracer -- | Loop function that monitors DNS Domain resolution threads and restarts -- if either these threads fail or detects the local configuration changed. -- - loop :: [(Int, Map RelayAccessPoint PeerAdvertise)] -> m Void + loop :: [((HotValency, WarmValency), Map RelayAccessPoint PeerAdvertise)] + -> m Void loop domainsGroups = do traceWith tracer (TraceLocalRootDomains domainsGroups) rr <- dnsAsyncResolverResource resolvConf @@ -278,8 +287,10 @@ 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 a57059e5bea..50522c5642d 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) @@ -57,7 +59,8 @@ withPeerSelectionActions -> (IP -> Socket.PortNumber -> peeraddr) -> 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 f0ee7eb35a0..471812ff723 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,8 @@ 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 cc1fbc58c81..06c547b7469 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs @@ -71,6 +71,8 @@ import Test.Ouroboros.Network.PeerSelection.PeerGraph import Control.Concurrent.Class.MonadSTM.Strict (newTVarIO) 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 (..)) @@ -1971,9 +1973,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) @@ -2022,9 +2024,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 @@ -2116,11 +2125,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 ] @@ -2169,10 +2178,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 @@ -2321,7 +2330,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = 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 -- @@ -2333,7 +2342,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 -- @@ -2344,10 +2353,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..c689a9b32f0 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,19 @@ 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)) +instance Arbitrary HotValency where + arbitrary = HotValency <$> arbitrary + +instance Arbitrary WarmValency where + arbitrary = WarmValency <$> arbitrary instance (Arbitrary peeraddr, Ord peeraddr) => Arbitrary (LocalRootPeers peeraddr) where @@ -114,10 +126,12 @@ prop_arbitrary_LocalRootPeers lrps = numGroups = show (length (LocalRootPeers.toGroups lrps)) sizeGroups = map (show . Set.size . snd) (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 +139,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 40c1982835c..0f695ff1a82 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -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,8 @@ 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 +103,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) @@ -142,6 +145,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 @@ -207,7 +216,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 @@ -462,7 +471,8 @@ selectLocalRootPeersEvents :: [(Time, TestTraceEvent Failure)] selectLocalRootPeersEvents trace = [ (t, e) | (t, RootPeerDNSLocal e) <- trace ] selectLocalRootGroupsEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)] - -> [(Time, [(Int, Map SockAddr PeerAdvertise)])] + -> [(Time, [( (HotValency, WarmValency) + , Map SockAddr PeerAdvertise)])] selectLocalRootGroupsEvents trace = [ (t, e) | (t, TraceLocalRootGroups e) <- trace ] selectLocalRootResultEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)] @@ -511,7 +521,9 @@ 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 @@ -526,7 +538,8 @@ prop_local_preservesIPs mockRoots@(MockRoots localRoots _ _ _) ] -- 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 diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index 4ec60cfde08..0d33b04a31b 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 (..)) @@ -386,17 +388,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) @@ -411,7 +413,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 [])] ] ) ] @@ -542,7 +544,7 @@ prop_peer_selection_trace_coverage defaultBearerInfo diffScript = "TraceForgetColdPeers" peerSelectionTraceMap (TracePromoteColdPeers _ _ _) = "TracePromoteColdPeers" - peerSelectionTraceMap (TracePromoteColdLocalPeers _ _ _) = + peerSelectionTraceMap (TracePromoteColdLocalPeers _ _) = "TracePromoteColdLocalPeers" peerSelectionTraceMap (TracePromoteColdFailed _ _ _ _ _) = "TracePromoteColdFailed" @@ -816,7 +818,7 @@ 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) + [ ((2,2),Map.fromList [ (RelayAccessDomain "test2" 15,DoNotAdvertisePeer) , (RelayAccessDomain "test3" 4,DoAdvertisePeer)]) ] PeerSelectionTargets @@ -856,10 +858,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 [] ]) ] @@ -1532,11 +1534,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 ] @@ -1685,11 +1687,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 ] @@ -1737,20 +1739,20 @@ 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) + localRoots1 = [((2,2), Map.fromList [(ra_addr2, DoNotAdvertisePeer) ,(ra_addr3, DoNotAdvertisePeer)])] - localRoots1' = [(2, Map.fromList [(ra_addr2, DoAdvertisePeer) + localRoots1' = [((2,2), Map.fromList [(ra_addr2, DoAdvertisePeer) ,(ra_addr3, DoAdvertisePeer)])] addr2 = TestAddress (IPAddr (read "10.0.0.2") 3000) @@ -1974,10 +1976,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 @@ -2176,7 +2178,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 9af44ebd18b..16d936dbe51 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,8 @@ 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 +215,8 @@ 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 +253,9 @@ 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,7 +275,8 @@ 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 @@ -318,7 +326,8 @@ 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 @@ -433,7 +442,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 @@ -449,13 +459,19 @@ 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 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 @@ -500,7 +516,8 @@ 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 = delete r l @@ -510,9 +527,12 @@ 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 @@ -688,7 +708,8 @@ 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 @@ -788,7 +809,8 @@ 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