peer-selection: verify peer snapshot with hash

crocodile-dentist · crocodile-dentist · commit d078a1cee8c4 · 2025-10-31T13:14:57.000+01:00
diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal
@@ -151,6 +151,7 @@ library
     aeson,
     base >=4.14 && <4.22,
     bytestring,
+    cardano-crypto-class,
     cardano-diffusion:{api, protocols},
     containers,
     contra-tracer,
diff --git a/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs b/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+
 module Cardano.Network.LedgerPeerConsensusInterface
   ( LedgerPeersConsensusInterface (..)
     -- * Re-exports
@@ -8,11 +10,14 @@ module Cardano.Network.LedgerPeerConsensusInterface
 
 import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 
-import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..))
-
+import Cardano.Crypto.Hash (Hash, Blake2b_256)
 import Cardano.Network.LedgerStateJudgement
 import Cardano.Network.PeerSelection.LocalRootPeers
            (OutboundConnectionsState (..))
+import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..))
+import Ouroboros.Network.Block (SlotNo)
+import Ouroboros.Network.Point (Block)
+
 
 -- | Cardano Node specific consensus interface actions.
 --
@@ -31,4 +36,6 @@ data LedgerPeersConsensusInterface m =
     -- it only has local peers.
     --
   , updateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
+
+  , getBlockHash   :: forall a. SlotNo -> STM m (Block SlotNo (Hash Blake2b_256 a))
   }
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,10 @@
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds                #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE PatternSynonyms          #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
 
 -- | This module contains governor decisions for monitoring tasks:
 --
@@ -18,14 +22,18 @@ 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.Crypto.Hash as Crypto (castHash)
 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,24 +45,20 @@ 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, pattern BlockPoint, SlotNo, atSlot, withHash)
 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 (..), LedgerPeersKind (..))
 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
 import Ouroboros.Network.PeerSelection.State.LocalRootPeers
            (LocalRootConfig (..))
 import Ouroboros.Network.PeerSelection.Types
-import Ouroboros.Network.Point (Block (..), WithOrigin (..))
+import Ouroboros.Network.Point (Block (..))
 
 
 -- | Used to set 'bootstrapPeersTimeout' for crashing the node in a critical
