Enable distribution of big ledger peers obtained from snapshot:

Depending on its topology configuration, a node may provide diffusion
layer with a snapshot of big ledger peers from some slot. This value
is provided as an argument when diffusion is initialized, and is
provided to ledgerPeersThread function, which contains the logic
when these peers, if any, can be provided to peer selection governor
when it requests them. This is especially useful when consensus is
ran in Genesis mode and when the node is bootstrapping so it may have
opportunity to connect to these trustworthy peers when they may not
be yet available on its own ledger.

ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs

@@ -15,6 +15,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type
   , UseLedgerPeers (..)
   , AfterSlot (..)
   , LedgerPeersKind (..)
+  , LedgerPeerSnapshot (..)
   , isLedgerPeersEnabled
   ) where
 
@@ -27,6 +28,15 @@ import GHC.Generics
 import NoThunks.Class
 import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint)
 
+-- | Peer snapshot type used to serialize peers from the
+-- current state of a node's ledger:
+-- LocalStateQuery app server running in ouroboros-consensus-diffusion
+-- receives a query (eg. cardano-cli) demanding a dump of this data
+-- from the current ledger. Consensus uses CBOR.
+newtype LedgerPeerSnapshot = LedgerPeerSnapshot
+  { unLedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]) }
+  deriving newtype (Show, ToCBOR, FromCBOR)
+
 -- | Which ledger peers to pick.
 --
 data LedgerPeersKind = AllLedgerPeers | BigLedgerPeers
@@ -52,14 +62,14 @@ isLedgerPeersEnabled UseLedgerPeers {}  = True
 --
 newtype PoolStake = PoolStake { unPoolStake :: Rational }
   deriving (Eq, Ord, Show)
-  deriving newtype (Fractional, Num, NFData, ToCBOR, FromCBOR)
+  deriving newtype (Fractional, Num, NFData, ToCBOR, FromCBOR) -- CBOR to support LedgerPeerSnapshot
 
 -- | The accumulated relative stake of a stake pool, like PoolStake but it also includes the
 -- relative stake of all preceding pools. A value in the range [0, 1].
 --
 newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational }
     deriving (Eq, Ord, Show)
-    deriving newtype (Fractional, Num)
+    deriving newtype (Fractional, Num, FromCBOR, ToCBOR) -- CBOR to support LedgerPeerSnapshot
 
 -- | A boolean like type.  Big ledger peers are the largest SPOs which control
 -- 90% of staked stake.

ouroboros-network/CHANGELOG.md

@@ -14,6 +14,12 @@
 * moved `accBigPoolStake` and `reRelativeStake` to ouroboros-networking-api
   in order to expose functionality of creating snapshots of big ledger peers,
   eg. for Genesis consensus mode.
+* Introduced `daReadLedgerPeerSnapshot` to `P2P.ArgumentsExtra` which holds
+  a `Maybe LedgerPeerSnapshot` from a node's configuration. If present, it
+  may be used to pick big ledger peers by the peer selection governor when
+  bootstrapping a node in Genesis consensus mode, or in general when 
+  LedgerStateJudgement = TooOld, subject to conditions in
+  `LedgerPeers.ledgerPeersThread`.
 
 ### Non-Breaking changes
 

ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs

@@ -112,8 +112,8 @@ import Ouroboros.Network.PeerSelection.Governor.Types
 #endif
 import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers,
            WithLedgerPeersArgs (..))
-import Ouroboros.Network.PeerSelection.LedgerPeers.Type
-           (LedgerPeersConsensusInterface (..), UseLedgerPeers)
+import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot,
+           LedgerPeersConsensusInterface (..), UseLedgerPeers)
 #ifdef POSIX
 import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics,
            fetchynessBlocks, upstreamyness)
