diff --git a/ouroboros-network-api/CHANGELOG.md b/ouroboros-network-api/CHANGELOG.md index 1420d39c12e..2982deeaa2d 100644 --- a/ouroboros-network-api/CHANGELOG.md +++ b/ouroboros-network-api/CHANGELOG.md @@ -12,6 +12,8 @@ ### Non-breaking changes +- Added `IsBootstrapPeer` type + ## 0.5.1.0 -- 2023-08-09 ### Breaking changes diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal index 8dbad6f481e..52914b17417 100644 --- a/ouroboros-network-api/ouroboros-network-api.cabal +++ b/ouroboros-network-api/ouroboros-network-api.cabal @@ -45,6 +45,7 @@ library Ouroboros.Network.PeerSelection.PeerMetric.Type Ouroboros.Network.PeerSelection.PeerAdvertise Ouroboros.Network.PeerSelection.PeerSharing + Ouroboros.Network.PeerSelection.Bootstrap Ouroboros.Network.PeerSelection.RelayAccessPoint default-language: Haskell2010 build-depends: base >=4.14 && <4.19, diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/Bootstrap.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/Bootstrap.hs new file mode 100644 index 00000000000..75303d2ed17 --- /dev/null +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/Bootstrap.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Ouroboros.Network.PeerSelection.Bootstrap (IsBootstrapPeer (..)) where + +import Data.Aeson +import Data.Bool (bool) +import GHC.Generics (Generic) + +-- | Is Bootstrap peer flag distinguishes different kinds of public root peers +-- +data IsBootstrapPeer = IsNotBootstrapPeer + | IsBootstrapPeer + deriving (Eq, Show, Ord, Generic) diff --git a/ouroboros-network-testing/ouroboros-network-testing.cabal b/ouroboros-network-testing/ouroboros-network-testing.cabal index 1621bb38933..d45b8d8ea16 100644 --- a/ouroboros-network-testing/ouroboros-network-testing.cabal +++ b/ouroboros-network-testing/ouroboros-network-testing.cabal @@ -73,7 +73,9 @@ library cborg >=0.2.1 && <0.3, serialise >=0.2 && <0.3, network-mux, - QuickCheck + QuickCheck, + + ouroboros-network-api ghc-options: -Wall -Wno-unticked-promoted-constructors diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index d166cc983fa..c026b5bf633 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -15,6 +15,20 @@ * `demo-chain-sync`: added option parser, added new options. * Preserve `PeerAdvertise` information when connecting to peers. +- Creates `PublicRootPeers` and adds `BootstrapPeers` to + `PublicRootPeers` abstraction. + +- Fix `PeerSelectionState` miss-merge with #4575 + +- Adds `readLedgerStateJudgement` to `PeerSelectionActions` +- Adds `currentLedgerStateJudgement` to `PeerSelectionState` + +- Adjusts `PeerSelectionActions` `requestPublicRootPeers` function to + provide either only ledger peers or bootstrap peers according to the + current ledger state. The same for `requestBigLedgerPeers`. + +- Move Big Ledger Peers to `PublicRootPeers` + ## 0.9.1.0 -- 2023-08-22 ### Breaking changes diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 485b0d28660..1cb1028da76 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -47,6 +47,7 @@ library Ouroboros.Network.Tracers Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSelection.LedgerPeers + Ouroboros.Network.PeerSelection.PublicRootPeers Ouroboros.Network.PeerSelection.PeerMetric Ouroboros.Network.PeerSelection.PeerSelectionActions Ouroboros.Network.PeerSelection.PeerStateActions @@ -170,6 +171,7 @@ test-suite sim-tests Test.Ouroboros.Network.PeerSelection.Instances Test.Ouroboros.Network.PeerSelection.KnownPeers Test.Ouroboros.Network.PeerSelection.LocalRootPeers + Test.Ouroboros.Network.PeerSelection.PublicRootPeers Test.Ouroboros.Network.PeerSelection.RootPeersDNS Test.Ouroboros.Network.PeerSelection.Json Test.Ouroboros.Network.PeerSelection.MockEnvironment diff --git a/ouroboros-network/sim-tests/Main.hs b/ouroboros-network/sim-tests/Main.hs index effe72983c5..1496ba29639 100644 --- a/ouroboros-network/sim-tests/Main.hs +++ b/ouroboros-network/sim-tests/Main.hs @@ -17,6 +17,7 @@ import qualified Test.Ouroboros.Network.PeerSelection.KnownPeers import qualified Test.Ouroboros.Network.PeerSelection.LocalRootPeers import qualified Test.Ouroboros.Network.PeerSelection.MockEnvironment import qualified Test.Ouroboros.Network.PeerSelection.PeerMetric +import qualified Test.Ouroboros.Network.PeerSelection.PublicRootPeers import qualified Test.Ouroboros.Network.PeerSelection.RootPeersDNS import qualified Test.Ouroboros.Network.PeerState (tests) import qualified Test.Ouroboros.Network.Testnet (tests) @@ -40,6 +41,7 @@ tests = , Test.Ouroboros.Network.PeerSelection.Json.tests , Test.Ouroboros.Network.PeerSelection.KnownPeers.tests , Test.Ouroboros.Network.PeerSelection.LocalRootPeers.tests + , Test.Ouroboros.Network.PeerSelection.PublicRootPeers.tests , Test.Ouroboros.Network.PeerSelection.MockEnvironment.tests , Test.Ouroboros.Network.PeerSelection.PeerMetric.tests , Test.Ouroboros.Network.PeerSelection.RootPeersDNS.tests diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs index 1fd865e51b5..6047377ce48 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node.hs @@ -22,7 +22,6 @@ module Test.Ouroboros.Network.Diffusion.Node -- * extra types used by the node , AcceptedConnectionsLimit (..) , DiffusionMode (..) - , LedgerPeersConsensusInterface (..) , PeerAdvertise (..) , PeerSelectionTargets (..) , RelayAccessPoint (..) @@ -77,8 +76,6 @@ import Ouroboros.Network.ExitPolicy (ReconnectDelay (..)) import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Governor (PeerSelectionTargets (..)) -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface (..)) import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetricsConfiguration (..), newPeerMetric) import Ouroboros.Network.PeerSelection.RootPeersDNS @@ -104,7 +101,7 @@ import Ouroboros.Network.Testing.Data.Script (Script (..)) import Simulation.Network.Snocket (AddressType (..), FD) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (UseLedgerPeers) + (LedgerPeersConsensusInterface, UseLedgerPeers) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index 354480df28f..40204a62453 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -77,8 +77,6 @@ import qualified Ouroboros.Network.Mock.Chain as Chain import Ouroboros.Network.Mock.ProducerState import Ouroboros.Network.Mux import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface) import Ouroboros.Network.Util.ShowProxy import Ouroboros.Network.Mock.ConcreteBlock @@ -90,6 +88,8 @@ import qualified Pipes import Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum, chainSyncMiniProtocolNum, keepAliveMiniProtocolNum, peerSharingMiniProtocolNum) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (LedgerPeersConsensusInterface) import qualified Ouroboros.Network.PeerSelection.PeerSharing as PSTypes import Ouroboros.Network.PeerSharing (bracketPeerSharingClient, peerSharingClient, peerSharingServer) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/LedgerPeers.hs index fb523fc80d7..713ccd66cf0 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/LedgerPeers.hs @@ -37,7 +37,9 @@ import Ouroboros.Network.PeerSelection.LedgerPeers import Cardano.Slotting.Slot (SlotNo) import Control.Concurrent.Class.MonadSTM import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (UseLedgerAfter (..), UseLedgerPeers (..)) + (LedgerPeersConsensusInterface (..), + LedgerStateJudgement (..), UseLedgerAfter (..), + UseLedgerPeers (..)) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection.hs index 9d83459cc7a..ce5dd0fc27c 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection.hs @@ -71,10 +71,12 @@ import Test.Ouroboros.Network.PeerSelection.PeerGraph 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.LedgerPeers.Type + (LedgerStateJudgement (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), LocalRootPeers, WarmValency (..)) import Ouroboros.Network.Protocol.PeerSharing.Type @@ -271,7 +273,7 @@ isEmptyEnv GovernorMockEnvironment { } = (LocalRootPeers.null localRootPeers || all (\(t,_) -> targetNumberOfKnownPeers t == 0) targets) - && (Map.null publicRootPeers + && (PublicRootPeers.null publicRootPeers || all (\(t,_) -> targetNumberOfRootPeers t == 0) targets) @@ -534,7 +536,7 @@ envEventCredits (TraceEnvAddPeers peerGraph) = 80 * 5 + length adjacency * 5 PeerGraph adjacency = peerGraph envEventCredits (TraceEnvSetLocalRoots peers) = LocalRootPeers.size peers -envEventCredits (TraceEnvSetPublicRoots peers) = Map.size peers +envEventCredits (TraceEnvSetPublicRoots peers) = PublicRootPeers.size peers envEventCredits TraceEnvRequestPublicRootPeers = 0 envEventCredits TraceEnvRequestBigLedgerPeers = 0 envEventCredits TraceEnvPublicRootTTL = 60 @@ -568,7 +570,7 @@ envEventCredits TraceEnvActivatePeer {} = 0 envEventCredits TraceEnvDeactivatePeer {} = 0 envEventCredits TraceEnvCloseConn {} = 0 - +envEventCredits TraceEnvSetLedgerStateJudgement {} = 30 -- | A coverage property, much like 'prop_governor_nofail' but we look to see @@ -725,7 +727,7 @@ prop_governor_peershare_1hr env@GovernorMockEnvironment { trace = selectPeerSelectionTraceEvents ioSimTrace Just found = knownPeersAfter1Hour trace reachable = peerShareReachablePeers peerGraph - (LocalRootPeers.keysSet localRootPeers <> Map.keysSet publicRootPeers) + (LocalRootPeers.keysSet localRootPeers <> PublicRootPeers.toSet publicRootPeers) in counterexample ( intercalate "\n" . map (ppSimEvent 20 20 20) . takeWhile (\e -> seTime e <= Time (60*60)) @@ -837,7 +839,7 @@ prop_governor_target_root_below env = govPublicRootPeersSig :: Signal (Set PeerAddr) govPublicRootPeersSig = - selectGovState Governor.publicRootPeers events + selectGovState (PublicRootPeers.toSet . Governor.publicRootPeers) events govRootPeersSig :: Signal (Set PeerAddr) govRootPeersSig = Set.union <$> govLocalRootPeersSig <*> govPublicRootPeersSig @@ -893,7 +895,7 @@ prop_governor_target_established_public env = govPublicRootPeersSig :: Signal (Set PeerAddr) govPublicRootPeersSig = - selectGovState Governor.publicRootPeers + selectGovState (PublicRootPeers.toSet . Governor.publicRootPeers) events govEstablishedPeersSig :: Signal (Set PeerAddr) @@ -950,7 +952,7 @@ prop_governor_target_established_big_ledger_peers env = govBigLedgerPeersSig :: Signal (Set PeerAddr) govBigLedgerPeersSig = - selectGovState Governor.bigLedgerPeers + selectGovState (PublicRootPeers.toBigLedgerPeerSet . Governor.publicRootPeers) events govEstablishedPeersSig :: Signal (Set PeerAddr) @@ -1005,7 +1007,7 @@ prop_governor_target_active_public env = govPublicRootPeersSig :: Signal (Set PeerAddr) govPublicRootPeersSig = - selectGovState Governor.publicRootPeers events + selectGovState (PublicRootPeers.toSet . Governor.publicRootPeers) events govActivePeersSig :: Signal (Set PeerAddr) govActivePeersSig = @@ -1641,7 +1643,8 @@ prop_governor_target_known_5_no_shrink_below env = bigLedgerPeersSig :: Signal (Set PeerAddr) bigLedgerPeersSig = - selectGovState (Governor.bigLedgerPeers) events + selectGovState (PublicRootPeers.toBigLedgerPeerSet . Governor.publicRootPeers) + events knownPeersShrinksSig :: Signal (Set PeerAddr) knownPeersShrinksSig = @@ -1781,7 +1784,7 @@ prop_governor_target_known_above env = govPublicRootPeersSig :: Signal (Set PeerAddr) govPublicRootPeersSig = - selectGovState Governor.publicRootPeers events + selectGovState (PublicRootPeers.toSet . Governor.publicRootPeers) events govKnownPeersSig :: Signal (Set PeerAddr) govKnownPeersSig = @@ -2853,9 +2856,10 @@ selectEnvTargets f = -- _governorFindingPublicRoots :: Int -> STM IO (Map RelayAccessPoint PeerAdvertise) + -> STM IO LedgerStateJudgement -> PeerSharing -> IO Void -_governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do +_governorFindingPublicRoots targetNumberOfRootPeers readDomains readLedgerStateJudgement peerSharing = do dnsSemaphore <- newLocalAndPublicRootDNSSemaphore publicRootPeersProvider tracer @@ -2871,7 +2875,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do (mkStdGen 42) publicStateVar actions - { requestPublicRootPeers = + { requestPublicRootPeers = \_ -> transformPeerSelectionAction requestPublicRootPeers } policy where @@ -2885,16 +2889,16 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do readPeerSelectionTargets = return targets, requestPeerShare = \_ _ -> return (PeerSharingResult []), peerConnToPeerSharing = \ps -> ps, - requestPublicRootPeers = \_ -> return (Map.empty, 0), + requestPublicRootPeers = \_ _ -> return (PublicRootPeers.empty, 0), readNewInboundConnection = retry, - requestBigLedgerPeers = \_ -> return (Set.empty, 0), peerStateActions = PeerStateActions { establishPeerConnection = error "establishPeerConnection", monitorPeerConnection = error "monitorPeerConnection", activatePeerConnection = error "activatePeerConnection", deactivatePeerConnection = error "deactivatePeerConnection", closePeerConnection = error "closePeerConnection" - } + }, + readLedgerStateJudgement } targets :: PeerSelectionTargets @@ -2921,7 +2925,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do pickTrivially :: Applicative m => Set SockAddr -> Int -> m (Set SockAddr) pickTrivially m n = pure . Set.take n $ m - transformPeerSelectionAction = fmap (fmap (\(x, y) -> (Map.map (\z -> (z, IsNotLedgerPeer)) x, y))) + transformPeerSelectionAction = fmap (fmap (\(a, b) -> (PublicRootPeers.fromMapAndSet a Set.empty Set.empty, b))) prop_issue_3550 :: Property prop_issue_3550 = prop_governor_target_established_below $ @@ -2932,12 +2936,17 @@ prop_issue_3550 = prop_governor_target_established_below $ (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)) + localRootPeers = LocalRootPeers.fromGroups + [ (1, 1, Map.fromList [(PeerAddr 16,DoAdvertisePeer)]) + , (1, 1, Map.fromList [(PeerAddr 4,DoAdvertisePeer)]) ], - bigLedgerPeers = Set.empty, + publicRootPeers = PublicRootPeers.fromMapAndSet + (Map.fromList [ (PeerAddr 14, DoNotAdvertisePeer) + , (PeerAddr 29, DoNotAdvertisePeer) + ] + ) + Set.empty + Set.empty, targets = Script ((nullPeerSelectionTargets { targetNumberOfRootPeers = 1, @@ -2951,7 +2960,8 @@ prop_issue_3550 = prop_governor_target_established_below $ pickHotPeersToDemote = Script (PickSome (Set.fromList [PeerAddr 29]) :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), - peerSharing = PeerSharingPublic + peerSharing = PeerSharingPublic, + ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| []) } -- | issue #3515 @@ -2971,8 +2981,7 @@ prop_issue_3515 = prop_governor_nolivelock $ connectionScript = Script ((ToCold,NoDelay) :| [(Noop,NoDelay)]) })], localRootPeers = LocalRootPeers.fromGroups [(1,1,Map.fromList [(PeerAddr 10,DoAdvertisePeer)])], - publicRootPeers = Map.fromList [], - bigLedgerPeers = Set.empty, + publicRootPeers = PublicRootPeers.empty, targets = Script (( nullPeerSelectionTargets { targetNumberOfKnownPeers = 1 }, ShortDelay) :| [ ( nullPeerSelectionTargets { targetNumberOfKnownPeers = 1 }, ShortDelay), @@ -2985,7 +2994,8 @@ prop_issue_3515 = prop_governor_nolivelock $ pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), - peerSharing = PeerSharingPublic + peerSharing = PeerSharingPublic, + ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| []) } -- | issue #3494 @@ -3003,8 +3013,7 @@ prop_issue_3494 = prop_governor_nofail $ connectionScript = Script ((ToCold,NoDelay) :| [(Noop,NoDelay)]) })], localRootPeers = LocalRootPeers.fromGroups [(1,1,Map.fromList [(PeerAddr 64,DoAdvertisePeer)])], - publicRootPeers = Map.fromList [], - bigLedgerPeers = Set.empty, + publicRootPeers = PublicRootPeers.empty, targets = Script (( nullPeerSelectionTargets,NoDelay) :| [ (nullPeerSelectionTargets { targetNumberOfKnownPeers = 1 },ShortDelay), @@ -3019,7 +3028,8 @@ prop_issue_3494 = prop_governor_nofail $ pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), - peerSharing = PeerSharingPublic + peerSharing = PeerSharingPublic, + ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| []) } -- | issue #3233 @@ -3041,9 +3051,14 @@ prop_issue_3233 = prop_governor_nolivelock $ (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))], - bigLedgerPeers = Set.empty, + localRootPeers = LocalRootPeers.fromGroups + [ (1, 1, Map.fromList [(PeerAddr 15,DoAdvertisePeer)]) + , (1, 1, Map.fromList [(PeerAddr 13,DoAdvertisePeer)]) + ], + publicRootPeers = PublicRootPeers.fromMapAndSet + (Map.fromList [(PeerAddr 4, DoNotAdvertisePeer)]) + Set.empty + Set.empty, targets = Script ((nullPeerSelectionTargets,NoDelay) :| [(nullPeerSelectionTargets { @@ -3065,7 +3080,8 @@ prop_issue_3233 = prop_governor_nolivelock $ pickHotPeersToDemote = Script (PickFirst :| []), pickWarmPeersToDemote = Script (PickFirst :| []), pickColdPeersToForget = Script (PickFirst :| []), - peerSharing = PeerSharingPublic + peerSharing = PeerSharingPublic, + ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| []) } @@ -3080,7 +3096,7 @@ takeBigLedgerPeers :: (Governor.PeerSelectionState PeerAddr peerconn -> Set PeerAddr) -> Governor.PeerSelectionState PeerAddr peerconn -> Set PeerAddr takeBigLedgerPeers f = - \st -> f st `Set.intersection` Governor.bigLedgerPeers st + \st -> f st `Set.intersection` (PublicRootPeers.toBigLedgerPeerSet . Governor.publicRootPeers) st -- | filter out big ledger peers -- @@ -3088,4 +3104,4 @@ dropBigLedgerPeers :: (Governor.PeerSelectionState PeerAddr peerconn -> Set PeerAddr) -> Governor.PeerSelectionState PeerAddr peerconn -> Set PeerAddr dropBigLedgerPeers f = - \st -> f st Set.\\ Governor.bigLedgerPeers st + \st -> f st Set.\\ (PublicRootPeers.toBigLedgerPeerSet . Governor.publicRootPeers) st diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Instances.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Instances.hs index 3af30b5e6a6..acb5badc441 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Instances.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/Instances.hs @@ -23,6 +23,8 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS (DomainAccessPoint (..), RelayAccessPoint (..)) import qualified Data.IP as IP +import Ouroboros.Network.PeerSelection.Bootstrap + (IsBootstrapPeer (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -65,6 +67,9 @@ instance Arbitrary PeerSharing where instance Arbitrary IsLedgerPeer where arbitrary = elements [ IsLedgerPeer, IsNotLedgerPeer ] +instance Arbitrary IsBootstrapPeer where + arbitrary = elements [ IsNotBootstrapPeer, IsBootstrapPeer ] + instance Arbitrary PeerSelectionTargets where arbitrary = do targetNumberOfKnownPeers <- getNonNegative <$> resize 1000 arbitrary diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs index 502bb1dddb3..d097eb1cbf2 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/KnownPeers.hs @@ -1,6 +1,7 @@ module Test.Ouroboros.Network.PeerSelection.KnownPeers (tests) where import Data.Map (Map) +import Ouroboros.Network.PeerSelection.Bootstrap (IsBootstrapPeer) import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer, RelayAccessPoint) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) @@ -20,7 +21,7 @@ tests = ] prop_insert_idempotent - :: Map RelayAccessPoint (Maybe PeerSharing, Maybe PeerAdvertise, Maybe IsLedgerPeer) + :: Map RelayAccessPoint (Maybe PeerSharing, Maybe PeerAdvertise, Maybe IsLedgerPeer, Maybe IsBootstrapPeer) -> Property prop_insert_idempotent m = let knownPeers = KnownPeers.insert m KnownPeers.empty diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs index ba8ecc71b18..c6e7676ce09 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs @@ -8,6 +8,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} module Test.Ouroboros.Network.PeerSelection.MockEnvironment ( PeerGraph (..) @@ -27,6 +28,7 @@ module Test.Ouroboros.Network.PeerSelection.MockEnvironment , prop_shrinkCarefully_GovernorMockEnvironment ) where +import Data.Bifunctor (first) import Data.Dynamic (fromDynamic) import Data.List (nub) import Data.Map.Strict (Map) @@ -71,13 +73,20 @@ import Test.Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRoo import Test.Ouroboros.Network.PeerSelection.PeerGraph import Test.Ouroboros.Network.ShrinkCarefully -import Ouroboros.Network.PeerSelection.LedgerPeers (IsBigLedgerPeer, - IsLedgerPeer) -import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) +import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..), + LedgerPeersKind (..)) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (IsBigLedgerPeer, LedgerStateJudgement (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.PublicRootPeers + (PublicRootPeers) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import Ouroboros.Network.PeerSelection.Types (PeerStatus (..)) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount, PeerSharingResult (..)) +import Test.Ouroboros.Network.LedgerPeers + (ArbitraryLedgerStateJudgement (..)) +import Test.Ouroboros.Network.PeerSelection.PublicRootPeers () import Test.QuickCheck import Test.Tasty (TestTree, localOption, testGroup) import Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty) @@ -117,8 +126,7 @@ tests = data GovernorMockEnvironment = GovernorMockEnvironment { peerGraph :: PeerGraph, localRootPeers :: LocalRootPeers PeerAddr, - publicRootPeers :: Map PeerAddr (PeerAdvertise, IsLedgerPeer), - bigLedgerPeers :: Set PeerAddr, + publicRootPeers :: PublicRootPeers PeerAddr, targets :: TimedScript PeerSelectionTargets, pickKnownPeersForPeerShare :: PickScript PeerAddr, pickColdPeersToPromote :: PickScript PeerAddr, @@ -126,7 +134,8 @@ data GovernorMockEnvironment = GovernorMockEnvironment { pickHotPeersToDemote :: PickScript PeerAddr, pickWarmPeersToDemote :: PickScript PeerAddr, pickColdPeersToForget :: PickScript PeerAddr, - peerSharing :: PeerSharing + peerSharing :: PeerSharing, + ledgerStateJudgement :: TimedScript LedgerStateJudgement } deriving (Show, Eq) @@ -164,19 +173,17 @@ validGovernorMockEnvironment GovernorMockEnvironment { peerGraph, localRootPeers, publicRootPeers, - bigLedgerPeers, targets } = counterexample "invalid peer graph" (validPeerGraph peerGraph) .&&. counterexample "local roots not a subset of all peers" (LocalRootPeers.keysSet localRootPeers `Set.isSubsetOf` allPeersSet) - .&&. counterexample "public roots not a subset of all peers" - (Map.keysSet publicRootPeers `Set.isSubsetOf` allPeersSet) + .&&. (PublicRootPeers.toSet publicRootPeers `Set.isSubsetOf` allPeersSet) .&&. foldl (\p (a,_) -> p .&&. counterexample ("in sane targets: " ++ show a) (sanePeerSelectionTargets a)) (property True) targets .&&. counterexample "big ledger peers not a subset of public roots" - (bigLedgerPeers `Set.isSubsetOf` (Map.keysSet publicRootPeers)) + (PublicRootPeers.invariant publicRootPeers) where allPeersSet = allPeers peerGraph @@ -197,8 +204,10 @@ runGovernorInMockEnvironment mockEnv = governorAction :: GovernorMockEnvironment -> IOSim s Void governorAction mockEnv = do publicStateVar <- StrictTVar.newTVarIO emptyPublicPeerSelectionState + lsjVar <- playTimedScript (contramap TraceEnvSetLedgerStateJudgement tracerMockEnv) + (ledgerStateJudgement mockEnv) policy <- mockPeerSelectionPolicy mockEnv - actions <- mockPeerSelectionActions tracerMockEnv mockEnv policy + actions <- mockPeerSelectionActions tracerMockEnv mockEnv (readTVar lsjVar) policy exploreRaces -- explore races within the governor _ <- forkIO $ do -- races with the governor should be explored labelThisThread "outbound-governor" @@ -225,7 +234,7 @@ data TraceMockEnv = TraceEnvAddPeers PeerGraph | TraceEnvSetLocalRoots (LocalRootPeers PeerAddr) | TraceEnvRequestPublicRootPeers | TraceEnvRequestBigLedgerPeers - | TraceEnvSetPublicRoots (Map PeerAddr (PeerAdvertise, IsLedgerPeer)) + | TraceEnvSetPublicRoots (PublicRootPeers PeerAddr) | TraceEnvPublicRootTTL | TraceEnvBigLedgerPeersTTL | TraceEnvPeerShareTTL PeerAddr @@ -241,6 +250,8 @@ data TraceMockEnv = TraceEnvAddPeers PeerGraph | TraceEnvPeerShareRequest PeerAddr (Maybe ([PeerAddr], PeerShareTime)) | TraceEnvPeerShareResult PeerAddr [PeerAddr] | TraceEnvPeersStatus (Map PeerAddr PeerStatus) + + | TraceEnvSetLedgerStateJudgement LedgerStateJudgement deriving Show mockPeerSelectionActions :: forall m. @@ -248,6 +259,7 @@ mockPeerSelectionActions :: forall m. Fail.MonadFail m, MonadThrow (STM m), MonadTraceSTM m) => Tracer m TraceMockEnv -> GovernorMockEnvironment + -> STM m LedgerStateJudgement -> PeerSelectionPolicy PeerAddr m -> m (PeerSelectionActions PeerAddr (PeerConn m) m) mockPeerSelectionActions tracer @@ -257,6 +269,7 @@ mockPeerSelectionActions tracer publicRootPeers, targets } + getLedgerStateJudgement policy = do scripts <- Map.fromList <$> sequence @@ -281,7 +294,7 @@ mockPeerSelectionActions tracer traceWith tracer (TraceEnvSetPublicRoots publicRootPeers) --TODO: make dynamic return $ mockPeerSelectionActions' tracer env policy - scripts targetsVar peerConns + scripts targetsVar getLedgerStateJudgement peerConns where proxy :: Proxy m proxy = Proxy @@ -303,13 +316,13 @@ mockPeerSelectionActions' :: forall m. -> PeerSelectionPolicy PeerAddr m -> Map PeerAddr (TVar m PeerShareScript, TVar m ConnectionScript) -> TVar m PeerSelectionTargets + -> STM m LedgerStateJudgement -> TVar m (Map PeerAddr (TVar m PeerStatus)) -> PeerSelectionActions PeerAddr (PeerConn m) m mockPeerSelectionActions' tracer GovernorMockEnvironment { localRootPeers, publicRootPeers, - bigLedgerPeers, peerSharing } PeerSelectionPolicy { @@ -317,13 +330,13 @@ mockPeerSelectionActions' tracer } scripts targetsVar + readLedgerStateJudgement connsVar = PeerSelectionActions { readLocalRootPeers = return (LocalRootPeers.toGroups localRootPeers), peerSharing = peerSharing, peerConnToPeerSharing = \(PeerConn _ ps _) -> ps, requestPublicRootPeers, - requestBigLedgerPeers, readPeerSelectionTargets = readTVar targetsVar, readNewInboundConnection = retry, requestPeerShare, @@ -333,30 +346,36 @@ mockPeerSelectionActions' tracer activatePeerConnection, deactivatePeerConnection, closePeerConnection - } + }, + readLedgerStateJudgement } where -- TODO: make this dynamic - requestPublicRootPeers _n = do + requestPublicRootPeers ledgerPeersKind _n = do traceWith tracer TraceEnvRequestPublicRootPeers let ttl :: DiffTime ttl = 60 _ <- async $ do threadDelay ttl traceWith tracer TraceEnvPublicRootTTL - traceWith tracer (TraceEnvRootsResult (Map.keys publicRootPeers)) - return (publicRootPeers, ttl) - -- TODO: make this dynamic - requestBigLedgerPeers _n = do - traceWith tracer TraceEnvRequestBigLedgerPeers - let ttl :: DiffTime - ttl = 60 - _ <- async $ do - threadDelay ttl - traceWith tracer TraceEnvBigLedgerPeersTTL - traceWith tracer (TraceEnvBigLedgerPeersResult bigLedgerPeers) - return (bigLedgerPeers, ttl) + -- Read the current ledger state judgement + lsj <- atomically readLedgerStateJudgement + -- If the ledger state is YoungEnough we should get ledger peers. + -- Otherwise we should get bootstrap peers + let ( bootstrapPeers , ledgerPeers , bigLedgerPeers) = + ( PublicRootPeers.toBootstrapPeerMap publicRootPeers + , PublicRootPeers.toLedgerPeerSet publicRootPeers + , PublicRootPeers.toBigLedgerPeerSet publicRootPeers + ) + result = case lsj of + YoungEnough -> case ledgerPeersKind of + AllLedgerPeers -> PublicRootPeers.fromMapAndSet Map.empty ledgerPeers Set.empty + BigLedgerPeers -> PublicRootPeers.fromMapAndSet Map.empty Set.empty bigLedgerPeers + TooOld -> PublicRootPeers.fromMapAndSet bootstrapPeers Set.empty Set.empty + + traceWith tracer (TraceEnvRootsResult (Set.toList (PublicRootPeers.toSet result))) + return (result, ttl) requestPeerShare :: PeerSharingAmount -> PeerAddr -> m (PeerSharingResult PeerAddr) requestPeerShare _ addr = do @@ -611,8 +630,7 @@ instance Arbitrary GovernorMockEnvironment where peerGraph <- arbitrary let peersSet = allPeers peerGraph (localRootPeers, - publicRootPeers, - bigLedgerPeers) <- arbitraryRootPeers peersSet + publicRootPeers) <- arbitraryRootPeers peersSet -- But the others are independent targets <- arbitrary @@ -625,12 +643,13 @@ instance Arbitrary GovernorMockEnvironment where pickWarmPeersToDemote <- arbitraryPickScript arbitrarySubsetOfPeers pickColdPeersToForget <- arbitraryPickScript arbitrarySubsetOfPeers peerSharing <- arbitrary + ledgerStateJudgement <- fmap (first getArbitraryLedgerStateJudgement) <$> arbitrary return GovernorMockEnvironment{..} where arbitraryRootPeers :: Set PeerAddr - -> Gen (LocalRootPeers PeerAddr, Map PeerAddr (PeerAdvertise, IsLedgerPeer), Set PeerAddr) + -> Gen (LocalRootPeers PeerAddr, PublicRootPeers PeerAddr) arbitraryRootPeers peers | Set.null peers = - return (LocalRootPeers.empty, Map.empty, Set.empty) + return (LocalRootPeers.empty, PublicRootPeers.empty) arbitraryRootPeers peers = do -- We decide how many we want and then pick randomly. @@ -669,14 +688,23 @@ instance Arbitrary GovernorMockEnvironment where ix == ix' `mod` Map.size publicRoots) $ zip3 [0..] ixs' (Map.keys publicRoots) + let (bootstrapPeers, ledgerPeers) = + span (\case + (_, (IsNotLedgerPeer, _)) -> True + (_, (IsLedgerPeer , _)) -> False + ) (zip publicRootsSet pAdvPLedger) + (bootstrapPeersMap, ledgerPeersSet) = + ( Map.fromList $ map (\(p, (_, pa)) -> (p, pa)) bootstrapPeers + , Set.fromList (map fst ledgerPeers) + ) + localRoots <- arbitraryLocalRootPeers localRootsSet - return (localRoots, publicRoots, bigLedgerPeers) + return (localRoots, PublicRootPeers.fromMapAndSet bootstrapPeersMap ledgerPeersSet bigLedgerPeers) shrink env@GovernorMockEnvironment { peerGraph, localRootPeers, publicRootPeers, - bigLedgerPeers, targets, pickKnownPeersForPeerShare, pickColdPeersToPromote, @@ -684,15 +712,15 @@ instance Arbitrary GovernorMockEnvironment where pickHotPeersToDemote, pickWarmPeersToDemote, pickColdPeersToForget, - peerSharing + peerSharing, + ledgerStateJudgement } = -- Special rule for shrinking the peerGraph because the localRootPeers -- depends on it so has to be updated too. [ env { peerGraph = peerGraph', localRootPeers = LocalRootPeers.restrictKeys localRootPeers nodes', - publicRootPeers = publicRootPeers `Map.restrictKeys` nodes', - bigLedgerPeers = bigLedgerPeers `Set.intersection` nodes' + publicRootPeers = publicRootPeers `PublicRootPeers.intersection` nodes' } | peerGraph' <- shrink peerGraph , let nodes' = allPeers peerGraph' ] @@ -701,7 +729,6 @@ instance Arbitrary GovernorMockEnvironment where peerGraph, localRootPeers = localRootPeers', publicRootPeers = publicRootPeers', - bigLedgerPeers = bigLedgerPeers'', targets = targets', pickKnownPeersForPeerShare = pickKnownPeersForPeerShare', pickColdPeersToPromote = pickColdPeersToPromote', @@ -709,25 +736,27 @@ instance Arbitrary GovernorMockEnvironment where pickHotPeersToDemote = pickHotPeersToDemote', pickWarmPeersToDemote = pickWarmPeersToDemote', pickColdPeersToForget = pickColdPeersToForget', - peerSharing + peerSharing, + ledgerStateJudgement = fmap (first getArbitraryLedgerStateJudgement) + ledgerStateJudgement' } - | (localRootPeers', publicRootPeers', bigLedgerPeers', targets', + | (localRootPeers', publicRootPeers', targets', pickKnownPeersForPeerShare', pickColdPeersToPromote', pickWarmPeersToPromote', pickHotPeersToDemote', pickWarmPeersToDemote', - pickColdPeersToForget') - <- shrink (localRootPeers, publicRootPeers, bigLedgerPeers, targets, + pickColdPeersToForget', + ledgerStateJudgement') + <- shrink (localRootPeers, publicRootPeers, targets, pickKnownPeersForPeerShare, pickColdPeersToPromote, pickWarmPeersToPromote, pickHotPeersToDemote, pickWarmPeersToDemote, - pickColdPeersToForget) - , let bigLedgerPeers'' = bigLedgerPeers' - `Set.intersection` - Map.keysSet publicRootPeers' + pickColdPeersToForget, + fmap (first ArbitraryLedgerStateJudgement) ledgerStateJudgement + ) ] @@ -738,21 +767,22 @@ instance Arbitrary GovernorMockEnvironment where prop_arbitrary_GovernorMockEnvironment :: GovernorMockEnvironment -> Property prop_arbitrary_GovernorMockEnvironment env = tabulate "num root peers" [show (LocalRootPeers.size (localRootPeers env) - + Map.size (publicRootPeers env))] $ + + PublicRootPeers.size (publicRootPeers env))] $ tabulate "num local root peers" [show (LocalRootPeers.size (localRootPeers env))] $ - tabulate "num public root peers" [show (Map.size (publicRootPeers env))] $ + tabulate "num public root peers" [show (PublicRootPeers.size (publicRootPeers env))] $ tabulate "empty root peers" [show $ not emptyGraph && emptyRootPeers] $ tabulate "overlapping local/public roots" [show overlappingRootPeers] $ - tabulate "num big ledger peers" [show (Set.size (bigLedgerPeers env))] $ + tabulate "num big ledger peers" [show (Set.size bigLedgerPeersSet)] $ validGovernorMockEnvironment env where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet (publicRootPeers env) emptyGraph = null g where PeerGraph g = peerGraph env emptyRootPeers = LocalRootPeers.null (localRootPeers env) - && Map.null (publicRootPeers env) + && PublicRootPeers.null (publicRootPeers env) overlappingRootPeers = - not $ Map.null $ - Map.restrictKeys + not $ PublicRootPeers.null $ + PublicRootPeers.intersection (publicRootPeers env) (LocalRootPeers.keysSet (localRootPeers env)) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/PublicRootPeers.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/PublicRootPeers.hs new file mode 100644 index 00000000000..793f54db83f --- /dev/null +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/PeerSelection/PublicRootPeers.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.PeerSelection.PublicRootPeers + ( arbitraryPublicRootPeers + , tests + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set + +import Ouroboros.Network.PeerSelection.PublicRootPeers + (PublicRootPeers) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers + +import Ouroboros.Network.Testing.Utils (prop_shrink_nonequal, + prop_shrink_valid) +import Test.Ouroboros.Network.PeerSelection.Instances + + +import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + + +tests :: TestTree +tests = + testGroup "Ouroboros.Network.PeerSelection" + [ testGroup "PublicRootPeers" + [ testProperty "arbitrary" prop_arbitrary_PublicRootPeers + , testProperty "fromMapAndSet" prop_fromMapAndSet + , testProperty "fromToMapAndSet" prop_fromToMapAndSet + , testProperty "shrink" prop_shrink_PublicRootPeers + ] + ] + +arbitraryPublicRootPeers :: Ord peeraddr + => Set peeraddr -> Gen (PublicRootPeers peeraddr) +arbitraryPublicRootPeers peeraddrs = do + let peersSize = Set.size peeraddrs + (bootstrapPeers, ledgerPeers) = Set.splitAt (peersSize `div` 2) peeraddrs + (normalLedgerPeers, bigLedgerPeers) = Set.splitAt (Set.size ledgerPeers `div` 2) ledgerPeers + + advertiseInfo <- vectorOf (Set.size bootstrapPeers) arbitrary + + let bootstrapPeersMap = Map.fromList + $ zip (Set.toList bootstrapPeers) advertiseInfo + + return (PublicRootPeers.fromMapAndSet bootstrapPeersMap normalLedgerPeers bigLedgerPeers) + +instance (Arbitrary peeraddr, Ord peeraddr) => + Arbitrary (PublicRootPeers peeraddr) where + arbitrary = do + peeraddrs <- scale (`div` 4) arbitrary + arbitraryPublicRootPeers peeraddrs + + shrink prp = + PublicRootPeers.fromMapAndSet <$> shrink (PublicRootPeers.toBootstrapPeerMap prp) + <*> shrink (PublicRootPeers.toLedgerPeerSet prp) + <*> shrink (PublicRootPeers.toBigLedgerPeerSet prp) + +prop_arbitrary_PublicRootPeers :: PublicRootPeers PeerAddr -> Property +prop_arbitrary_PublicRootPeers = property . PublicRootPeers.invariant + + +prop_shrink_PublicRootPeers :: Fixed (PublicRootPeers PeerAddr) -> Property +prop_shrink_PublicRootPeers x = + prop_shrink_valid PublicRootPeers.invariant x + .&&. prop_shrink_nonequal x + +prop_fromMapAndSet :: Map PeerAddr PeerAdvertise -> Set PeerAddr -> Set PeerAddr -> Bool +prop_fromMapAndSet bsp lp = PublicRootPeers.invariant . PublicRootPeers.fromMapAndSet bsp lp + +prop_fromToMapAndSet :: PublicRootPeers PeerAddr -> Bool +prop_fromToMapAndSet prp = + let bsp = PublicRootPeers.toBootstrapPeerMap prp + lp = PublicRootPeers.toLedgerPeerSet prp + blp = PublicRootPeers.toBigLedgerPeerSet prp + in PublicRootPeers.fromMapAndSet bsp lp blp == prp + + diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet.hs index c80d9412612..3bcd059ad50 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet.hs @@ -86,6 +86,7 @@ import Ouroboros.Network.NodeToNode (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..)) @@ -966,7 +967,7 @@ prop_diffusion_target_established_public defaultBearerInfo diffScript = let govPublicRootPeersSig :: Signal (Set NtNAddr) govPublicRootPeersSig = selectDiffusionPeerSelectionState - Governor.publicRootPeers + (PublicRootPeers.toSet . Governor.publicRootPeers) events govEstablishedPeersSig :: Signal (Set NtNAddr) @@ -1060,7 +1061,9 @@ prop_diffusion_target_active_public defaultBearerInfo diffScript = verify_target_active_public events = let govPublicRootPeersSig :: Signal (Set NtNAddr) govPublicRootPeersSig = - selectDiffusionPeerSelectionState Governor.publicRootPeers events + selectDiffusionPeerSelectionState + (PublicRootPeers.toSet . Governor.publicRootPeers) + events govActivePeersSig :: Signal (Set NtNAddr) govActivePeersSig = @@ -1226,7 +1229,8 @@ prop_diffusion_target_active_root defaultBearerInfo diffScript = govPublicRootPeersSig :: Signal (Set NtNAddr) govPublicRootPeersSig = - selectDiffusionPeerSelectionState Governor.publicRootPeers events + selectDiffusionPeerSelectionState + (PublicRootPeers.toSet . Governor.publicRootPeers) events govRootPeersSig :: Signal (Set NtNAddr) govRootPeersSig = Set.union <$> govLocalRootPeersSig @@ -3058,4 +3062,4 @@ dropBigLedgerPeers :: (Governor.PeerSelectionState NtNAddr peerconn -> Set NtNAddr) -> Governor.PeerSelectionState NtNAddr peerconn -> Set NtNAddr dropBigLedgerPeers f = - \st -> f st Set.\\ Governor.bigLedgerPeers st + \st -> f st Set.\\ PublicRootPeers.toBigLedgerPeerSet (Governor.publicRootPeers st) diff --git a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet/Simulation/Node.hs b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet/Simulation/Node.hs index 9e572aded0e..6c17117c2c5 100644 --- a/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/sim-tests/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -80,9 +80,7 @@ import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), PeerSelectionTargets (..), TracePeerSelection) import qualified Ouroboros.Network.PeerSelection.Governor as PeerSelection -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface (..), - LedgerStateJudgement (..), accPoolStake) +import Ouroboros.Network.PeerSelection.LedgerPeers (accPoolStake) import Ouroboros.Network.PeerSelection.PeerStateActions (PeerSelectionActionsTrace) import Ouroboros.Network.PeerSelection.RootPeersDNS @@ -127,7 +125,9 @@ import Data.Typeable (Typeable) import Ouroboros.Network.BlockFetch (TraceFetchClientState, TraceLabelPeer (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (UseLedgerAfter (..), UseLedgerPeers (..)) + (LedgerPeersConsensusInterface (..), + LedgerStateJudgement (..), UseLedgerAfter (..), + UseLedgerPeers (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs index b66b1955699..602497af47a 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs @@ -30,8 +30,9 @@ import qualified Ouroboros.Network.NodeToClient as NodeToClient import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit, ConnectionId, DiffusionMode) import qualified Ouroboros.Network.NodeToNode as NodeToNode -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface, TraceLedgerPeers) +import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (LedgerPeersConsensusInterface) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount) import Ouroboros.Network.Snocket (FileDescriptor) import Ouroboros.Network.Socket (SystemdSocketTracer) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index 914720f1ebf..83ee139dc6d 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -109,7 +109,7 @@ import Ouroboros.Network.PeerSelection.Governor.Types import Ouroboros.Network.PeerSelection.LedgerPeers (LedgerPeersKind, NumberOfPeers, withLedgerPeers) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (UseLedgerPeers) + (LedgerPeersConsensusInterface (..), UseLedgerPeers) import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) import Ouroboros.Network.PeerSelection.PeerSelectionActions import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -630,7 +630,9 @@ runM Interfaces { daApplicationInitiatorMode , daApplicationInitiatorResponderMode , daLocalResponderApplication - , daLedgerPeersCtx + , daLedgerPeersCtx = + daLedgerPeersCtx@LedgerPeersConsensusInterface + { lpGetLedgerStateJudgement } } ApplicationsExtra { daRethrowPolicy @@ -962,6 +964,7 @@ runM Interfaces diLocalAndPublicRootDnsSemaphore (diDnsActions lookupReqs) (readTVar peerSelectionTargetsVar) + lpGetLedgerStateJudgement daReadLocalRootPeers daReadPublicRootPeers daOwnPeerSharing diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs index 5d0bac70f51..f090e17bf23 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs @@ -452,7 +452,7 @@ peerSelectionGovernor :: ( Alternative (STM m) -> m Void peerSelectionGovernor tracer debugTracer countersTracer fuzzRng stateVar actions policy = JobPool.withJobPool $ \jobPool -> do - localPeers <- map (\_ -> (0, 0)) + localPeers <- map (\(w, h, _) -> (w, h)) <$> 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 7619fa2ee58..aa0e7e21448 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs @@ -25,6 +25,7 @@ import System.Random (randomR) import Ouroboros.Network.PeerSelection.Governor.Types import Ouroboros.Network.PeerSelection.LedgerPeers (IsBigLedgerPeer (..)) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers (setTepidFlag) import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers @@ -63,7 +64,7 @@ belowTargetBigLedgerPeers actions policyPickWarmPeersToPromote } st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, establishedPeers, activePeers, inProgressPromoteWarm, @@ -79,7 +80,7 @@ belowTargetBigLedgerPeers actions -- Are there any warm peers we could pick to promote? , let availableToPromote :: Set peeraddr availableToPromote = EstablishedPeers.readyPeers establishedPeers - `Set.intersection` bigLedgerPeers + `Set.intersection` bigLedgerPeersSet Set.\\ activePeers Set.\\ inProgressPromoteWarm Set.\\ inProgressDemoteWarm @@ -113,12 +114,13 @@ belowTargetBigLedgerPeers actions | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers numActiveBigLedgerPeers = Set.size $ activePeers - `Set.intersection` bigLedgerPeers + `Set.intersection` bigLedgerPeersSet numPromoteInProgressBigLedgerPeers = Set.size $ inProgressPromoteWarm - `Set.intersection` bigLedgerPeers + `Set.intersection` bigLedgerPeersSet belowTargetLocal :: forall peeraddr peerconn m. @@ -130,7 +132,7 @@ belowTargetLocal actions policyPickWarmPeersToPromote } st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, localRootPeers, establishedPeers, activePeers, @@ -203,11 +205,12 @@ belowTargetLocal actions Set.\\ activePeers Set.\\ EstablishedPeers.readyPeers establishedPeers , not (Set.null potentialToPromote) - = GuardedSkip (Min <$> EstablishedPeers.minActivateTime establishedPeers (`Set.notMember` bigLedgerPeers)) + = GuardedSkip (Min <$> EstablishedPeers.minActivateTime establishedPeers (`Set.notMember` bigLedgerPeersSet)) | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers groupsBelowTarget = [ (hotValency, members, membersActive) | (hotValency, _, members) <- LocalRootPeers.toGroupSets localRootPeers @@ -224,7 +227,7 @@ belowTargetOther actions policyPickWarmPeersToPromote } st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, localRootPeers, establishedPeers, activePeers, @@ -244,7 +247,7 @@ belowTargetOther actions Set.\\ inProgressPromoteWarm Set.\\ inProgressDemoteWarm Set.\\ LocalRootPeers.keysSet localRootPeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet numPeersToPromote = targetNumberOfActivePeers - numActivePeers - numPromoteInProgress @@ -274,15 +277,16 @@ belowTargetOther actions -- If we could promote except that there are no peers currently available -- then we return the next wakeup time (if any) | numActivePeers + numPromoteInProgress < targetNumberOfActivePeers - = GuardedSkip (Min <$> EstablishedPeers.minActivateTime establishedPeers (`Set.notMember` bigLedgerPeers)) + = GuardedSkip (Min <$> EstablishedPeers.minActivateTime establishedPeers (`Set.notMember` bigLedgerPeersSet)) | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers numActivePeers = Set.size $ activePeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet numPromoteInProgress = Set.size $ inProgressPromoteWarm - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet jobPromoteWarmPeer :: forall peeraddr peerconn m. @@ -314,7 +318,7 @@ jobPromoteWarmPeer PeerSelectionActions{peerStateActions = PeerStateActions {act return $ -- When promotion fails we set the peer as cold. Completion $ \st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, activePeers, establishedPeers, knownPeers, @@ -327,117 +331,118 @@ jobPromoteWarmPeer PeerSelectionActions{peerStateActions = PeerStateActions {act now -> -- TODO: this is a temporary fix, which will by addressed by -- #3460 - if peeraddr `Set.member` inProgressPromoteWarm st - then let establishedPeers' = EstablishedPeers.delete peeraddr - establishedPeers - (fuzz, fuzzRng') = randomR (-2, 2 :: Double) fuzzRng - delay = realToFrac fuzz + policyErrorDelay - knownPeers' = if peeraddr `KnownPeers.member` knownPeers - then KnownPeers.setConnectTimes - (Map.singleton - peeraddr - (delay `addTime` now)) - $ snd $ KnownPeers.incrementFailCount - peeraddr + let bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + in if peeraddr `Set.member` inProgressPromoteWarm st + then let establishedPeers' = EstablishedPeers.delete peeraddr + establishedPeers + (fuzz, fuzzRng') = randomR (-2, 2 :: Double) fuzzRng + delay = realToFrac fuzz + policyErrorDelay + knownPeers' = if peeraddr `KnownPeers.member` knownPeers + then KnownPeers.setConnectTimes + (Map.singleton + peeraddr + (delay `addTime` now)) + $ snd $ KnownPeers.incrementFailCount + peeraddr + knownPeers + else + -- Apparently the governor can remove + -- the peer we failed to promote from the + -- set of known peers before we can process + -- the failure. knownPeers - else - -- Apparently the governor can remove - -- the peer we failed to promote from the - -- set of known peers before we can process - -- the failure. - knownPeers in - Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers - then [TracePromoteWarmBigLedgerPeerFailed - targetNumberOfActiveBigLedgerPeers - (Set.size $ activePeers - `Set.intersection` - bigLedgerPeers) - peeraddr e] - else [TracePromoteWarmFailed - targetNumberOfActivePeers - (Set.size $ activePeers - Set.\\ bigLedgerPeers) - peeraddr e], - decisionState = st { - inProgressPromoteWarm = Set.delete peeraddr - (inProgressPromoteWarm st), - knownPeers = knownPeers', - establishedPeers = establishedPeers', - fuzzRng = fuzzRng' - }, - decisionJobs = [] - } - else Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers - then [TracePromoteWarmBigLedgerPeerAborted - targetNumberOfActiveBigLedgerPeers - (Set.size $ activePeers - `Set.intersection` - bigLedgerPeers) - peeraddr] - else [TracePromoteWarmAborted - targetNumberOfActivePeers - (Set.size $ activePeers - Set.\\ bigLedgerPeers) - peeraddr], - decisionState = st, - decisionJobs = [] - } + in + Decision { + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet + then [TracePromoteWarmBigLedgerPeerFailed + targetNumberOfActiveBigLedgerPeers + (Set.size $ activePeers + `Set.intersection` + bigLedgerPeersSet) + peeraddr e] + else [TracePromoteWarmFailed + targetNumberOfActivePeers + (Set.size $ activePeers + Set.\\ bigLedgerPeersSet) + peeraddr e], + decisionState = st { + inProgressPromoteWarm = Set.delete peeraddr + (inProgressPromoteWarm st), + knownPeers = knownPeers', + establishedPeers = establishedPeers', + fuzzRng = fuzzRng' + }, + decisionJobs = [] + } + else Decision { + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet + then [TracePromoteWarmBigLedgerPeerAborted + targetNumberOfActiveBigLedgerPeers + (Set.size $ activePeers + `Set.intersection` + bigLedgerPeersSet) + peeraddr] + else [TracePromoteWarmAborted + targetNumberOfActivePeers + (Set.size $ activePeers + Set.\\ bigLedgerPeersSet) + peeraddr], + decisionState = st, + decisionJobs = [] + } job :: m (Completion m peeraddr peerconn) job = do activatePeerConnection isBigLedgerPeer peerconn return $ Completion $ \st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, activePeers, targets = PeerSelectionTargets { targetNumberOfActivePeers } } _now -> - - if peeraddr `EstablishedPeers.member` establishedPeers st - then - let activePeers' = Set.insert peeraddr activePeers in - Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers - then [TracePromoteWarmBigLedgerPeerDone - targetNumberOfActivePeers - (Set.size $ activePeers' - `Set.intersection` - bigLedgerPeers) - peeraddr] - else [TracePromoteWarmDone - targetNumberOfActivePeers - (Set.size $ activePeers' - Set.\\ bigLedgerPeers) - peeraddr], - decisionState = st { - activePeers = activePeers', - inProgressPromoteWarm = Set.delete peeraddr - (inProgressPromoteWarm st) - }, - decisionJobs = [] - } - else - Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers - then [TracePromoteWarmBigLedgerPeerAborted - targetNumberOfActivePeers - (Set.size $ activePeers - `Set.intersection` - bigLedgerPeers) - peeraddr] - else [TracePromoteWarmAborted - targetNumberOfActivePeers - (Set.size $ activePeers - Set.\\ bigLedgerPeers) - peeraddr], - decisionState = st, - decisionJobs = [] - } + let bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + in if peeraddr `EstablishedPeers.member` establishedPeers st + then let activePeers' = Set.insert peeraddr activePeers in + Decision { + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet + then [TracePromoteWarmBigLedgerPeerDone + targetNumberOfActivePeers + (Set.size $ activePeers' + `Set.intersection` + bigLedgerPeersSet) + peeraddr] + else [TracePromoteWarmDone + targetNumberOfActivePeers + (Set.size $ activePeers' + Set.\\ bigLedgerPeersSet) + peeraddr], + decisionState = st { + activePeers = activePeers', + inProgressPromoteWarm = Set.delete peeraddr + (inProgressPromoteWarm st) + }, + decisionJobs = [] + } + else + Decision { + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet + then [TracePromoteWarmBigLedgerPeerAborted + targetNumberOfActivePeers + (Set.size $ activePeers + `Set.intersection` + bigLedgerPeersSet) + peeraddr] + else [TracePromoteWarmAborted + targetNumberOfActivePeers + (Set.size $ activePeers + Set.\\ bigLedgerPeersSet) + peeraddr], + decisionState = st, + decisionJobs = [] + } ---------------------------- -- Active peers above target @@ -470,7 +475,7 @@ aboveTargetBigLedgerPeers actions policyPickHotPeersToDemote } st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, localRootPeers, establishedPeers, activePeers, @@ -494,7 +499,7 @@ aboveTargetBigLedgerPeers actions -- peers, e.g. for churn and improved selection, then we'll need an extra -- mechanism to avoid promotion/demotion loops for local peers. , let availableToDemote = activePeers - `Set.intersection` bigLedgerPeers + `Set.intersection` bigLedgerPeersSet Set.\\ inProgressDemoteHot Set.\\ LocalRootPeers.keysSet localRootPeers , not (Set.null availableToDemote) @@ -523,14 +528,15 @@ aboveTargetBigLedgerPeers actions | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers numActiveBigLedgerPeers = Set.size $ activePeers `Set.intersection` - bigLedgerPeers + bigLedgerPeersSet numDemoteInProgressBigLedgerPeers = Set.size $ inProgressDemoteHot `Set.intersection` - bigLedgerPeers + bigLedgerPeersSet aboveTargetLocal :: forall peeraddr peerconn m. @@ -617,7 +623,7 @@ aboveTargetOther actions policyPickHotPeersToDemote } st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, localRootPeers, establishedPeers, activePeers, @@ -643,7 +649,7 @@ aboveTargetOther actions , let availableToDemote = activePeers Set.\\ inProgressDemoteHot Set.\\ LocalRootPeers.keysSet localRootPeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet , not (Set.null availableToDemote) = Guarded Nothing $ do selectedToDemote <- pickPeers st @@ -670,10 +676,11 @@ aboveTargetOther actions | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers numActivePeers = Set.size $ activePeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet numDemoteInProgress = Set.size $ inProgressDemoteHot - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet jobDemoteActivePeer :: forall peeraddr peerconn m. @@ -693,7 +700,7 @@ jobDemoteActivePeer PeerSelectionActions{peerStateActions = PeerStateActions {de -- It's quite bad if demoting fails. The peer is cold so -- remove if from the set of established and hot peers. Completion $ \st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, activePeers, establishedPeers, inProgressDemoteHot, @@ -719,35 +726,36 @@ jobDemoteActivePeer PeerSelectionActions{peerStateActions = PeerStateActions {de $ peerSet establishedPeers' = EstablishedPeers.deletePeers peerSet - establishedPeers in - Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers - then [TraceDemoteHotBigLedgerPeerFailed - targetNumberOfActiveBigLedgerPeers - (Set.size $ activePeers - `Set.intersection` - bigLedgerPeers) - peeraddr e] - else [TraceDemoteHotFailed - targetNumberOfActivePeers - (Set.size $ activePeers - Set.\\ bigLedgerPeers) - peeraddr e], - decisionState = st { - inProgressDemoteHot = inProgressDemoteHot', - fuzzRng = fuzzRng', - activePeers = activePeers', - knownPeers = knownPeers', - establishedPeers = establishedPeers' - }, - decisionJobs = [] - } + establishedPeers + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + in Decision { + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet + then [TraceDemoteHotBigLedgerPeerFailed + targetNumberOfActiveBigLedgerPeers + (Set.size $ activePeers + `Set.intersection` + bigLedgerPeersSet) + peeraddr e] + else [TraceDemoteHotFailed + targetNumberOfActivePeers + (Set.size $ activePeers + Set.\\ bigLedgerPeersSet) + peeraddr e], + decisionState = st { + inProgressDemoteHot = inProgressDemoteHot', + fuzzRng = fuzzRng', + activePeers = activePeers', + knownPeers = knownPeers', + establishedPeers = establishedPeers' + }, + decisionJobs = [] + } job :: m (Completion m peeraddr peerconn) job = do deactivatePeerConnection peerconn return $ Completion $ \st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, activePeers, knownPeers, targets = PeerSelectionTargets { @@ -758,25 +766,26 @@ jobDemoteActivePeer PeerSelectionActions{peerStateActions = PeerStateActions {de _now -> assert (peeraddr `EstablishedPeers.member` establishedPeers st) $ let activePeers' = Set.delete peeraddr activePeers - knownPeers' = setTepidFlag peeraddr knownPeers in - Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers - then [TraceDemoteHotBigLedgerPeerDone - targetNumberOfActiveBigLedgerPeers - (Set.size $ activePeers' - `Set.intersection` - bigLedgerPeers) - peeraddr] - else [TraceDemoteHotDone - targetNumberOfActivePeers - (Set.size $ activePeers' - Set.\\ bigLedgerPeers) - peeraddr], - decisionState = st { - activePeers = activePeers', - knownPeers = knownPeers', - inProgressDemoteHot = Set.delete peeraddr - (inProgressDemoteHot st) - }, - decisionJobs = [] - } + knownPeers' = setTepidFlag peeraddr knownPeers + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + in Decision { + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet + then [TraceDemoteHotBigLedgerPeerDone + targetNumberOfActiveBigLedgerPeers + (Set.size $ activePeers' + `Set.intersection` + bigLedgerPeersSet) + peeraddr] + else [TraceDemoteHotDone + targetNumberOfActivePeers + (Set.size $ activePeers' + Set.\\ bigLedgerPeersSet) + peeraddr], + decisionState = st { + activePeers = activePeers', + knownPeers = knownPeers', + inProgressDemoteHot = Set.delete peeraddr + (inProgressDemoteHot st) + }, + decisionJobs = [] + } diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs index 4e71837991b..5ed2d5c641d 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/BigLedgerPeers.hs @@ -18,10 +18,14 @@ import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI import Ouroboros.Network.PeerSelection.Governor.Types -import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..)) +import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..), + LedgerPeersKind (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.PublicRootPeers + (PublicRootPeers) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PubliRootPeers import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers @@ -35,7 +39,7 @@ belowTarget :: (MonadSTM m, Ord peeraddr) belowTarget actions blockedAt st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, bigLedgerPeerRetryTime, inProgressBigLedgerPeersReq, targets = PeerSelectionTargets { @@ -60,7 +64,7 @@ belowTarget actions | otherwise = GuardedSkip Nothing where - numBigLedgerPeers = Set.size bigLedgerPeers + numBigLedgerPeers = Set.size (PubliRootPeers.toBigLedgerPeerSet publicRootPeers) maxExtraBigLedgerPeers = targetNumberOfKnownBigLedgerPeers - numBigLedgerPeers @@ -70,7 +74,7 @@ jobReqBigLedgerPeers :: forall m peeraddr peerconn. => PeerSelectionActions peeraddr peerconn m -> Int -> Job () m (Completion m peeraddr peerconn) -jobReqBigLedgerPeers PeerSelectionActions{ requestBigLedgerPeers } +jobReqBigLedgerPeers PeerSelectionActions{ requestPublicRootPeers } numExtraAllowed = Job job (return . handler) () "reqBigLedgerPeers" where @@ -104,26 +108,28 @@ jobReqBigLedgerPeers PeerSelectionActions{ requestBigLedgerPeers } job :: m (Completion m peeraddr peerconn) job = do - (results, ttl) <- requestBigLedgerPeers numExtraAllowed + (results, ttl) <- requestPublicRootPeers BigLedgerPeers numExtraAllowed return $ Completion $ \st now -> let -- We make sure the set of big ledger peers disjoint from the sum -- of local, public and ledger peers. - newPeers :: Set peeraddr - newPeers = results Set.\\ LocalRootPeers.keysSet (localRootPeers st) - Set.\\ publicRootPeers st + newPeers :: PublicRootPeers peeraddr + newPeers = results `PublicRootPeers.difference` LocalRootPeers.keysSet (localRootPeers st) + `PublicRootPeers.difference` PublicRootPeers.toSet (publicRootPeers st) - bigLedgerPeers' = bigLedgerPeers st `Set.union` newPeers + newPeersSet = PublicRootPeers.toSet newPeers + publicRootPeers' = publicRootPeers st `PublicRootPeers.merge` newPeers knownPeers' = KnownPeers.insert - (Map.fromSet (\_ -> ( Just NoPeerSharing + (Map.fromSet (\_ -> ( Nothing -- the peer sharing flag will be -- updated once we negotiate -- the connection , Just DoNotAdvertisePeer , Just IsLedgerPeer + , Nothing )) - newPeers) + newPeersSet) (knownPeers st) -- We got a successful response to our request, but if we're still @@ -134,7 +140,7 @@ jobReqBigLedgerPeers PeerSelectionActions{ requestBigLedgerPeers } -- seconds is just over four minutes. bigLedgerPeerBackoffs' :: Int bigLedgerPeerBackoffs' - | Set.null newPeers = (bigLedgerPeerBackoffs st `max` 0) + 1 + | PublicRootPeers.null newPeers = (bigLedgerPeerBackoffs st `max` 0) + 1 | otherwise = 0 bigLedgerPeerRetryDiffTime :: DiffTime @@ -148,11 +154,11 @@ jobReqBigLedgerPeers PeerSelectionActions{ requestBigLedgerPeers } in Decision { decisionTrace = [TraceBigLedgerPeersResults - newPeers + newPeersSet bigLedgerPeerBackoffs' bigLedgerPeerRetryDiffTime], decisionState = st { - bigLedgerPeers = bigLedgerPeers', + publicRootPeers = publicRootPeers', knownPeers = knownPeers', bigLedgerPeerBackoffs = bigLedgerPeerBackoffs', bigLedgerPeerRetryTime = bigLedgerPeerRetryTime, @@ -167,7 +173,7 @@ aboveTarget :: forall m peeraddr peerconn. => MkGuardedDecision peeraddr peerconn m aboveTarget PeerSelectionPolicy {policyPickColdPeersToForget} st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, knownPeers, establishedPeers, inProgressPromoteCold, @@ -182,7 +188,7 @@ aboveTarget PeerSelectionPolicy {policyPickColdPeersToForget} , numKnownBigLedgerPeers > numEstablishedBigLedgerPeers , let availableToForget :: Set peeraddr - availableToForget = bigLedgerPeers + availableToForget = bigLedgerPeersSet Set.\\ establishedBigLedgerPeers Set.\\ inProgressPromoteCold @@ -196,15 +202,15 @@ aboveTarget PeerSelectionPolicy {policyPickColdPeersToForget} numPeersCanForget return $ \_now -> let knownPeers' = KnownPeers.delete selectedToForget knownPeers - bigLedgerPeers' = bigLedgerPeers Set.\\ selectedToForget + publicRootPeers' = PublicRootPeers.difference publicRootPeers selectedToForget in Decision { decisionTrace = [TraceForgetBigLedgerPeers targetNumberOfKnownBigLedgerPeers numKnownBigLedgerPeers selectedToForget ], - decisionState = st { knownPeers = knownPeers', - bigLedgerPeers = bigLedgerPeers' + decisionState = st { knownPeers = knownPeers', + publicRootPeers = publicRootPeers' }, decisionJobs = [] } @@ -212,13 +218,15 @@ aboveTarget PeerSelectionPolicy {policyPickColdPeersToForget} | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + numKnownBigLedgerPeers :: Int - numKnownBigLedgerPeers = Set.size bigLedgerPeers + numKnownBigLedgerPeers = Set.size bigLedgerPeersSet establishedBigLedgerPeers :: Set peeraddr establishedBigLedgerPeers = EstablishedPeers.toSet establishedPeers `Set.intersection` - bigLedgerPeers + bigLedgerPeersSet numEstablishedBigLedgerPeers :: Int numEstablishedBigLedgerPeers = Set.size establishedBigLedgerPeers diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs index 7b2eeb444e7..0904e4887fc 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs @@ -24,6 +24,7 @@ import Ouroboros.Network.PeerSelection.Governor.Types import Ouroboros.Network.PeerSelection.LedgerPeers (IsBigLedgerPeer (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers @@ -76,8 +77,8 @@ belowTargetLocal actions policyPickColdPeersToPromote } st@PeerSelectionState { - bigLedgerPeers, localRootPeers, + publicRootPeers, knownPeers, establishedPeers, inProgressPromoteCold @@ -140,7 +141,7 @@ belowTargetLocal actions Set.\\ localEstablishedPeers Set.\\ KnownPeers.availableToConnect knownPeers , not (Set.null potentialToPromote) - = GuardedSkip (Min <$> KnownPeers.minConnectTime knownPeers (`Set.notMember` bigLedgerPeers)) + = GuardedSkip (Min <$> KnownPeers.minConnectTime knownPeers (`Set.notMember` bigLedgerPeersSet)) | otherwise = GuardedSkip Nothing @@ -153,6 +154,7 @@ belowTargetLocal actions ] localRootPeersSet = LocalRootPeers.keysSet localRootPeers + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers localEstablishedPeers = EstablishedPeers.toSet establishedPeers `Set.intersection` localRootPeersSet localAvailableToConnect = KnownPeers.availableToConnect knownPeers @@ -171,8 +173,8 @@ belowTargetOther actions policyPickColdPeersToPromote } st@PeerSelectionState { - bigLedgerPeers, knownPeers, + publicRootPeers, establishedPeers, inProgressPromoteCold, targets = PeerSelectionTargets { @@ -226,18 +228,20 @@ belowTargetOther actions -- If we could connect except that there are no peers currently available -- then we return the next wakeup time (if any) | numEstablishedPeers + numConnectInProgress < targetNumberOfEstablishedPeers - = GuardedSkip (Min <$> KnownPeers.minConnectTime knownPeers (`Set.notMember` bigLedgerPeers)) + = GuardedSkip (Min <$> KnownPeers.minConnectTime knownPeers (`Set.notMember` PublicRootPeers.toBigLedgerPeerSet publicRootPeers)) | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + numEstablishedPeers, numConnectInProgress :: Int numEstablishedPeers = Set.size $ EstablishedPeers.toSet establishedPeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet numConnectInProgress = Set.size $ inProgressPromoteCold - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet availableToConnect = KnownPeers.availableToConnect knownPeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet numAvailableToConnect = Set.size availableToConnect @@ -251,8 +255,8 @@ belowTargetBigLedgerPeers actions policyPickColdPeersToPromote } st@PeerSelectionState { - bigLedgerPeers, knownPeers, + publicRootPeers, establishedPeers, inProgressPromoteCold, targets = PeerSelectionTargets { @@ -308,23 +312,24 @@ belowTargetBigLedgerPeers actions -- then we return the next wakeup time (if any) | numEstablishedPeers + numConnectInProgress < targetNumberOfEstablishedBigLedgerPeers - = GuardedSkip (Min <$> KnownPeers.minConnectTime knownPeers (`Set.member` bigLedgerPeers)) + = GuardedSkip (Min <$> KnownPeers.minConnectTime knownPeers (`Set.member` PublicRootPeers.toBigLedgerPeerSet publicRootPeers)) | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers numEstablishedPeers, numConnectInProgress :: Int numEstablishedPeers = Set.size $ EstablishedPeers.toSet establishedPeers `Set.intersection` - bigLedgerPeers + bigLedgerPeersSet numConnectInProgress = Set.size $ inProgressPromoteCold `Set.intersection` - bigLedgerPeers + bigLedgerPeersSet availableToConnect = KnownPeers.availableToConnect knownPeers `Set.intersection` - bigLedgerPeers + bigLedgerPeersSet numAvailableToConnect= Set.size availableToConnect @@ -353,7 +358,7 @@ jobPromoteColdPeer PeerSelectionActions { handler :: SomeException -> m (Completion m peeraddr peerconn) handler e = return $ Completion $ \st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, establishedPeers, fuzzRng, targets = PeerSelectionTargets { @@ -374,14 +379,15 @@ jobPromoteColdPeer PeerSelectionActions { ( baseColdPeerRetryDiffTime * 2 ^ (pred failCount `min` maxColdPeerRetryBackoff) ) + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers in Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet then [TracePromoteColdBigLedgerPeerFailed targetNumberOfEstablishedBigLedgerPeers (Set.size $ EstablishedPeers.toSet establishedPeers `Set.intersection` - bigLedgerPeers) + bigLedgerPeersSet) peeraddr delay e] else [TracePromoteColdFailed targetNumberOfEstablishedPeers @@ -408,7 +414,7 @@ jobPromoteColdPeer PeerSelectionActions { let peerSharing = peerConnToPeerSharing peerconn return $ Completion $ \st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, establishedPeers, knownPeers, targets = PeerSelectionTargets { @@ -422,24 +428,25 @@ jobPromoteColdPeer PeerSelectionActions { -- Update PeerSharing value in KnownPeers -- This will compute the appropriate peer sharing value using -- 'combinePeerInformation' - knownPeers' = KnownPeers.insert (Map.singleton peeraddr (Just peerSharing, mbPeerAdvertise, Nothing)) + knownPeers' = KnownPeers.insert (Map.singleton peeraddr (Just peerSharing, mbPeerAdvertise, Nothing, Nothing)) $ KnownPeers.clearTepidFlag peeraddr $ KnownPeers.resetFailCount peeraddr knownPeers + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers in Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet then [TracePromoteColdBigLedgerPeerDone targetNumberOfEstablishedBigLedgerPeers (Set.size $ EstablishedPeers.toSet establishedPeers' `Set.intersection` - bigLedgerPeers) + bigLedgerPeersSet) peeraddr] else [TracePromoteColdDone targetNumberOfEstablishedPeers (Set.size $ EstablishedPeers.toSet establishedPeers' - Set.\\ bigLedgerPeers) + Set.\\ bigLedgerPeersSet) peeraddr], decisionState = st { establishedPeers = establishedPeers', @@ -475,8 +482,8 @@ aboveTargetOther actions policyPickWarmPeersToDemote } st@PeerSelectionState { - bigLedgerPeers, localRootPeers, + publicRootPeers, establishedPeers, activePeers, inProgressDemoteWarm, @@ -489,16 +496,17 @@ aboveTargetOther actions -- Or more precisely, how many established peers could we demote? -- We only want to pick established peers that are not active, since for -- active one we need to demote them first. - | let numEstablishedPeers, numActivePeers, numPeersToDemote :: Int + | let bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + numEstablishedPeers, numActivePeers, numPeersToDemote :: Int numEstablishedPeers = Set.size $ EstablishedPeers.toSet establishedPeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet numActivePeers = Set.size $ activePeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet numLocalWarmPeers = Set.size localWarmPeers localWarmPeers = LocalRootPeers.keysSet localRootPeers `Set.intersection` EstablishedPeers.toSet establishedPeers Set.\\ activePeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet -- One constraint on how many to demote is the difference in the -- number we have now vs the target. The other constraint is that -- we pick established peers that are not also active. These @@ -510,8 +518,8 @@ aboveTargetOther actions (numEstablishedPeers - numLocalWarmPeers - numActivePeers) - - Set.size (inProgressDemoteWarm Set.\\ bigLedgerPeers) - - Set.size (inProgressPromoteWarm Set.\\ bigLedgerPeers) + - Set.size (inProgressDemoteWarm Set.\\ bigLedgerPeersSet) + - Set.size (inProgressPromoteWarm Set.\\ bigLedgerPeersSet) , numPeersToDemote > 0 = Guarded Nothing $ do @@ -555,7 +563,7 @@ aboveTargetBigLedgerPeers actions policyPickWarmPeersToDemote } st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, establishedPeers, activePeers, inProgressDemoteWarm, @@ -568,12 +576,13 @@ aboveTargetBigLedgerPeers actions -- Or more precisely, how many established peers could we demote? -- We only want to pick established peers that are not active, since for -- active one we need to demote them first. - | let numEstablishedBigLedgerPeers, numBigLedgerPeersToDemote :: Int + | let bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + numEstablishedBigLedgerPeers, numBigLedgerPeersToDemote :: Int numEstablishedBigLedgerPeers = Set.size $ EstablishedPeers.toSet establishedPeers - `Set.intersection` bigLedgerPeers + `Set.intersection` bigLedgerPeersSet numActiveBigLedgerPeers = Set.size $ activePeers - `Set.intersection` bigLedgerPeers + `Set.intersection` bigLedgerPeersSet -- We want to demote big ledger peers towards the target but we avoid to -- pick active peer. The `min` is taken so that `pickPeers` is given @@ -591,7 +600,7 @@ aboveTargetBigLedgerPeers actions let availableToDemote :: Set peeraddr availableToDemote = EstablishedPeers.toSet establishedPeers - `Set.intersection` bigLedgerPeers + `Set.intersection` bigLedgerPeersSet Set.\\ activePeers Set.\\ inProgressDemoteWarm Set.\\ inProgressPromoteWarm @@ -637,7 +646,7 @@ jobDemoteEstablishedPeer PeerSelectionActions{peerStateActions = PeerStateAction -- It's quite bad if closing fails. The peer is cold so -- remove if from the set of established. Completion $ \st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, establishedPeers, inProgressDemoteWarm, knownPeers, @@ -662,19 +671,21 @@ jobDemoteEstablishedPeer PeerSelectionActions{peerStateActions = PeerStateAction $ peerSet establishedPeers' = EstablishedPeers.deletePeers peerSet - establishedPeers in + establishedPeers + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers + in Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet then [TraceDemoteWarmBigLedgerPeerFailed targetNumberOfEstablishedBigLedgerPeers (Set.size $ EstablishedPeers.toSet establishedPeers `Set.intersection` - bigLedgerPeers) + bigLedgerPeersSet) peeraddr e] else [TraceDemoteWarmFailed targetNumberOfEstablishedPeers (Set.size $ EstablishedPeers.toSet establishedPeers - Set.\\ bigLedgerPeers) + Set.\\ bigLedgerPeersSet) peeraddr e], decisionState = st { inProgressDemoteWarm = inProgressDemoteWarm', @@ -689,7 +700,7 @@ jobDemoteEstablishedPeer PeerSelectionActions{peerStateActions = PeerStateAction job = do closePeerConnection peerconn return $ Completion $ \st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, establishedPeers, targets = PeerSelectionTargets { targetNumberOfEstablishedPeers @@ -698,18 +709,19 @@ jobDemoteEstablishedPeer PeerSelectionActions{peerStateActions = PeerStateAction _now -> let establishedPeers' = EstablishedPeers.delete peeraddr establishedPeers + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers in Decision { - decisionTrace = if peeraddr `Set.member` bigLedgerPeers + decisionTrace = if peeraddr `Set.member` bigLedgerPeersSet then [TraceDemoteWarmBigLedgerPeerDone targetNumberOfEstablishedPeers (Set.size $ EstablishedPeers.toSet establishedPeers' `Set.intersection` - bigLedgerPeers) + bigLedgerPeersSet) peeraddr] else [TraceDemoteWarmDone targetNumberOfEstablishedPeers (Set.size $ EstablishedPeers.toSet establishedPeers' - Set.\\ bigLedgerPeers) + Set.\\ bigLedgerPeersSet) peeraddr], decisionState = st { establishedPeers = establishedPeers', diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs index c36cb5137b0..a849f8f3dc7 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs @@ -22,6 +22,7 @@ import Control.Monad.Class.MonadTimer.SI import Ouroboros.Network.PeerSelection.Governor.Types import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers (isKnownLedgerPeer) @@ -50,8 +51,8 @@ belowTarget actions policyPeerShareRetryTime } st@PeerSelectionState { - bigLedgerPeers, knownPeers, + publicRootPeers, establishedPeers, inProgressPeerShareReqs, targets = PeerSelectionTargets { @@ -121,7 +122,7 @@ belowTarget actions = GuardedSkip Nothing where numKnownPeers = Set.size $ KnownPeers.toSet knownPeers - Set.\\ bigLedgerPeers + Set.\\ PublicRootPeers.toBigLedgerPeerSet publicRootPeers numPeerShareReqsPossible = policyMaxInProgressPeerShareReqs - inProgressPeerShareReqs availableForPeerShare = EstablishedPeers.availableForPeerShare establishedPeers @@ -188,6 +189,7 @@ jobPeerShare PeerSelectionActions{requestPeerShare} (Map.fromList $ map (\a -> ( a , ( Nothing + , Nothing , Nothing , Nothing)) ) @@ -232,6 +234,7 @@ jobPeerShare PeerSelectionActions{requestPeerShare} (Map.fromList $ map (\a -> ( a , ( Nothing + , Nothing , Nothing , Nothing)) ) @@ -296,6 +299,7 @@ jobPeerShare PeerSelectionActions{requestPeerShare} (Map.fromList $ map (\a -> ( a , ( Nothing + , Nothing , Nothing , Nothing)) ) @@ -326,7 +330,6 @@ aboveTarget PeerSelectionPolicy { st@PeerSelectionState { localRootPeers, publicRootPeers, - bigLedgerPeers, knownPeers, establishedPeers, inProgressPromoteCold, @@ -354,15 +357,16 @@ aboveTarget PeerSelectionPolicy { -- below the target for root peers. -- , let numRootPeersCanForget = LocalRootPeers.size localRootPeers - + Set.size publicRootPeers + + PublicRootPeers.size publicRootPeers - targetNumberOfRootPeers availableToForget = KnownPeers.toSet knownPeers Set.\\ EstablishedPeers.toSet establishedPeers Set.\\ LocalRootPeers.keysSet localRootPeers Set.\\ (if numRootPeersCanForget <= 0 - then publicRootPeers else Set.empty) + then PublicRootPeers.toSet publicRootPeers + else Set.empty) Set.\\ inProgressPromoteCold - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet , not (Set.null availableToForget) = Guarded Nothing $ do @@ -384,9 +388,9 @@ aboveTarget PeerSelectionPolicy { selectedToForget knownPeers publicRootPeers' = publicRootPeers - Set.\\ selectedToForget + `PublicRootPeers.difference` selectedToForget in assert (Set.isSubsetOf - publicRootPeers' + (PublicRootPeers.toSet publicRootPeers') (KnownPeers.toSet knownPeers')) Decision { @@ -402,11 +406,12 @@ aboveTarget PeerSelectionPolicy { | otherwise = GuardedSkip Nothing where + bigLedgerPeersSet = PublicRootPeers.toBigLedgerPeerSet publicRootPeers numKnownPeers, numEstablishedPeers :: Int numKnownPeers = Set.size $ KnownPeers.toSet knownPeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet numEstablishedPeers = Set.size $ EstablishedPeers.toSet establishedPeers - Set.\\ bigLedgerPeers + Set.\\ bigLedgerPeersSet ------------------------------- diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index 42c65fe9129..819754c6235 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -35,6 +35,10 @@ import Ouroboros.Network.PeerSelection.Governor.ActivePeers (jobDemoteActivePeer) import Ouroboros.Network.PeerSelection.Governor.Types hiding (PeerSelectionCounters (..)) +import Ouroboros.Network.PeerSelection.PeerAdvertise + (PeerAdvertise (..)) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PubliRootPeers import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers @@ -51,7 +55,7 @@ targetPeers :: (MonadSTM m, Ord peeraddr) -> Guarded (STM m) (TimedDecision m peeraddr peerconn) targetPeers PeerSelectionActions{readPeerSelectionTargets} st@PeerSelectionState{ - bigLedgerPeers, + publicRootPeers, localRootPeers, targets } = @@ -72,9 +76,9 @@ targetPeers PeerSelectionActions{readPeerSelectionTargets} localRootPeers -- We have to enforce that local and big ledger peers are disjoint. - bigLedgerPeers' = bigLedgerPeers - Set.\\ - LocalRootPeers.keysSet localRootPeers' + publicRootPeers' = PublicRootPeers.difference + publicRootPeers + (LocalRootPeers.keysSet localRootPeers') return $ \_now -> Decision { decisionTrace = [TraceTargetsChanged targets targets'], @@ -82,7 +86,7 @@ targetPeers PeerSelectionActions{readPeerSelectionTargets} decisionState = st { targets = targets', localRootPeers = localRootPeers', - bigLedgerPeers = bigLedgerPeers' + publicRootPeers = publicRootPeers' } } @@ -118,7 +122,7 @@ inboundPeers PeerSelectionActions{ return $ \_ -> let -- If peer happens to already be present in the Known Peer set -- 'insert' is going to do its due diligence before adding. - newEntry = Map.singleton addr (Just ps, Nothing, Nothing) + newEntry = Map.singleton addr (Just ps, Just DoAdvertisePeer, Nothing, Nothing) knownPeers' = KnownPeers.insert newEntry knownPeers in Decision { decisionTrace = [TraceKnownInboundConnection addr ps], @@ -137,7 +141,7 @@ connections PeerSelectionActions{ peerStateActions = PeerStateActions {monitorPeerConnection} } st@PeerSelectionState { - bigLedgerPeers, + publicRootPeers, localRootPeers, activePeers, establishedPeers, @@ -202,9 +206,9 @@ connections PeerSelectionActions{ demotions' publicRootDemotions = nonLocalDemotions - `Map.withoutKeys` bigLedgerPeers + `Map.withoutKeys` bigLedgerPeersSet bigLedgerPeersDemotions = nonLocalDemotions - `Map.restrictKeys` bigLedgerPeers + `Map.restrictKeys` bigLedgerPeersSet in assert (activePeers' `Set.isSubsetOf` Map.keysSet (EstablishedPeers.toMap establishedPeers')) @@ -240,6 +244,7 @@ connections PeerSelectionActions{ } } where + bigLedgerPeersSet = PubliRootPeers.toBigLedgerPeerSet publicRootPeers -- Those demotions that occurred not as a result of action by the governor. -- They're further classified into demotions to warm, and demotions to cold. asynchronousDemotions :: Map peeraddr (PeerStatus, Maybe ReconnectDelay) -> Map peeraddr (PeerStatus, Maybe ReconnectDelay) @@ -288,7 +293,6 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers } policy st@PeerSelectionState{ - bigLedgerPeers, localRootPeers, publicRootPeers, knownPeers, @@ -314,7 +318,7 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers removed = LocalRootPeers.toMap localRootPeers Map.\\ LocalRootPeers.toMap localRootPeers' -- LocalRoots are not ledger! - addedInfoMap = Map.map (\a -> (Nothing, Just a, Nothing)) added + addedInfoMap = Map.map (\a -> (Nothing, Just a, Nothing, Nothing)) added removedSet = Map.keysSet removed knownPeers' = KnownPeers.insert addedInfoMap knownPeers -- We do not immediately remove old ones from the @@ -325,11 +329,10 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers -- We have to adjust the publicRootPeers to maintain the invariant -- that the local and public sets are non-overlapping. - publicRootPeers' = publicRootPeers Set.\\ localRootPeersSet - - -- We have to adjust the bigLedgerPeers to maintain the invariant that - -- the local and big ledger peer sets are non-overlapping. - bigLedgerPeers' = bigLedgerPeers Set.\\ localRootPeersSet + -- + publicRootPeers' = publicRootPeers + `PublicRootPeers.difference` + localRootPeersSet -- If we are removing local roots and we have active connections to -- them then things are a little more complicated. We would typically @@ -348,7 +351,7 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers return $ \_now -> assert (Set.isSubsetOf - publicRootPeers' + (PublicRootPeers.toSet publicRootPeers') (KnownPeers.toSet knownPeers')) . assert (Set.isSubsetOf (LocalRootPeers.keysSet localRootPeers') @@ -358,7 +361,6 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers decisionTrace = [TraceLocalRootPeersChanged localRootPeers localRootPeers'], decisionState = st { - bigLedgerPeers = bigLedgerPeers', localRootPeers = localRootPeers', publicRootPeers = publicRootPeers', knownPeers = knownPeers', diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/RootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/RootPeers.hs index f1dbebde5a7..325e13e0cf5 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/RootPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/RootPeers.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Ouroboros.Network.PeerSelection.Governor.RootPeers (belowTarget) where @@ -12,8 +13,12 @@ import Control.Exception (SomeException, assert) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI +import Ouroboros.Network.PeerSelection.Bootstrap + (IsBootstrapPeer (..)) import Ouroboros.Network.PeerSelection.Governor.Types -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..), + LedgerPeersKind (..)) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers @@ -65,7 +70,7 @@ belowTarget actions = GuardedSkip Nothing where numRootPeers = LocalRootPeers.size localRootPeers - + Set.size publicRootPeers + + PublicRootPeers.size publicRootPeers maxExtraRootPeers = targetNumberOfRootPeers - numRootPeers @@ -109,17 +114,36 @@ jobReqPublicRootPeers PeerSelectionActions{ requestPublicRootPeers job :: m (Completion m peeraddr peerconn) job = do - (results, ttl) <- requestPublicRootPeers numExtraAllowed + (results, ttl) <- requestPublicRootPeers AllLedgerPeers numExtraAllowed return $ Completion $ \st now -> - let newPeers = results `Map.withoutKeys` LocalRootPeers.keysSet (localRootPeers st) - `Map.withoutKeys` publicRootPeers st - `Map.withoutKeys` bigLedgerPeers st - publicRootPeers' = publicRootPeers st <> Map.keysSet newPeers - knownPeers' = KnownPeers.insert - -- When we don't know about the PeerSharing information - -- we default to NoPeerSharing - (Map.map (\(a, b) -> (Just NoPeerSharing, Just a, Just b)) newPeers) - (knownPeers st) + let newPeers = results `PublicRootPeers.difference` LocalRootPeers.keysSet (localRootPeers st) + `PublicRootPeers.difference` PublicRootPeers.toSet (publicRootPeers st) + publicRootPeers' = PublicRootPeers.merge (publicRootPeers st) newPeers + bootstrapPeers = PublicRootPeers.toBootstrapPeerMap publicRootPeers' + ledgerPeers = PublicRootPeers.toLedgerPeerSet publicRootPeers' + -- Add bootstrapPeers peers + knownPeers' = KnownPeers.insert + -- When we don't know about the PeerSharing information + -- we default to NoPeerSharing + ( Map.fromList + . map (\(p, pa) -> (p, (Nothing, Just pa, Nothing, Just IsBootstrapPeer))) + -- ^ important + $ Map.assocs bootstrapPeers + -- ^ important + ) + (knownPeers st) + + -- Add ledgerPeers peers + knownPeers'' = KnownPeers.insert + -- When we don't know about the PeerSharing information + -- we default to NoPeerSharing + ( Map.fromList + . map (,(Nothing, Nothing, Just IsLedgerPeer, Nothing)) + -- ^ important + $ Set.toList ledgerPeers + -- ^ important + ) + knownPeers' -- We got a successful response to our request, but if we're still -- below target we're going to want to try again at some point. @@ -129,8 +153,8 @@ jobReqPublicRootPeers PeerSelectionActions{ requestPublicRootPeers -- seconds is just over an hour. publicRootBackoffs' :: Int publicRootBackoffs' - | Map.null newPeers = (publicRootBackoffs st `max` 0) + 1 - | otherwise = 0 + | PublicRootPeers.null newPeers = (publicRootBackoffs st `max` 0) + 1 + | otherwise = 0 publicRootRetryDiffTime :: DiffTime publicRootRetryDiffTime @@ -142,17 +166,17 @@ jobReqPublicRootPeers PeerSelectionActions{ requestPublicRootPeers publicRootRetryTime = addTime publicRootRetryDiffTime now in assert (Set.isSubsetOf - publicRootPeers' - (KnownPeers.toSet knownPeers')) + (PublicRootPeers.toSet publicRootPeers') + (KnownPeers.toSet knownPeers'')) Decision { decisionTrace = [TracePublicRootsResults - (Map.map fst newPeers) + newPeers publicRootBackoffs' publicRootRetryDiffTime], decisionState = st { publicRootPeers = publicRootPeers', - knownPeers = knownPeers', + knownPeers = knownPeers'', publicRootBackoffs = publicRootBackoffs', publicRootRetryTime = publicRootRetryTime, inProgressPublicRootsReq = False diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index e20d9a58644..0cc7c53f0c5 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -61,16 +61,22 @@ import System.Random (StdGen) import Ouroboros.Network.ExitPolicy import Ouroboros.Network.PeerSelection.LedgerPeers (IsBigLedgerPeer, - IsLedgerPeer) + LedgerPeersKind) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (LedgerStateJudgement (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) +import Ouroboros.Network.PeerSelection.PublicRootPeers + (PublicRootPeers) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers (EstablishedPeers) import qualified Ouroboros.Network.PeerSelection.State.EstablishedPeers as EstablishedPeers -import Ouroboros.Network.PeerSelection.State.KnownPeers (KnownPeers) +import Ouroboros.Network.PeerSelection.State.KnownPeers (KnownPeers, + getBootstrapPeers) import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers - (HotValency, LocalRootPeers, WarmValency) + (HotValency (..), LocalRootPeers, WarmValency (..)) import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers import Ouroboros.Network.PeerSelection.Types (PeerSource (..), PeerStatus (PeerHot, PeerWarm)) @@ -276,15 +282,14 @@ data PeerSelectionActions peeraddr peerconn m = PeerSelectionActions { -- It is intended to cover use cases including: -- -- * federated relays from a DNS pool + -- * Official bootstrap peers from a trusted source -- * stake pool relays published in the blockchain -- * a pre-distributed snapshot of stake pool relays from the blockchain -- - requestPublicRootPeers :: Int -> m (Map peeraddr (PeerAdvertise, IsLedgerPeer), DiffTime), - - - -- | Request a sample of big ledger peers. + -- It also makes a distinction between normal and big ledger peers to be + -- fetched. -- - requestBigLedgerPeers :: Int -> m (Set peeraddr, DiffTime), + requestPublicRootPeers :: LedgerPeersKind -> Int -> m (PublicRootPeers peeraddr, DiffTime), -- | The action to contact a known peer and request a sample of its -- known peers. @@ -293,7 +298,10 @@ data PeerSelectionActions peeraddr peerconn m = PeerSelectionActions { -- | Core actions run by the governor to change 'PeerStatus'. -- - peerStateActions :: PeerStateActions peeraddr peerconn m + peerStateActions :: PeerStateActions peeraddr peerconn m, + + -- | Read the current ledger state judgement + readLedgerStateJudgement :: STM m LedgerStateJudgement } -- | Callbacks which are performed to change peer state. @@ -350,11 +358,10 @@ data PeerSelectionState peeraddr peerconn = PeerSelectionState { -- localRootPeers :: !(LocalRootPeers peeraddr), - publicRootPeers :: !(Set peeraddr), - - -- | Set of big ledger peers. + -- | This set holds the public root peers (i.e. Ledger (small and big), + -- Bootstrap peers and locally configured public root peers). -- - bigLedgerPeers :: !(Set peeraddr), + publicRootPeers :: !(PublicRootPeers peeraddr), -- | Known peers. -- @@ -414,7 +421,11 @@ data PeerSelectionState peeraddr peerconn = PeerSelectionState { -- | 'PeerSelectionCounters' counters cache. Allows to only trace -- values when necessary. -- - countersCache :: !(Cache PeerSelectionCounters) + countersCache :: !(Cache PeerSelectionCounters), + + -- | Cached value of 'LedgerStateJudgement'. If this changes the peer selection + -- governor will act on it + currentLedgerStateJudgement :: !LedgerStateJudgement -- TODO: need something like this to distinguish between lots of bad peers -- and us getting disconnected from the network locally. We don't want a @@ -481,11 +492,11 @@ data PeerSelectionCounters = PeerSelectionCounters { -- | Local root peers with one entry per group. First entry is the number -- of warm peers in that group the second is the number of hot peers in -- that group. - localRoots :: [(Int, Int)] + localRoots :: [(HotValency, WarmValency)] } deriving (Eq, Show) peerStateToCounters :: Ord peeraddr => PeerSelectionState peeraddr peerconn -> PeerSelectionCounters -peerStateToCounters st@PeerSelectionState { activePeers, bigLedgerPeers, localRootPeers } = +peerStateToCounters st@PeerSelectionState { activePeers, publicRootPeers, localRootPeers } = PeerSelectionCounters { coldPeers = Set.size $ coldPeersSet Set.\\ bigLedgerPeers, warmPeers = Set.size $ warmPeersSet Set.\\ bigLedgerPeers, @@ -501,38 +512,37 @@ peerStateToCounters st@PeerSelectionState { activePeers, bigLedgerPeers, localRo coldPeersSet = knownPeersSet Set.\\ establishedPeersSet warmPeersSet = establishedPeersSet Set.\\ activePeers hotPeersSet = activePeers - localRoots = - [ (warm, hot) - | (_,_, members) <- LocalRootPeers.toGroupSets localRootPeers - , let warm = Set.size $ members `Set.intersection` warmPeersSet - hot = Set.size $ members `Set.intersection` hotPeersSet + localRoots = + [ (h, w) + | (h, w, _) <- LocalRootPeers.toGroupSets localRootPeers ] + bigLedgerPeers = PublicRootPeers.toBigLedgerPeerSet publicRootPeers emptyPeerSelectionState :: StdGen - -> [(Int, Int)] + -> [(HotValency, WarmValency)] -> PeerSelectionState peeraddr peerconn emptyPeerSelectionState rng localRoots = PeerSelectionState { - targets = nullPeerSelectionTargets, - localRootPeers = LocalRootPeers.empty, - publicRootPeers = Set.empty, - bigLedgerPeers = Set.empty, - knownPeers = KnownPeers.empty, - establishedPeers = EstablishedPeers.empty, - activePeers = Set.empty, - publicRootBackoffs = 0, - publicRootRetryTime = Time 0, - inProgressPublicRootsReq = False, - bigLedgerPeerBackoffs = 0, - bigLedgerPeerRetryTime = Time 0, - inProgressBigLedgerPeersReq = False, - inProgressPeerShareReqs = 0, - inProgressPromoteCold = Set.empty, - inProgressPromoteWarm = Set.empty, - inProgressDemoteWarm = Set.empty, - inProgressDemoteHot = Set.empty, - fuzzRng = rng, - countersCache = Cache (PeerSelectionCounters 0 0 0 0 0 0 localRoots) + targets = nullPeerSelectionTargets, + localRootPeers = LocalRootPeers.empty, + publicRootPeers = PublicRootPeers.empty, + knownPeers = KnownPeers.empty, + establishedPeers = EstablishedPeers.empty, + activePeers = Set.empty, + publicRootBackoffs = 0, + publicRootRetryTime = Time 0, + inProgressPublicRootsReq = False, + bigLedgerPeerBackoffs = 0, + bigLedgerPeerRetryTime = Time 0, + inProgressBigLedgerPeersReq = False, + inProgressPeerShareReqs = 0, + inProgressPromoteCold = Set.empty, + inProgressPromoteWarm = Set.empty, + inProgressDemoteWarm = Set.empty, + inProgressDemoteHot = Set.empty, + fuzzRng = rng, + countersCache = Cache (PeerSelectionCounters 0 0 0 0 0 0 localRoots), + currentLedgerStateJudgement = TooOld } @@ -543,6 +553,7 @@ assertPeerSelectionState PeerSelectionState{..} = assert (KnownPeers.invariant knownPeers) . assert (EstablishedPeers.invariant establishedPeers) . assert (LocalRootPeers.invariant localRootPeers) + . assert (PublicRootPeers.invariant publicRootPeers) -- The activePeers is a subset of the establishedPeers -- which is a subset of the known peers @@ -550,7 +561,7 @@ assertPeerSelectionState PeerSelectionState{..} = . assert (Set.isSubsetOf establishedPeersSet knownPeersSet) -- The localRootPeers and publicRootPeers must not overlap. - . assert (Set.null (Set.intersection localRootPeersSet publicRootPeers)) + . assert (Set.null (Set.intersection localRootPeersSet publicRootPeersSet)) -- The localRootPeers are a subset of the knownPeers, -- and with correct source info in the knownPeers (either @@ -559,8 +570,10 @@ assertPeerSelectionState PeerSelectionState{..} = . assert (Set.isSubsetOf localRootPeersSet knownPeersSet) -- The publicRootPeers are a subset of the knownPeers, - -- and with correct source info in the knownPeers. - . assert (Set.isSubsetOf publicRootPeers knownPeersSet) + . assert (Set.isSubsetOf publicRootPeersSet knownPeersSet) + + -- and all known bootstrap peers have the correct source info + . assert (Set.isSubsetOf publicBootstrapPeersSet (getBootstrapPeers knownPeers)) -- The targets should respect the containment relationships of the root, -- known, established and active peers @@ -605,14 +618,16 @@ assertPeerSelectionState PeerSelectionState{..} = . assert (Set.isSubsetOf inProgressDemoteHot hotPeersSet) . assert (Set.null (Set.intersection inProgressPromoteWarm inProgressDemoteWarm)) - -- `bigLedgerPeers` is a subset of known peers and disjoint from public and - -- local root peers. + -- `bigLedgerPeers` is a subset of known peers (and also public root peers) + -- and disjoint local root peers. . assert (Set.isSubsetOf bigLedgerPeers knownPeersSet) - . assert (Set.null (Set.intersection bigLedgerPeers publicRootPeers)) . assert (Set.null (Set.intersection bigLedgerPeers localRootPeersSet)) where knownPeersSet = KnownPeers.toSet knownPeers localRootPeersSet = LocalRootPeers.keysSet localRootPeers + publicRootPeersSet = PublicRootPeers.toSet publicRootPeers + publicBootstrapPeersSet = PublicRootPeers.toBootstrapPeerSet publicRootPeers + bigLedgerPeers = PublicRootPeers.toBigLedgerPeerSet publicRootPeers establishedPeersSet = EstablishedPeers.toSet establishedPeers establishedReadySet = EstablishedPeers.readyPeers establishedPeers activePeersSet = activePeers @@ -657,10 +672,10 @@ pickPeers PeerSelectionState{localRootPeers, publicRootPeers, knownPeers} numClamped = min num (Set.size available) peerSource p - | LocalRootPeers.member p localRootPeers = PeerSourceLocalRoot - | Set.member p publicRootPeers = PeerSourcePublicRoot - | KnownPeers.member p knownPeers = PeerSourcePeerShare - | otherwise = errorUnavailable + | LocalRootPeers.member p localRootPeers = PeerSourceLocalRoot + | PublicRootPeers.member p publicRootPeers = PeerSourcePublicRoot + | KnownPeers.member p knownPeers = PeerSourcePeerShare + | otherwise = errorUnavailable peerConnectFailCount p = fromMaybe errorUnavailable $ @@ -772,7 +787,7 @@ data TracePeerSelection peeraddr = | TraceTargetsChanged PeerSelectionTargets PeerSelectionTargets | TracePublicRootsRequest Int Int - | TracePublicRootsResults (Map peeraddr PeerAdvertise) Int DiffTime + | TracePublicRootsResults (PublicRootPeers peeraddr) Int DiffTime | TracePublicRootsFailure SomeException Int DiffTime -- | target known peers, actual known peers, selected peers | TraceForgetColdPeers Int Int (Set peeraddr) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 3f901ad10c3..39a84c86dab 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -11,8 +11,6 @@ module Ouroboros.Network.PeerSelection.LedgerPeers ( DomainAccessPoint (..) , IP.IP (..) - , LedgerPeersConsensusInterface (..) - , LedgerStateJudgement (..) , LedgerPeers (..) , getLedgerPeers , RelayAccessPoint (..) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs index c79bf0aca8e..32231290dfb 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs @@ -31,10 +31,16 @@ import qualified Network.DNS as DNS import qualified Network.Socket as Socket import Ouroboros.Network.PeerSelection.Governor.Types -import Ouroboros.Network.PeerSelection.LedgerPeers hiding (getLedgerPeers) +import Ouroboros.Network.PeerSelection.LedgerPeers hiding + (getLedgerPeers) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (LedgerStateJudgement (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) +import Ouroboros.Network.PeerSelection.PublicRootPeers + (PublicRootPeers) +import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) @@ -60,6 +66,7 @@ withPeerSelectionActions -> DNSSemaphore m -> DNSActions resolver exception m -> STM m PeerSelectionTargets + -> STM m LedgerStateJudgement -> STM m [( HotValency , WarmValency , Map RelayAccessPoint PeerAdvertise)] @@ -89,6 +96,7 @@ withPeerSelectionActions dnsSemaphore dnsActions readPeerSelectionTargets + readLedgerStateJudgement readLocalRootPeers readPublicRootPeers peerSharing @@ -106,9 +114,9 @@ withPeerSelectionActions peerSharing, peerConnToPeerSharing, requestPublicRootPeers, - requestBigLedgerPeers, requestPeerShare, - peerStateActions + peerStateActions, + readLedgerStateJudgement } withAsync (localRootPeersProvider @@ -120,28 +128,34 @@ withPeerSelectionActions localRootsVar) (\thread -> k thread peerSelectionActions) where - -- We first try to get public root peers from the ledger, but if it fails - -- (for example because the node hasn't synced far enough) we fall back - -- to using the manually configured bootstrap root peers. - requestPublicRootPeers :: Int -> m (Map peeraddr (PeerAdvertise, IsLedgerPeer), DiffTime) - requestPublicRootPeers n = do - peers_m <- getLedgerPeers (NumberOfPeers $ fromIntegral n) AllLedgerPeers - case peers_m of - -- No peers from Ledger - Nothing -> do - (m, dt) <- requestConfiguredRootPeers n - let m' = Map.map (\a -> (a, IsNotLedgerPeer)) m - return (m', dt) - - -- These peers come from Ledger - -- - -- We set peers coming from ledger as DoNotAdvertisePeer so they do - -- not get shared via Peer Sharing - Just (peers, dt) -> - return ( Map.fromList - $ map (\a -> (a, (DoNotAdvertisePeer, IsLedgerPeer))) - $ Set.toList peers - , dt) + -- We start by reading the current ledger state judgement, if it is + -- YoungEnough we only care about fetching for ledger peers, otherwise we + -- aim to fetch bootstrap peers. + requestPublicRootPeers :: LedgerPeersKind -> Int -> m (PublicRootPeers peeraddr, DiffTime) + requestPublicRootPeers ledgerPeersKind n = do + -- Read the current ledger state judgement + lsj <- atomically readLedgerStateJudgement + -- If the ledger state is YoungEnough we should get ledger peers, the + -- Nothing case should not happen but there can be a race condition. + -- If that's the case we try again soon enough. + case lsj of + YoungEnough -> do + mbLedgerPeers <- getLedgerPeers (NumberOfPeers $ fromIntegral n) ledgerPeersKind + case mbLedgerPeers of + Nothing -> pure (PublicRootPeers.empty, 0) + Just (ledgerPeers, dt) -> + case ledgerPeersKind of + AllLedgerPeers -> + pure (PublicRootPeers.fromMapAndSet Map.empty ledgerPeers Set.empty, dt) + BigLedgerPeers -> + pure (PublicRootPeers.fromMapAndSet Map.empty Set.empty ledgerPeers, dt) + TooOld -> do + -- If the ledger state is YoungEnough we should get trustable peers. + -- However TODO: we need to ensure we only choose from big configured + -- root peers, but for that the root peers need to contain stake + -- information! + (bootstrapPeers, dt) <- requestConfiguredRootPeers n + pure (PublicRootPeers.fromMapAndSet bootstrapPeers Set.empty Set.empty, dt) -- For each call we re-initialise the dns library which forces reading -- `/etc/resolv.conf`: @@ -156,18 +170,6 @@ withPeerSelectionActions dnsActions ($ n) - requestBigLedgerPeers :: Int -> m (Set peeraddr, DiffTime) - requestBigLedgerPeers n = do - peers_m <- getLedgerPeers (NumberOfPeers $ fromIntegral n) BigLedgerPeers - case peers_m of - Nothing -> do - (m, dt) <- requestConfiguredRootPeers n - -- TODO: we need to ensure we only choose from big configured root - -- peers, but for that the root peers need to contain stake - -- information! - return (Map.keysSet m, dt) - Just peers -> return peers - requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr) requestPeerShare amount peer = do resultQueue <- newEmptyMVar diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PublicRootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PublicRootPeers.hs new file mode 100644 index 00000000000..a474e7775bb --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PublicRootPeers.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DerivingVia #-} + +module Ouroboros.Network.PeerSelection.PublicRootPeers + ( -- * Types + PublicRootPeers + -- Export constructors for defining tests. + , invariant + -- * Basic operations + , empty + , null + , size + , member + , merge + , difference + , intersection + , toSet + , toBootstrapPeerSet + , toBootstrapPeerMap + , toLedgerPeerSet + , toBigLedgerPeerSet + , toAllLedgerPeerSet + , insertBootstrapPeer + , insertLedgerPeer + , insertBigLedgerPeer + , fromMapAndSet + ) where + +import Prelude hiding (null) + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set, (\\)) +import qualified Data.Set as Set +import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) + +--------------------------------------- +-- Public root peer set representation +-- + +-- | Public Root Peers consist of either a set of manually configured +-- bootstrap peers +data PublicRootPeers peeraddr = + PublicRootPeers { getBootstrapPeers :: !(Map peeraddr PeerAdvertise) + , getLedgerPeers :: !(Set peeraddr) + , getBigLedgerPeers :: !(Set peeraddr) + } + deriving (Eq, Show) + +invariant :: Ord peeraddr => PublicRootPeers peeraddr -> Bool +invariant (PublicRootPeers bsp lp blp) = + -- bootstrap peers and ledger peers should not overlap + Set.null (Set.intersection (Map.keysSet bsp) lp) + -- bootstrap peers and big ledger peers should not overlap + && Set.null (Set.intersection (Map.keysSet bsp) blp) + -- ledger and big ledger peers should not overlap + && Set.null (Set.intersection lp blp) + +empty :: PublicRootPeers peeraddr +empty = PublicRootPeers Map.empty Set.empty Set.empty + +nullBootstrap :: PublicRootPeers peeraddr -> Bool +nullBootstrap (PublicRootPeers bsp _ _) = Map.null bsp + +nullLedgerPeers :: PublicRootPeers peeraddr -> Bool +nullLedgerPeers (PublicRootPeers _ lp _) = Set.null lp + +nullBigLedgerPeers :: PublicRootPeers peeraddr -> Bool +nullBigLedgerPeers (PublicRootPeers _ _ blp) = Set.null blp + +nullAllLedgerPeers :: PublicRootPeers peeraddr -> Bool +nullAllLedgerPeers prp = + nullLedgerPeers prp && nullBigLedgerPeers prp + +null :: PublicRootPeers peeraddr -> Bool +null prp = nullBootstrap prp && nullAllLedgerPeers prp + +size :: PublicRootPeers peeraddr -> Int +size (PublicRootPeers bsp lp blp) = + Map.size bsp + + Set.size lp + + Set.size blp + +member :: Ord peeraddr => peeraddr -> PublicRootPeers peeraddr -> Bool +member p (PublicRootPeers bsp lp blp) = + Map.member p bsp + || Set.member p lp + || Set.member p blp + +merge :: Ord peeraddr + => PublicRootPeers peeraddr + -> PublicRootPeers peeraddr + -> PublicRootPeers peeraddr +merge (PublicRootPeers bsp lp blp) (PublicRootPeers bsp' lp' blp') = + PublicRootPeers (bsp <> bsp') (lp <> lp') (blp <> blp') + +difference :: Ord peeraddr + => PublicRootPeers peeraddr + -> Set peeraddr + -> PublicRootPeers peeraddr +difference (PublicRootPeers bsp lp blp) addrs = + PublicRootPeers (bsp `Map.withoutKeys` addrs) + (lp \\ addrs) + (blp \\ addrs) + +intersection :: Ord peeraddr + => PublicRootPeers peeraddr + -> Set peeraddr + -> PublicRootPeers peeraddr +intersection (PublicRootPeers bsp lp blp) addrs = + PublicRootPeers (bsp `Map.restrictKeys` addrs) + (lp `Set.intersection` addrs) + (blp `Set.intersection` addrs) + +toSet :: Ord peeraddr => PublicRootPeers peeraddr -> Set peeraddr +toSet (PublicRootPeers bsp lp blp) = + Map.keysSet bsp <> lp <> blp + +toBootstrapPeerSet :: PublicRootPeers peeraddr -> Set peeraddr +toBootstrapPeerSet (PublicRootPeers bsp _ _) = Map.keysSet bsp + +toBootstrapPeerMap :: PublicRootPeers peeraddr -> Map peeraddr PeerAdvertise +toBootstrapPeerMap (PublicRootPeers bsp _ _) = bsp + +toLedgerPeerSet :: PublicRootPeers peeraddr -> Set peeraddr +toLedgerPeerSet (PublicRootPeers _ lp _) = lp + +toBigLedgerPeerSet :: PublicRootPeers peeraddr -> Set peeraddr +toBigLedgerPeerSet (PublicRootPeers _ _ blp) = blp + +toAllLedgerPeerSet :: Ord peeraddr => PublicRootPeers peeraddr -> Set peeraddr +toAllLedgerPeerSet (PublicRootPeers _ lp blp) = lp <> blp + +-- | Preserves PublicRootPeers invariant. If the two sets are not disjoint, +-- removes the common ones from the bootstrap peers set since its the most +-- sensitive set. +-- +fromMapAndSet :: Ord peeraddr + => Map peeraddr PeerAdvertise + -> Set peeraddr -- ledger peers + -> Set peeraddr -- big ledger peers + -> PublicRootPeers peeraddr +fromMapAndSet bsp lp blp = + -- Enforcing invariants + let newLP = Set.difference lp (Map.keysSet bsp) + newBLP = Set.difference blp (Map.keysSet bsp <> newLP) + in PublicRootPeers bsp newLP newBLP + +insertBootstrapPeer :: Ord peeraddr + => peeraddr + -> PeerAdvertise + -> PublicRootPeers peeraddr + -> PublicRootPeers peeraddr +insertBootstrapPeer p pa prp = + let (PublicRootPeers b lp blp) = difference prp (Set.singleton p) + in PublicRootPeers (Map.insert p pa b) lp blp + +insertLedgerPeer :: Ord peeraddr + => peeraddr + -> PublicRootPeers peeraddr + -> PublicRootPeers peeraddr +insertLedgerPeer p prp = + let (PublicRootPeers bsp lp blp) = difference prp (Set.singleton p) + in if Map.member p bsp + then prp + else PublicRootPeers bsp (Set.insert p lp) blp + +insertBigLedgerPeer :: Ord peeraddr + => peeraddr + -> PublicRootPeers peeraddr + -> PublicRootPeers peeraddr +insertBigLedgerPeer p prp = + let (PublicRootPeers bsp lp blp) = difference prp (Set.singleton p) + in if Map.member p bsp + then prp + else PublicRootPeers bsp lp (Set.insert p blp) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs index 35e168d85e5..f4d13f7acee 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -31,6 +32,10 @@ module Ouroboros.Network.PeerSelection.State.KnownPeers , getAvailablePeerSharingPeers -- ** Filtering ledger peers , isKnownLedgerPeer + -- ** Selecting bootstrap peers + , getBootstrapPeers + -- ** Filtering bootstrap peers + , isBootstrapPeer ) where import qualified Data.List as List @@ -46,6 +51,8 @@ import Control.Exception (assert) import Control.Monad.Class.MonadTime.SI import Data.Maybe (fromMaybe) +import Ouroboros.Network.PeerSelection.Bootstrap + (IsBootstrapPeer (..)) import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) @@ -128,7 +135,13 @@ data KnownPeerInfo = KnownPeerInfo { -- reply, since ledger peers are not particularly what one is looking for -- in a Peer Sharing reply. -- - knownLedgerPeer :: !IsLedgerPeer + knownLedgerPeer :: !IsLedgerPeer, + + -- | Indicates if peer is a bootstrap peer + -- + -- It is used so we can filter out the bootstrap peers when in bootstrap + -- phase (aka ledger state judgement says we are 'TooOld'). + knownBootstrapPeer :: !IsBootstrapPeer } deriving (Eq, Show) @@ -173,9 +186,8 @@ member :: Ord peeraddr member peeraddr KnownPeers {allPeers} = peeraddr `Map.member` allPeers --- TODO: `insert` ought to be idempotent, see issue #4616. insert :: Ord peeraddr - => Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise, Maybe IsLedgerPeer) + => Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise, Maybe IsLedgerPeer, Maybe IsBootstrapPeer) -> KnownPeers peeraddr -> KnownPeers peeraddr insert peeraddrs @@ -196,7 +208,7 @@ insert peeraddrs } in assert (invariant knownPeers') knownPeers' where - newPeerInfo (peerSharing, peerAdvertise, ledgerPeers) = + newPeerInfo (peerSharing, peerAdvertise, ledgerPeers, bootstrapPeer) = let peerAdvertise' = fromMaybe DoNotAdvertisePeer peerAdvertise peerSharing' = fromMaybe NoPeerSharing peerSharing `combinePeerInformation` @@ -207,6 +219,7 @@ insert peeraddrs , knownPeerSharing = peerSharing' , knownPeerAdvertise = peerAdvertise' , knownLedgerPeer = fromMaybe IsNotLedgerPeer ledgerPeers + , knownBootstrapPeer = fromMaybe IsNotBootstrapPeer bootstrapPeer } mergePeerInfo old new = KnownPeerInfo { @@ -221,6 +234,11 @@ insert peeraddrs , knownLedgerPeer = case knownLedgerPeer old of IsLedgerPeer -> IsLedgerPeer IsNotLedgerPeer -> knownLedgerPeer new + -- Preserve Bootstrap Peer information if we already know it being a + -- bootstrap peer + , knownBootstrapPeer = case knownBootstrapPeer old of + IsBootstrapPeer -> IsBootstrapPeer + IsNotBootstrapPeer -> knownBootstrapPeer new } delete :: Ord peeraddr @@ -395,9 +413,9 @@ setConnectTimes times canPeerShareRequest :: Ord peeraddr => peeraddr -> KnownPeers peeraddr -> Bool canPeerShareRequest pa KnownPeers { allPeers } = case Map.lookup pa allPeers of - Just (KnownPeerInfo _ _ PeerSharingPublic _ _) -> True - Just (KnownPeerInfo _ _ PeerSharingPrivate _ _) -> True - _ -> False + Just (KnownPeerInfo _ _ PeerSharingPublic _ _ _) -> True + Just (KnownPeerInfo _ _ PeerSharingPrivate _ _ _) -> True + _ -> False -- Filter available for Peer Sharing peers according to their PeerSharing -- information @@ -410,6 +428,32 @@ getAvailablePeerSharingPeers availableForPeerShare knownPeers = Set.filter (`canPeerShareRequest` knownPeers) availableForPeerShare +--------------------------------- +-- Selecting bootstrap peers +-- + +-- | Checks the KnownPeers Set for bootstrap peers. +-- +-- This is used in Peer Selection Governor to filter out the bootstrap peers +-- peers. +-- +isBootstrapPeer :: Ord peeraddr => peeraddr -> KnownPeers peeraddr -> Bool +isBootstrapPeer peeraddr KnownPeers { allPeers } = + case Map.lookup peeraddr allPeers of + Just (KnownPeerInfo _ _ _ _ _ IsBootstrapPeer) -> True + _ -> False + +-- | Filter available for Peer Sharing peers according to their PeerSharing +-- information +-- +getBootstrapPeers :: KnownPeers peeraddr + -> Set peeraddr +getBootstrapPeers = Map.keysSet + . Map.filter (\case + KnownPeerInfo _ _ _ _ _ IsBootstrapPeer -> True + _ -> False) + . allPeers + --------------------------------- -- Selecting peers to advertise -- @@ -443,14 +487,11 @@ sampleAdvertisedPeers _ _ _ = [] -- | Checks the KnownPeers Set for known ledger peers. -- --- This is used in Peer Selection Governor to filter out the known-to-te ledger +-- This is used in Peer Selection Governor to filter out the known-to-be ledger -- peers from the share result set. -- isKnownLedgerPeer :: Ord peeraddr => peeraddr -> KnownPeers peeraddr -> Bool isKnownLedgerPeer peeraddr KnownPeers { allPeers } = case Map.lookup peeraddr allPeers of - Just KnownPeerInfo { knownLedgerPeer } -> - case knownLedgerPeer of - IsLedgerPeer -> True - IsNotLedgerPeer -> False - Nothing -> False + Just (KnownPeerInfo _ _ _ _ IsLedgerPeer _) -> True + _ -> False