peer-selection: verify peer snapshot with hash

crocodile-dentist · crocodile-dentist · commit fc58da38217f · 2025-10-28T14:59:30.000+01:00
diff --git a/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs b/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs
@@ -8,11 +8,14 @@ module Cardano.Network.LedgerPeerConsensusInterface
 
 import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 
-import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..))
-
 import Cardano.Network.LedgerStateJudgement
+import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot)
 import Cardano.Network.PeerSelection.LocalRootPeers
            (OutboundConnectionsState (..))
+import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..))
+import Ouroboros.Network.Block (HeaderHash, SlotNo)
+import Ouroboros.Network.Point (Block)
+
 
 -- | Cardano Node specific consensus interface actions.
 --
@@ -31,4 +34,6 @@ data LedgerPeersConsensusInterface m =
     -- it only has local peers.
     --
   , updateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
+
+  , lpGetBlockInfo   :: SlotNo -> STM m (Block SlotNo (HeaderHash LedgerPeerSnapshot))
   }
diff --git a/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs b/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
 
 -- | This module contains governor decisions for monitoring tasks:
 --
@@ -18,14 +19,17 @@ module Cardano.Network.PeerSelection.Governor.Monitor
   , ExtraTrace (..)
   ) where
 
-import Data.Set qualified as Set
-
+import Control.Concurrent.JobPool (Job (..))
+import Control.Exception (assert)
 import Control.Monad.Class.MonadSTM
 import Control.Monad.Class.MonadTime.SI
 import Control.Monad.Class.MonadTimer.SI
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Set (Set)
+import Data.Set qualified as Set
 
 import Cardano.Network.ConsensusMode
-import Cardano.Network.Diffusion.Configuration qualified as Cardano (srvPrefix)
 import Cardano.Network.LedgerPeerConsensusInterface qualified as Cardano
 import Cardano.Network.LedgerStateJudgement
 import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..),
@@ -37,17 +41,13 @@ import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Ca
 import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
 import Cardano.Network.PeerSelection.PublicRootPeers qualified as Cardano.PublicRootPeers
 import Cardano.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers
-import Control.Exception (assert)
-import Data.Map.Strict (Map)
-import Data.Map.Strict qualified as Map
-import Data.Set (Set)
+import Ouroboros.Network.Block (HeaderHash, Point (..), SlotNo)
 import Ouroboros.Network.PeerSelection.Governor.ActivePeers
            (jobDemoteActivePeer)
-import Ouroboros.Network.PeerSelection.Governor.Monitor (jobVerifyPeerSnapshot)
 import Ouroboros.Network.PeerSelection.Governor.Types hiding
            (PeerSelectionCounters)
 import Ouroboros.Network.PeerSelection.LedgerPeers.Type
-           (LedgerPeersConsensusInterface (..))
+           (LedgerPeersConsensusInterface (..), LedgerPeerSnapshot (..))
 import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
 import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers
 import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers
@@ -496,8 +496,8 @@ monitorLedgerStateJudgement
             (TimedDecision m Cardano.ExtraState extraDebugState extraFlags
                              (Cardano.ExtraPeers peeraddr) ExtraTrace peeraddr peerconn)
 monitorLedgerStateJudgement PeerSelectionActions{
-                              getLedgerStateCtx = ledgerCtx@LedgerPeersConsensusInterface {
-                                lpExtraAPI = Cardano.LedgerPeersConsensusInterface {
+                              getLedgerStateCtx = LedgerPeersConsensusInterface {
+                                lpExtraAPI = lpExtraAPI@Cardano.LedgerPeersConsensusInterface {
                                   Cardano.getLedgerStateJudgement = readLedgerStateJudgement
                                 }
                               }
@@ -524,8 +524,9 @@ monitorLedgerStateJudgement PeerSelectionActions{
         Decision {
           decisionTrace = [ExtraTrace (TraceLedgerStateJudgementChanged lsj)],
           decisionJobs = case (lsj, ledgerPeerSnapshot) of
-                           (TooOld, Just ledgerPeerSnapshot') ->
-                             [jobVerifyPeerSnapshot Cardano.srvPrefix ledgerPeerSnapshot' ledgerCtx]
+                           (TooOld, Just (LedgerPeerSnapshotV3 point _pools))
+                             | Point (At Block { blockPointSlot, blockPointHash } ) <- point ->
+                                 [jobVerifyPeerSnapshot (blockPointSlot, blockPointHash) lpExtraAPI]
                            _otherwise -> [],
           decisionState = st {
             extraState = cpst {
@@ -676,6 +677,35 @@ waitForSystemToQuiesce st@PeerSelectionState{
   | otherwise = GuardedSkip Nothing
 
 
+-- |This job, which is initiated by monitorLedgerStateJudgement job,
+-- verifies whether the provided big ledger pools match up with the
+-- ledger state once the node catches up to the slot at which the
+-- snapshot was ostensibly taken
+--
+jobVerifyPeerSnapshot :: (MonadSTM m)
+                      => (SlotNo, HeaderHash LedgerPeerSnapshot)
+                      -> Cardano.LedgerPeersConsensusInterface m
+                      -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers extraTrace peeraddr peerconn)
+jobVerifyPeerSnapshot (slotNo, theHash)
+                      Cardano.LedgerPeersConsensusInterface { lpGetBlockInfo }
+  = Job job (const (completion False)) () "jobVerifyPeerSnapshot"
+  where
+    completion result = return . Completion $ \st _now ->
+      Decision {
+        decisionTrace = [TraceVerifyPeerSnapshot result],
+        decisionState = st,
+        decisionJobs  = [] }
+
+    job = do
+      Block { blockPointHash } <- atomically $ lpGetBlockInfo slotNo
+      let result = theHash == blockPointHash
+      return . Completion $ \st _now ->
+            Decision {
+              decisionTrace = [TraceVerifyPeerSnapshot result],
+              decisionState = st,
+              decisionJobs  = [] }
+
+
 -- | Extra trace points for `TracePeerSelection`.
 --
 -- TODO: it ought to be moved to `Types`, but that introduces a circular
diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs
@@ -11,7 +11,6 @@
 module Ouroboros.Network.PeerSelection.Governor.Monitor
   ( targetPeers
   , jobs
-  , jobVerifyPeerSnapshot
   , connections
   , localRoots
   , ledgerPeerSnapshotChange
@@ -23,27 +22,21 @@ import Data.Maybe (fromMaybe, isJust)
 import Data.Set (Set)
 import Data.Set qualified as Set
 
-import Control.Concurrent.JobPool (Job (..), JobPool)
+import Control.Concurrent.JobPool (JobPool)
 import Control.Concurrent.JobPool qualified as JobPool
 import Control.Exception (assert)
 import Control.Monad.Class.MonadSTM
 import Control.Monad.Class.MonadTime.SI
 import Control.Monad.Class.MonadTimer.SI
 import System.Random (randomR)
 
-import Ouroboros.Network.Block (HeaderHash, SlotNo)
 import Ouroboros.Network.ExitPolicy (RepromoteDelay)
 import Ouroboros.Network.ExitPolicy qualified as ExitPolicy
 import Ouroboros.Network.PeerSelection.Governor.ActivePeers
            (jobDemoteActivePeer)
 import Ouroboros.Network.PeerSelection.Governor.Types hiding
            (PeerSelectionCounters)
-import Ouroboros.Network.PeerSelection.LedgerPeers.Type
-           (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..),
-           SRVPrefix, compareLedgerPeerSnapshotApproximate,
-           getRelayAccessPointsFromLedger,
-           getRelayAccessPointsFromLedgerPeerSnapshot)
-import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
+import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot (..))
 import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
 import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers
 import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers
@@ -410,38 +403,6 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers
                             | (peeraddr, peerconn) <- Map.assocs selectedToDemote' ]
           }
 
--- |This job, which is initiated by monitorLedgerStateJudgement job,
--- verifies whether the provided big ledger pools match up with the
--- ledger state once the node catches up to the slot at which the
--- snapshot was ostensibly taken
---
-jobVerifyPeerSnapshot :: MonadSTM m
-                      => SRVPrefix
-                      -> LedgerPeerSnapshot
-                      -> LedgerPeersConsensusInterface extraAPI m
-                      -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers extraTrace peeraddr peerconn)
-jobVerifyPeerSnapshot srvPrefix
-                      ledgerPeerSnapshot
-                      ledgerCtx@LedgerPeersConsensusInterface { lpGetLatestSlot }
-  = Job job (const (completion False)) () "jobVerifyPeerSnapshot"
-  where
-    (slot, snapshotPeers) =
-      getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix ledgerPeerSnapshot
-
-    completion result = return . Completion $ \st _now ->
-      Decision {
-        decisionTrace = [TraceVerifyPeerSnapshot result],
-        decisionState = st,
-        decisionJobs  = [] }
-
-    job = do
-      ledgerPeers <-
-        atomically $ do
-          check . (>= slot) =<< lpGetLatestSlot
-          accumulateBigLedgerStake <$> getRelayAccessPointsFromLedger srvPrefix ledgerCtx
-      completion $ snapshotPeers
-                   `compareLedgerPeerSnapshotApproximate`
-                   ledgerPeers
 
 -- |This job monitors for any changes in the big ledger peer snapshot
 -- and flips ledger state judgement private state so that monitoring action
@@ -464,8 +425,8 @@ ledgerPeerSnapshotChange extraStateChange
     ledgerPeerSnapshot' <- readLedgerPeerSnapshot
     case (ledgerPeerSnapshot', ledgerPeerSnapshot) of
       (Nothing, _) -> retry
-      (Just (LedgerPeerSnapshot (slot, _)), Just (LedgerPeerSnapshot (slot', _)))
-        | slot == slot' -> retry
+      (Just (LedgerPeerSnapshot point _), Just (LedgerPeerSnapshot point' _))
+        | point == point' -> retry
       _otherwise ->
         return $ \_now ->
                    Decision { decisionTrace = [],
diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs
@@ -70,6 +70,11 @@ module Ouroboros.Network.PeerSelection.Governor.Types
   , DemotionTimeoutException (..)
   ) where
 
+import Control.Applicative (Alternative)
+import Control.Concurrent.Class.MonadSTM.Strict
+import Control.Concurrent.JobPool (Job)
+import Control.Exception (Exception (..), SomeException, assert)
+import Control.Monad.Class.MonadTime.SI
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe)
@@ -81,12 +86,7 @@ import Data.Set qualified as Set
 import GHC.Stack (HasCallStack)
 import System.Random (StdGen)
 
-import Control.Applicative (Alternative)
-import Control.Concurrent.Class.MonadSTM.Strict
-import Control.Concurrent.JobPool (Job)
-import Control.Exception (Exception (..), SomeException, assert)
-import Control.Monad.Class.MonadTime.SI
-
+import Ouroboros.Network.Block
 import Ouroboros.Network.DiffusionMode
 import Ouroboros.Network.ExitPolicy
 import Ouroboros.Network.PeerSelection.LedgerPeers.Type
@@ -1839,4 +1839,5 @@ deriving instance ( Show extraState
                   , Show extraPeers
                   , Ord peeraddr
                   , Show peeraddr
+                  , StandardHash LedgerPeerSnapshot
                   ) => Show (DebugPeerSelection extraState extraFlags extraPeers peeraddr)
diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs
@@ -36,10 +36,12 @@ module Ouroboros.Network.PeerSelection.LedgerPeers
   , resolveLedgerPeers
   ) where
 
+import Control.Concurrent.Class.MonadSTM.Strict
 import Control.Monad (when)
 import Control.Monad.Class.MonadAsync
 import Control.Monad.Class.MonadFork
 import Control.Monad.Class.MonadTime.SI
+import Control.Monad.Class.MonadThrow
 import Control.Tracer (Tracer, traceWith)
 import Data.IP qualified as IP
 import Data.List as List (foldl')
@@ -49,16 +51,14 @@ import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Maybe (isJust)
 import Data.Ratio
-import System.Random
-import Text.Printf
-
-import Control.Concurrent.Class.MonadSTM.Strict
-import Control.Monad.Class.MonadThrow
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Void (Void)
 import Data.Word (Word16, Word64)
 import Network.DNS qualified as DNS
+import System.Random
+import Text.Printf
+
 import Ouroboros.Network.Block (SlotNo)
 import Ouroboros.Network.PeerSelection.LedgerPeers.Type
 import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
