Bugfix

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

@@ -25,6 +25,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type
   , LedgerPeersKind (..)
   , LedgerPeerSnapshot (.., LedgerPeerSnapshot)
   , isLedgerPeersEnabled
+  , compareLedgerPeerSnapshotApproximate
   ) where
 
 import Control.Monad (forM)
@@ -63,6 +64,26 @@ pattern LedgerPeerSnapshot payload <- LedgerPeerSnapshotV1 payload where
 
 {-# COMPLETE LedgerPeerSnapshot #-}
 
+-- | Since ledger peer snapshot is serialised with all domain names
+--   fully qualified, and all stake values are approximate in floating
+--   point, comparison is necessarily approximate as well.
+--   The candidate argument is processed here to simulate a round trip
+--   by the serialisation mechanism and then compared to the baseline
+--   argument, which is assumed that it was actually processed this way
+--   when a snapshot was created earlier, and hence it is approximate as well.
+--   The two approximate values should be equal if they were created
+--   from the same 'faithful' data.
+--
+compareLedgerPeerSnapshotApproximate :: LedgerPeerSnapshot
+                                     -> LedgerPeerSnapshot
+                                     -> Bool
+compareLedgerPeerSnapshotApproximate baseline candidate =
+  case tripIt of
+    Success candidate' -> candidate' == baseline
+    Error _            -> False
+  where
+    tripIt = fromJSON . toJSON $ candidate
+
 -- | In case the format changes in the future, this function provides a migration functionality
 -- when possible.
 --

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

@@ -603,6 +603,10 @@ peerSelectionGovernorLoop tracer
       -- Trace peer selection
       traverse_ (traceWith tracer) decisionTrace
 
+      case decisionTrace of
+        [TraceVerifyPeerSnapshot False] -> throwIO BigLedgerPeerSnapshotError
+        _otherwise                      -> pure ()
+
       mapM_ (JobPool.forkJob jobPool) decisionJobs
       loop st'' dbgUpdateAt'
 

ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs

@@ -23,15 +23,14 @@ module Ouroboros.Network.PeerSelection.Governor.Monitor
 
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
-import Data.Maybe (fromMaybe, isJust, maybeToList)
+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 qualified as JobPool
 import Control.Exception (assert)
 import Control.Monad.Class.MonadSTM
-import Control.Monad.Class.MonadThrow
 import Control.Monad.Class.MonadTime.SI
 import System.Random (randomR)
 
@@ -46,7 +45,7 @@ import Ouroboros.Network.PeerSelection.Governor.Types hiding
            (PeerSelectionCounters)
 import Ouroboros.Network.PeerSelection.LedgerPeers.Type
            (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..),
-           LedgerStateJudgement (..))
+           LedgerStateJudgement (..), compareLedgerPeerSnapshotApproximate)
 import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
 import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
 import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
@@ -600,7 +599,6 @@ monitorBootstrapPeersFlag PeerSelectionActions { readUseBootstrapPeers }
 -- to a clean state. I.e., it will disconnect from the targets source of truth.
 --
 monitorLedgerStateJudgement :: ( MonadSTM m
-                               , MonadThrow m
                                , Ord peeraddr
                                )
                             => PeerSelectionActions peeraddr peerconn m
@@ -761,34 +759,29 @@ waitForSystemToQuiesce st@PeerSelectionState{
 -- ledger state once the node catches up to the slot at which the
 -- snapshot was ostensibly taken
 --
-jobVerifyPeerSnapshot :: ( MonadSTM m
-                         , MonadThrow m)
+jobVerifyPeerSnapshot :: ( MonadSTM m )
                       => LedgerPeerSnapshot
                       -> LedgerPeersConsensusInterface m
                       -> Job () m (Completion m peeraddr peerconn)
-jobVerifyPeerSnapshot (LedgerPeerSnapshot (slot, relays))
+jobVerifyPeerSnapshot baseline@(LedgerPeerSnapshot (slot, _))
                       LedgerPeersConsensusInterface {
                         lpGetLatestSlot,
                         lpGetLedgerPeers }
-  = Job job
-        throwIO
-        ()
-        "jobVerifyPeerSnapshot"
+  = Job job (const (completion False)) () "jobVerifyPeerSnapshot"
   where
-    completion queueJob trace = return . Completion $ \st _now ->
+    completion result = return . Completion $ \st _now ->
       Decision {
-        decisionTrace = maybeToList trace,
+        decisionTrace = [TraceVerifyPeerSnapshot result],
         decisionState = st,
-        decisionJobs  = maybeToList queueJob }
+        decisionJobs  = [] }
 
     job = do
-      result <-
+      ledgerPeers <-
         atomically $ do
-          check . (slot >=) =<< lpGetLatestSlot
-          (relays ==) . accumulateBigLedgerStake <$> lpGetLedgerPeers
-      if result
-        then completion Nothing (Just $ TraceVerifyPeerSnapshot result)
-        else throwIO BigLedgerPeerSnapshotError
+          check . (>= slot) =<< lpGetLatestSlot
+          accumulateBigLedgerStake <$> lpGetLedgerPeers
+      let candidate = LedgerPeerSnapshot (slot, ledgerPeers) -- ^ slot here is intentional
+      completion $ compareLedgerPeerSnapshotApproximate baseline candidate
 
 -- |This job monitors for any changes in the big ledger peer snapshot
 -- and flips ledger state judgement private state so that monitoring action