Add UseLedgerCloseToTip

Also adds lpGetPeersAfterSafeSlot consensus interface function

ouroboros-network/CHANGELOG.md

@@ -10,6 +10,17 @@
 * The constructor `FetchDeclineChainNoIntersection` was renamed to
   `FetchDeclineChainIntersectionTooDeep` (#4541)
 
+* Added `UseLedgerCloseToTip` to `UseLedger` type .
+
+  This is part of the effort of getting rid of `UseLedgerAfter` and use an automatic way to
+  distribute the load of locally configured root peers to ledger peers. However this needs
+  to be done carefully, one shouldn't start using ledger peers if it's not safe to do so.
+  A good time to switch and start using ledger peers is determined by choosing the point
+  so that the probability that a 50% stake adversarial would be chosen k times to produce
+  a block is sufficiently low.
+
+- Given the text above, `lpGetPeersAfterSafeSlot` was added.
+
 ### Non-breaking changes
 
 * Support for decoding Handshake Query Reply in wireshark dissector.

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

@@ -51,7 +51,10 @@ import           Ouroboros.Network.PeerSelection.RootPeersDNS
 import           Text.Printf
 
 -- | Only use the ledger after the given slot number.
-data UseLedgerAfter = DontUseLedger | UseLedgerAfter SlotNo deriving (Eq, Show)
+data UseLedgerAfter = DontUseLedger
+                    | UseLedgerAfter SlotNo
+                    | UseRecentLedger
+                    deriving (Eq, Show)
 
 isLedgerPeersEnabled :: UseLedgerAfter -> Bool
 isLedgerPeersEnabled DontUseLedger = False
@@ -63,8 +66,26 @@ data IsLedgerPeer = IsLedgerPeer | IsNotLedgerPeer
 
 newtype NumberOfPeers = NumberOfPeers Word16 deriving Show
 
-newtype LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface {
-      lpGetPeers :: SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
+data LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface {
+
+      -- | Return ledger peer information from given slot number.
+      --
+      lpGetPeers :: SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]),
+
+      -- | Return ledger peer information from a safe slot number.
+      --
+      -- The concrete implementation of this function comes from the consensus
+      -- layer. It plays a pivotal role in managing these peers by distributing
+      -- the load among locally configured root peers and ledger peers.
+      --
+      -- The utilization of this functionality should be exercised with caution.
+      -- Leveraging ledger peers should not commence unless it's absolutely safe.
+      -- The challenge here lies in the fact that even if the ledger peers'
+      -- distribution held 50% stake at a certain point in the past, it does not
+      -- guarantee their current honesty or availability. There's a chance that
+      -- the honest nodes have since changed their IP addresses or are no longer online.
+      --
+      lpGetRecentPeers :: STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
     }
 
 -- | Trace LedgerPeers events.
@@ -245,8 +266,13 @@ ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter LedgerPeersConsensu
                                      traceWith tracer DisabledLedgerPeers
                                      return (Map.empty, now)
                                    UseLedgerAfter slot -> do
-                                     peers_m <- atomically $ lpGetPeers slot
-                                     let peers = maybe Map.empty accPoolStake peers_m
+                                     peers <- maybe Map.empty accPoolStake
+                                              <$> atomically (lpGetPeers slot)
+                                     traceWith tracer $ FetchingNewLedgerState $ Map.size peers
+                                     return (peers, now)
+                                   UseRecentLedger -> do
+                                     peers <- maybe Map.empty accPoolStake
+                                              <$> atomically lpGetRecentPeers
                                      traceWith tracer $ FetchingNewLedgerState $ Map.size peers
                                      return (peers, now)
 

ouroboros-network/test/Test/LedgerPeers.hs

@@ -124,7 +124,10 @@ prop_pick100 seed =
                                         ]
                 )
           where
-            interface = LedgerPeersConsensusInterface $ \_ -> pure (Just (Map.elems (accPoolStake sps)))
+            interface =
+              LedgerPeersConsensusInterface
+                (\_ -> pure (Just (Map.elems (accPoolStake sps))))
+                (      pure (Just (Map.elems (accPoolStake sps))))
 
     in ioProperty $ do
         tr' <- evaluateTrace (runSimTrace sim)
@@ -162,7 +165,9 @@ prop_pick (LedgerPools lps) count seed =
                 )
           where
             interface :: LedgerPeersConsensusInterface (IOSim s)
-            interface = LedgerPeersConsensusInterface $ \_ -> pure (Just (Map.elems (accPoolStake lps)))
+            interface = LedgerPeersConsensusInterface
+                          (\_ -> pure (Just (Map.elems (accPoolStake lps))))
+                          (      pure (Just (Map.elems (accPoolStake lps))))
 
             domainMap :: Map Domain (Set IP)
             domainMap = Map.fromList [("relay.iohk.example", Set.singleton (read "2.2.2.2"))]

ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs

@@ -879,7 +879,8 @@ diffusionSimulation
               , NodeKernel.iDomainMap         = dMapVar
               , NodeKernel.iLedgerPeersConsensusInterface
                                         = LedgerPeersConsensusInterface
-                                        $ \_ -> return Nothing
+                                            (\_ -> return Nothing)
+                                            (      return Nothing)
               }
 
           shouldChainSyncExit :: StrictTVar m (Maybe BlockNo) -> BlockHeader -> m Bool