@@ -251,6 +251,12 @@ data ArgumentsExtra m = ArgumentsExtra {
     , daReadLocalRootPeers  :: STM m [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
     , daReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise)
     , daReadUseBootstrapPeers :: STM m UseBootstrapPeers
+    -- | Depending on configuration, node may provide us with
+    -- a snapshot of big ledger peers taken at some slot on the chain.
+    -- These peers may be selected by ledgerPeersThread when requested
+    -- by the peer selection governor when the node is syncing up.
+    -- This is especially useful for Genesis consensus mode.
+    , daReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
 
     -- | Peer's own PeerSharing value.
     --
@@ -638,6 +644,7 @@ runM Interfaces
        , daTimeWaitTimeout
        , daDeadlineChurnInterval
        , daBulkChurnInterval
+       , daReadLedgerPeerSnapshot
        }
      Applications
        { daApplicationInitiatorMode
@@ -988,7 +995,8 @@ runM Interfaces
                                          wlpRng = ledgerPeersRng,
                                          wlpConsensusInterface = daLedgerPeersCtx,
                                          wlpTracer = dtTraceLedgerPeersTracer,
-                                         wlpGetUseLedgerPeers = daReadUseLedgerPeers }
+                                         wlpGetUseLedgerPeers = daReadUseLedgerPeers,
+                                         wlpGetLedgerPeerSnapshot = daReadLedgerPeerSnapshot }
 
           peerSelectionGovernor'
             :: forall (muxMode :: MuxMode) b.

ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE ViewPatterns        #-}
 #if __GLASGOW_HASKELL__ >= 908
 {-# OPTIONS_GHC -Wno-x-partial #-}
 #endif
@@ -222,9 +223,12 @@ ledgerPeersThread PeerActionsDNS {
                     paDnsSemaphore }
                   WithLedgerPeersArgs {
                     wlpRng,
-                    wlpConsensusInterface,
+                    wlpConsensusInterface = wlpConsensusInterface@LedgerPeersConsensusInterface {
+                      lpGetLatestSlot,
+                      lpGetLedgerStateJudgement },
                     wlpTracer,
-                    wlpGetUseLedgerPeers }
+                    wlpGetUseLedgerPeers,
+                    wlpGetLedgerPeerSnapshot }
                   getReq
                   putResp = do
     go wlpRng (Time 0) Map.empty Map.empty
@@ -255,20 +259,33 @@ ledgerPeersThread PeerActionsDNS {
                  traceWith wlpTracer DisabledLedgerPeers
                  return (Map.empty, Map.empty, now)
                UseLedgerPeers ula -> do
-                 peers <- (\case
-                            BeforeSlot          -> []
-                            LedgerPeers _ peers -> peers
-                          )
-                      <$> atomically (getLedgerPeers wlpConsensusInterface ula)
-                 let peersStake   = accPoolStake peers
-                     bigPeersStakeMap = accBigPoolStakeMap peers
+                 (ledgerStateJudgement, consensusSlotNo, consensusPeers, peerSnapshot) <-
+                   atomically ((,,,) <$> lpGetLedgerStateJudgement
+                                     <*> lpGetLatestSlot
+                                     <*> getLedgerPeers wlpConsensusInterface ula
+                                     <*> wlpGetLedgerPeerSnapshot)
+
+                 -- we have to assess which of, if any, peers we get from consensus vs.
+                 -- peers we may have from the snapshot file is more recent, and use that
+                 let (accPoolStake -> peersStake, bigPeersStakeMap) =
+                       case (consensusSlotNo, consensusPeers, peerSnapshot) of
+                         (At t, LedgerPeers _ lp, Just (LedgerPeerSnapshot (At t', sp {- snapshot peer-})))
+                           | t' > t -> (lp, Map.fromAscList sp)
+                           | otherwise -> (lp, accBigPoolStakeMap lp)
+
+                         (_, LedgerPeers _ lp, Nothing) -> (lp, accBigPoolStakeMap lp)
+
+                         (_, _, Just (LedgerPeerSnapshot (At t', sp)))
+                           | After slot <- ula, t' >= slot -> ([], Map.fromAscList sp)
+                         otherwise -> ([], Map.empty)
+
                  traceWith wlpTracer $ FetchingNewLedgerState (Map.size peersStake) (Map.size bigPeersStakeMap)
                  return (peersStake, bigPeersStakeMap, now)
              else do
                traceWith wlpTracer $ ReusingLedgerState (Map.size peerMap) age
                return (peerMap, bigPeerMap, oldTs)
 
-        if Map.null peerMap'
+        if all Map.null [peerMap', bigPeerMap']
            then do
                when (isLedgerPeersEnabled useLedgerPeers) $
                    traceWith wlpTracer FallingBackToPublicRootPeers
@@ -341,13 +358,15 @@ ledgerPeersThread PeerActionsDNS {
 -- | Argument record for withLedgerPeers
 --
 data WithLedgerPeersArgs m = WithLedgerPeersArgs {
-  wlpRng                :: StdGen,
+  wlpRng                   :: StdGen,
   -- ^ Random generator for picking ledger peers
-  wlpConsensusInterface :: LedgerPeersConsensusInterface m,
-  wlpTracer             :: Tracer m TraceLedgerPeers,
+  wlpConsensusInterface    :: LedgerPeersConsensusInterface m,
+  wlpTracer                :: Tracer m TraceLedgerPeers,
   -- ^ Get Ledger Peers comes from here
-  wlpGetUseLedgerPeers  :: STM m UseLedgerPeers
+  wlpGetUseLedgerPeers     :: STM m UseLedgerPeers,
   -- ^ Get Use Ledger After value
+  wlpGetLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
+  -- ^ Get ledger peer snapshot from file read by node
   }
 
 -- | For a LedgerPeers worker thread and submit request and receive responses.