Adds PublicRootPeers and BootstrapPeers

Adds `readLedgerStateJudgement` to `PeerSelectionActions`
Adds `currentLedgerStateJudgement` to `PeerSelectionState`

Fix PeerSelectionState miss-merge with #4575

Adjusts `PeerSelectionActions` `requestPublicRootPeers` function to
provide either only ledger peers or bootstrap peers according to the
current ledger state. The same for `requestBigLedgerPeers`.

Adds LedgerStateJudgement to tests

Moves BigLedgerPeers to PublicRootPeers

Refactor `PeerSelectionActions` `requestPublicRootPeers` function

ouroboros-network-api/CHANGELOG.md

@@ -48,7 +48,6 @@
 * Restructured `decodeTerm` to prevent an impossible case and eliminate the
   associated `error`.
 
-
 ## 0.5.1.1 -- 2023-10-26
 
 ### Non-breaking changes
@@ -63,6 +62,7 @@
 
 * Added `IsBigLedgerPeer` type to
   `Ouroboros.Network.PeerSelection.LedgerPeers.Type`.
+
 ## 0.5.0.0 -- 2023-05-15
 
 * Swapped `NodeToClientV_15` with `NodeToClientV_16`, e.g. handshake query

ouroboros-network-api/ouroboros-network-api.cabal

@@ -46,6 +46,7 @@ library
                        Ouroboros.Network.PeerSelection.PeerAdvertise
                        Ouroboros.Network.PeerSelection.PeerSharing
                        Ouroboros.Network.PeerSelection.PeerSharing.Codec
+                       Ouroboros.Network.PeerSelection.Bootstrap
                        Ouroboros.Network.PeerSelection.RelayAccessPoint
   default-language:    Haskell2010
   build-depends:       base              >=4.14 && <4.19,

ouroboros-network-api/src/Ouroboros/Network/PeerSelection/Bootstrap.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Ouroboros.Network.PeerSelection.Bootstrap (IsBootstrapPeer (..)) where
+
+import           GHC.Generics (Generic)
+
+-- | Is Bootstrap peer flag distinguishes different kinds of public root peers
+--
+data IsBootstrapPeer = IsNotBootstrapPeer
+                     | IsBootstrapPeer
+  deriving (Eq, Show, Ord, Generic)

ouroboros-network-testing/ouroboros-network-testing.cabal

@@ -74,7 +74,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

ouroboros-network/CHANGELOG.md

@@ -4,10 +4,20 @@
 
 ### Breaking changes
 
-- Moved `LedgerConsensusInterface` type to `ouroboros-network-api`.
+* Moved `LedgerConsensusInterface` type to `ouroboros-network-api`.
 
 ### Non-breaking changes
 
+* Creates `PublicRootPeers` and adds `BootstrapPeers` and big ledger peers to
+  `PublicRootPeers` abstraction.
+
+* Adjusts `PeerSelectionActions` `requestPublicRootPeers` function to
+  provide either only ledger peers or bootstrap peers according to the
+  current ledger state. The same for `requestBigLedgerPeers`.
+
+* Adds `readLedgerStateJudgement` to `PeerSelectionActions`
+* Adds `currentLedgerStateJudgement` to `PeerSelectionState`
+
 ## 0.10.2.2 -- 2023-12-15
 
 ### Non-breaking changes

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
@@ -225,6 +226,7 @@ library sim-tests-lib
                        Test.Ouroboros.Network.PeerSelection.PeerGraph
                        Test.Ouroboros.Network.PeerSelection.PeerMetric
                        Test.Ouroboros.Network.PeerSelection.RootPeersDNS
+                       Test.Ouroboros.Network.PeerSelection.PublicRootPeers
                        Test.Ouroboros.Network.PeerState
                        Test.Ouroboros.Network.Testnet
                        Test.Ouroboros.Network.Testnet.Simulation.Node

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs

@@ -76,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.Protocol.Handshake (HandshakeArguments (..))
@@ -100,7 +98,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 (..))

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs

@@ -89,7 +89,6 @@ import           Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum,
                      chainSyncMiniProtocolNum, keepAliveMiniProtocolNum,
                      peerSharingMiniProtocolNum)
 import           Ouroboros.Network.PeerSelection.LedgerPeers
-                     (LedgerPeersConsensusInterface)
 import qualified Ouroboros.Network.PeerSelection.PeerSharing as PSTypes
 import           Ouroboros.Network.PeerSharing (bracketPeerSharingClient,
                      peerSharingClient, peerSharingServer)

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs

@@ -73,6 +73,7 @@ import           Control.Monad.IOSim
 import           Ouroboros.Network.PeerSelection.LedgerPeers
 import           Ouroboros.Network.PeerSelection.PeerAdvertise
 import           Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
+import qualified Ouroboros.Network.PeerSelection.PublicRootPeers as PublicRootPeers
 import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
 import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
 import           Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers
@@ -272,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)
 
 
@@ -535,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
@@ -569,7 +570,7 @@ envEventCredits  TraceEnvActivatePeer {}        = 0
 envEventCredits  TraceEnvDeactivatePeer {}      = 0
 envEventCredits  TraceEnvCloseConn {}           = 0
 
-
+envEventCredits  TraceEnvSetLedgerStateJudgement {} = 30
 
 
 -- | A coverage property that checks how many events are analysed when taking
@@ -748,7 +749,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))
@@ -860,7 +861,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
@@ -916,7 +917,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)
@@ -973,7 +974,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)
@@ -1028,7 +1029,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 =
@@ -1710,7 +1711,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 =
@@ -1850,7 +1852,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 =
@@ -2972,9 +2974,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 <- newLedgerAndPublicRootDNSSemaphore
     publicRootPeersProvider
       tracer
@@ -2990,7 +2993,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do
           (mkStdGen 42)
           publicStateVar
           actions
-            { requestPublicRootPeers =
+            { requestPublicRootPeers = \_ ->
                 transformPeerSelectionAction requestPublicRootPeers }
           policy
   where
@@ -3003,17 +3006,17 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains peerSharing = do
                 peerSharing              = peerSharing,
                 readPeerSelectionTargets = return targets,
                 requestPeerShare         = \_ _ -> return (PeerSharingResult []),
-                peerConnToPeerSharing    = id,
-                requestPublicRootPeers   = \_ -> return (Map.empty, 0),
+                peerConnToPeerSharing    = \ps -> ps,
+                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
@@ -3040,7 +3043,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 $
@@ -3051,12 +3054,17 @@ prop_issue_3550 = prop_governor_target_established_below $
           (PeerAddr 16,[],GovernorScripts {peerShareScript = Script (Nothing :| []), peerSharingScript = Script (PeerSharingDisabled :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),
           (PeerAddr 29,[],GovernorScripts {peerShareScript = Script (Nothing :| []), peerSharingScript = Script (PeerSharingDisabled :| []), 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,
@@ -3070,7 +3078,8 @@ prop_issue_3550 = prop_governor_target_established_below $
       pickHotPeersToDemote = Script (PickSome (Set.fromList [PeerAddr 29]) :| []),
       pickWarmPeersToDemote = Script (PickFirst :| []),
       pickColdPeersToForget = Script (PickFirst :| []),
-      peerSharing = PeerSharingEnabled
+      peerSharing = PeerSharingEnabled,
+      ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| [])
     }
 
 -- | issue #3515
@@ -3091,8 +3100,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),
@@ -3105,7 +3113,8 @@ prop_issue_3515 = prop_governor_nolivelock $
       pickHotPeersToDemote = Script (PickFirst :| []),
       pickWarmPeersToDemote = Script (PickFirst :| []),
       pickColdPeersToForget = Script (PickFirst :| []),
-      peerSharing = PeerSharingEnabled
+      peerSharing = PeerSharingEnabled,
+      ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| [])
     }
 
 -- | issue #3494
@@ -3124,8 +3133,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),
@@ -3140,7 +3148,8 @@ prop_issue_3494 = prop_governor_nofail $
       pickHotPeersToDemote = Script (PickFirst :| []),
       pickWarmPeersToDemote = Script (PickFirst :| []),
       pickColdPeersToForget = Script (PickFirst :| []),
-      peerSharing = PeerSharingEnabled
+      peerSharing = PeerSharingEnabled,
+      ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| [])
     }
 
 -- | issue #3233
@@ -3163,9 +3172,14 @@ prop_issue_3233 = prop_governor_nolivelock $
          (PeerAddr 13,[],GovernorScripts {peerShareScript = Script (Nothing :| []), peerSharingScript = Script (PeerSharingDisabled :| []), connectionScript = Script ((Noop,NoDelay) :| [])}),
          (PeerAddr 15,[],GovernorScripts {peerShareScript = Script (Just ([],PeerShareTimeSlow) :| []), peerSharingScript = Script (PeerSharingDisabled :| []), 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 {
@@ -3187,7 +3201,8 @@ prop_issue_3233 = prop_governor_nolivelock $
       pickHotPeersToDemote = Script (PickFirst :| []),
       pickWarmPeersToDemote = Script (PickFirst :| []),
       pickColdPeersToForget = Script (PickFirst :| []),
-      peerSharing = PeerSharingEnabled
+      peerSharing = PeerSharingEnabled,
+      ledgerStateJudgement = Script ((YoungEnough, NoDelay) :| [])
     }
 
 
@@ -3202,12 +3217,12 @@ 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
 --
 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

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs

@@ -20,6 +20,8 @@ import           Data.Word (Word32)
 import           Ouroboros.Network.PeerSelection.Governor
 
 import qualified Data.IP as IP
+import           Ouroboros.Network.PeerSelection.Bootstrap
+                     (IsBootstrapPeer (..))
 import           Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..))
 import           Ouroboros.Network.PeerSelection.PeerAdvertise
                      (PeerAdvertise (..))
@@ -64,6 +66,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