@@ -496,8 +500,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 +528,9 @@ monitorLedgerStateJudgement PeerSelectionActions{
         Decision {
           decisionTrace = [ExtraTrace (TraceLedgerStateJudgementChanged lsj)],
           decisionJobs = case (lsj, ledgerPeerSnapshot) of
-                           (TooOld, Just ledgerPeerSnapshot') ->
-                             [jobVerifyPeerSnapshot Cardano.srvPrefix ledgerPeerSnapshot' ledgerCtx]
+                           (TooOld, Just (LedgerBigPeerSnapshotV23 point _magic _pools))
+                             | BlockPoint { atSlot, withHash } <- point ->
+                                 [jobVerifyPeerSnapshot (atSlot, withHash) lpExtraAPI]
                            _otherwise -> [],
           decisionState = st {
             extraState = cpst {
@@ -676,6 +681,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 BigLedgerPeers))
+                      -> Cardano.LedgerPeersConsensusInterface m
+                      -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers extraTrace peeraddr peerconn)
+jobVerifyPeerSnapshot (slotNo, theHash)
+                      Cardano.LedgerPeersConsensusInterface { getBlockHash }
+  = 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 $ getBlockHash slotNo
+      let result = theHash == Crypto.castHash 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/Diffusion/Types.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs
@@ -473,7 +473,7 @@ data Configuration extraFlags m ntnFd ntnAddr ntcFd ntcAddr = Configuration {
     -- 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.
-    , dcReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
+    , dcReadLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers))
 
     -- | `UseLedgerPeers` from topology file.
     --
diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE GADTs               #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -11,7 +12,6 @@
 module Ouroboros.Network.PeerSelection.Governor.Monitor
   ( targetPeers
   , jobs
-  , jobVerifyPeerSnapshot
   , connections
   , localRoots
   , ledgerPeerSnapshotChange
@@ -23,27 +23,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 +404,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 +426,9 @@ ledgerPeerSnapshotChange extraStateChange
     ledgerPeerSnapshot' <- readLedgerPeerSnapshot
     case (ledgerPeerSnapshot', ledgerPeerSnapshot) of
       (Nothing, _) -> retry
-      (Just (LedgerPeerSnapshot (slot, _)), Just (LedgerPeerSnapshot (slot', _)))
-        | slot == slot' -> retry
+      (Just (LedgerBigPeerSnapshotV23 point _magic _pools),
+       Just (LedgerBigPeerSnapshotV23 point' _magic' _pools'))
+        | 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
@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns              #-}
 {-# LANGUAGE CPP                       #-}
+{-# LANGUAGE DataKinds                 #-}
 {-# LANGUAGE DeriveFunctor             #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts          #-}
@@ -9,6 +10,7 @@
 {-# LANGUAGE RecordWildCards           #-}
 {-# LANGUAGE ScopedTypeVariables       #-}
 {-# LANGUAGE StandaloneDeriving        #-}
+{-# LANGUAGE UndecidableInstances      #-}
 {-# LANGUAGE ViewPatterns              #-}
 
 #if __GLASGOW_HASKELL__ < 904
@@ -70,6 +72,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 +88,6 @@ 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.DiffusionMode
 import Ouroboros.Network.ExitPolicy
 import Ouroboros.Network.PeerSelection.LedgerPeers.Type
@@ -351,7 +352,7 @@ data PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounter
 
        -- | Read the current state of ledger peer snapshot
        --
-       readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
+       readLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers))
      }
 
 -- | Interfaces required by the peer selection governor, which do not need to
@@ -646,7 +647,7 @@ data PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn =
 
     -- | Internal state of ledger peer snapshot
     --
-    ledgerPeerSnapshot          :: Maybe LedgerPeerSnapshot,
+    ledgerPeerSnapshot          :: Maybe (LedgerPeerSnapshot BigLedgerPeers),
 
     -- | Extension point so that 3rd party users can plug their own peer
     -- selection state if needed
diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE CPP                 #-}
+{-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DerivingStrategies  #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE LambdaCase          #-}
@@ -36,10 +37,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 +52,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
@@ -381,7 +382,7 @@ ledgerPeersThread PeerActionsDNS {
 data StakeMapOverSource = StakeMapOverSource {
     ledgerWithOrigin :: WithOrigin SlotNo,
     ledgerPeers      :: LedgerPeers,
-    peerSnapshot     :: Maybe LedgerPeerSnapshot,
+    peerSnapshot     :: Maybe (LedgerPeerSnapshot BigLedgerPeers),
     cachedSlot       :: Maybe SlotNo,
     peerMap          :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
     bigPeerMap       :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
@@ -412,7 +413,7 @@ stakeMapWithSlotOverSource StakeMapOverSource {
     -- check if we can use the snapshot first
     (ledgerSlotNo, _, Just ledgerPeerSnapshot)
       | (At snapshotSlotNo, snapshotRelays)
-        <- getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix ledgerPeerSnapshot
+        <- getRelayAccessPointsFromBigLedgerPeersSnapshot srvPrefix ledgerPeerSnapshot
       , snapshotSlotNo >= ledgerSlotNo'
       , snapshotSlotNo >= useLedgerAfter' ->
           -- we cache the peers from the snapshot
@@ -448,7 +449,7 @@ data WithLedgerPeersArgs extraAPI m = WithLedgerPeersArgs {
   -- ^ Get Ledger Peers comes from here
   wlpGetUseLedgerPeers     :: STM m UseLedgerPeers,
   -- ^ Get Use Ledger After value
-  wlpGetLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot),
+  wlpGetLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers)),
   -- ^ Get ledger peer snapshot from file read by node
   wlpSemaphore             :: DNSSemaphore m,
   wlpSRVPrefix             :: SRVPrefix
