From 7977e6d14f46a5c6b8122db49d6473fd681d9cc2 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 17:34:41 +0200
Subject: [PATCH 01/42] ChainSel: `olderThanK` -> `olderThanImmTip`

---
 .../Test/Consensus/PeerSimulator/Trace.hs     |  4 +-
 ...9_alexander.esgen_decouple_immutability.md |  4 ++
 .../Storage/ChainDB/Impl/ChainSel.hs          | 38 ++++++++-----------
 .../Consensus/Storage/ChainDB/Impl/Types.hs   |  5 +--
 .../Test/Ouroboros/Storage/ChainDB/Model.hs   |  4 +-
 5 files changed, 26 insertions(+), 29 deletions(-)
 create mode 100644 ouroboros-consensus/changelog.d/20250811_130239_alexander.esgen_decouple_immutability.md

diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs
index feda424c51..d7acdf1fdc 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs
@@ -418,8 +418,8 @@ traceChainDBEventTestBlockWith tracer = \case
         trace $ "Switched to a fork; now: " ++ terseHFragment newFragment
       StoreButDontChange point ->
         trace $ "Did not select block due to LoE: " ++ terseRealPoint point
-      IgnoreBlockOlderThanK point ->
-        trace $ "Ignored block older than k: " ++ terseRealPoint point
+      IgnoreBlockOlderThanImmTip point ->
+        trace $ "Ignored block older than imm tip: " ++ terseRealPoint point
       ChainSelectionLoEDebug curChain (LoEEnabled loeFrag0) -> do
         trace $ "Current chain: " ++ terseHFragment curChain
         trace $ "LoE fragment: " ++ terseHFragment loeFrag0
diff --git a/ouroboros-consensus/changelog.d/20250811_130239_alexander.esgen_decouple_immutability.md b/ouroboros-consensus/changelog.d/20250811_130239_alexander.esgen_decouple_immutability.md
new file mode 100644
index 0000000000..43ecf32dcd
--- /dev/null
+++ b/ouroboros-consensus/changelog.d/20250811_130239_alexander.esgen_decouple_immutability.md
@@ -0,0 +1,4 @@
+### Breaking
+
+- Renamed `IgnoreBlockOlderThanK` to `IgnoreBlockOlderThanImmTip` for future-proofing.
+- Renamed and simplified `olderThanK` to `olderThanImmTip`.
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
index 1fbd49f467..af3c9b35da 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -19,7 +19,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel
   , triggerChainSelectionAsync
 
     -- * Exported for testing purposes
-  , olderThanK
+  , olderThanImmTip
   ) where
 
 import Cardano.Ledger.BaseTypes (unNonZero)
@@ -404,8 +404,8 @@ chainSelSync cdb@CDB{..} (ChainSelAddBlock BlockToAdd{blockToAdd = b, ..}) = do
   -- We follow the steps from section "## Adding a block" in ChainDB.md
 
   if
-    | olderThanK hdr isEBB immBlockNo -> do
-        lift $ traceWith addBlockTracer $ IgnoreBlockOlderThanK (blockRealPoint b)
+    | olderThanImmTip hdr immBlockNo -> do
+        lift $ traceWith addBlockTracer $ IgnoreBlockOlderThanImmTip (blockRealPoint b)
         lift $ deliverWrittenToDisk False
     | isMember (blockHash b) -> do
         lift $ traceWith addBlockTracer $ IgnoreBlockAlreadyInVolatileDB (blockRealPoint b)
@@ -459,31 +459,28 @@ chainSelSync cdb@CDB{..} (ChainSelAddBlock BlockToAdd{blockToAdd = b, ..}) = do
 
 -- | Return 'True' when the given header should be ignored when adding it
 -- because it is too old, i.e., we wouldn't be able to switch to a chain
--- containing the corresponding block because its block number is more than
--- @k@ blocks or exactly @k@ blocks back.
+-- containing the corresponding block because its block number is (weakly) older
+-- than that of the immutable tip.
 --
 -- Special case: the header corresponds to an EBB which has the same block
--- number as the block @k@ blocks back (the most recent \"immutable\" block).
--- As EBBs share their block number with the block before them, the EBB is not
--- too old in that case and can be adopted as part of our chain.
+-- number as the most recent \"immutable\" block. As EBBs share their block
+-- number with the block before them, the EBB is not too old in that case and
+-- can be adopted as part of our chain.
 --
 -- This special case can occur, for example, when the VolatileDB is empty
 -- (because of corruption). The \"immutable\" block is then also the tip of
 -- the chain. If we then try to add the EBB after it, it will have the same
 -- block number, so we must allow it.
-olderThanK ::
-  HasHeader (Header blk) =>
+olderThanImmTip ::
+  GetHeader blk =>
   -- | Header of the block to add
   Header blk ->
-  -- | Whether the block is an EBB or not
-  IsEBB ->
-  -- | The block number of the most recent \"immutable\" block, i.e., the
-  -- block @k@ blocks back.
+  -- | The block number of the most recent immutable block.
   WithOrigin BlockNo ->
   Bool
-olderThanK hdr isEBB immBlockNo
+olderThanImmTip hdr immBlockNo
   | NotOrigin bNo == immBlockNo
-  , isEBB == IsEBB =
+  , headerToIsEBB hdr == IsEBB =
       False
   | otherwise =
       NotOrigin bNo <= immBlockNo
@@ -594,9 +591,9 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
 
     if
       -- The chain might have grown since we added the block such that the
-      -- block is older than @k@.
-      | olderThanK hdr isEBB immBlockNo -> do
-          traceWith addBlockTracer $ IgnoreBlockOlderThanK p
+      -- block is older than the immutable tip.
+      | olderThanImmTip hdr immBlockNo -> do
+          traceWith addBlockTracer $ IgnoreBlockOlderThanImmTip p
 
       -- The block is invalid
       | Just (InvalidBlockInfo reason _) <- Map.lookup (headerHash hdr) invalid -> do
@@ -636,9 +633,6 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
   p :: RealPoint blk
   p = headerRealPoint hdr
 
-  isEBB :: IsEBB
-  isEBB = headerToIsEBB hdr
-
   addBlockTracer :: Tracer m (TraceAddBlockEvent blk)
   addBlockTracer = TraceAddBlockEvent >$< cdbTracer
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
index 6c2d7eb909..3fe7ca9ab6 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
@@ -811,9 +811,8 @@ deriving stock instance
 
 -- | Trace type for the various events that occur when adding a block.
 data TraceAddBlockEvent blk
-  = -- | A block with a 'BlockNo' more than @k@ back than the current tip was
-    -- ignored.
-    IgnoreBlockOlderThanK (RealPoint blk)
+  = -- | A block with a 'BlockNo' not newer than the immutable tip was ignored.
+    IgnoreBlockOlderThanImmTip (RealPoint blk)
   | -- | A block that is already in the Volatile DB was ignored.
     IgnoreBlockAlreadyInVolatileDB (RealPoint blk)
   | -- | A block that is know to be invalid was ignored.
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
index 3369265f5e..d8cbf1acb0 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
@@ -122,7 +122,7 @@ import Ouroboros.Consensus.Storage.ChainDB.API
   , UnknownRange (..)
   , validBounds
   )
-import Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel (olderThanK)
+import Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel (olderThanImmTip)
 import Ouroboros.Consensus.Storage.Common ()
 import Ouroboros.Consensus.Util (repeatedly)
 import qualified Ouroboros.Consensus.Util.AnchoredFragment as Fragment
@@ -415,7 +415,7 @@ addBlock cfg blk m
   ignoreBlock =
     -- If the block is as old as the tip of the ImmutableDB, i.e. older
     -- than @k@, we ignore it, as we can never switch to it.
-    olderThanK hdr (headerToIsEBB hdr) immBlockNo
+    olderThanImmTip hdr immBlockNo
       ||
       -- If it's an invalid block we've seen before, ignore it.
       Map.member (blockHash blk) (invalid m)

From 7b957349f247f41c8412a4c91ddb1e0984a68c7d Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 21:18:44 +0200
Subject: [PATCH 02/42] ChainDB.Background: avoid hardcoding immutability
 criterion

This is preparing for Peras, which will introduce a refined immutability
criterion. Due to this change, we defer the immutability criterion to the
implementation of `getCurrentChain`, reducing the impact of Peras.
---
 .../Storage/ChainDB/Impl/Background.hs        | 42 ++++++++++---------
 1 file changed, 22 insertions(+), 20 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
index ed8ce9bc97..3df09ab9ea 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
@@ -41,7 +41,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Background
   , addBlockRunner
   ) where
 
-import Cardano.Ledger.BaseTypes (unNonZero)
 import Control.Exception (assert)
 import Control.Monad (forM_, forever, void)
 import Control.Monad.Trans.Class (lift)
@@ -57,7 +56,6 @@ import Data.Word
 import GHC.Generics (Generic)
 import GHC.Stack (HasCallStack)
 import Ouroboros.Consensus.Block
-import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.HardFork.Abstract
 import Ouroboros.Consensus.Ledger.Inspect
 import Ouroboros.Consensus.Ledger.SupportsProtocol
@@ -69,6 +67,7 @@ import Ouroboros.Consensus.Storage.ChainDB.API
 import Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel
   ( chainSelSync
   )
+import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query
 import Ouroboros.Consensus.Storage.ChainDB.Impl.Types
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
@@ -132,10 +131,11 @@ launchBgTasks cdb@CDB{..} replayed = do
   Copying blocks from the VolatileDB to the ImmutableDB
 -------------------------------------------------------------------------------}
 
--- | Copy the blocks older than @k@ from the VolatileDB to the ImmutableDB.
+-- | Copy the blocks older than the immutable tip from the VolatileDB to the
+-- ImmutableDB.
 --
--- These headers of these blocks can be retrieved by dropping the @k@ most
--- recent blocks from the fragment stored in 'cdbChain'.
+-- The headers of these blocks can be retrieved by considering headers in
+-- 'cdbChain' that are not also in 'getCurrentChain' (a suffix of 'cdbChain').
 --
 -- The copied blocks are removed from the fragment stored in 'cdbChain'.
 --
@@ -153,10 +153,11 @@ copyToImmutableDB ::
   ) =>
   ChainDbEnv m blk ->
   Electric m (WithOrigin SlotNo)
-copyToImmutableDB CDB{..} = electric $ do
+copyToImmutableDB cdb@CDB{..} = electric $ do
   toCopy <- atomically $ do
     curChain <- icWithoutTime <$> readTVar cdbChain
-    let nbToCopy = max 0 (AF.length curChain - fromIntegral (unNonZero k))
+    curChainVolSuffix <- Query.getCurrentChain cdb
+    let nbToCopy = max 0 $ AF.length curChain - AF.length curChainVolSuffix
         toCopy :: [Point blk]
         toCopy =
           map headerPoint $
@@ -165,10 +166,10 @@ copyToImmutableDB CDB{..} = electric $ do
     return toCopy
 
   if null toCopy
-    -- This can't happen in practice, as we're only called when the fragment
-    -- is longer than @k@. However, in the tests, we will be calling this
-    -- function manually, which means it might be called when there are no
-    -- blocks to copy.
+    -- This can't happen in practice, as we're only called when there are new
+    -- immutable blocks. However, in the tests, we will be calling this function
+    -- manually, which means it might be called when there are no blocks to
+    -- copy.
     then trace NoBlocksToCopyToImmutableDB
     else forM_ toCopy $ \pt -> do
       let hash = case pointHash pt of
@@ -193,7 +194,6 @@ copyToImmutableDB CDB{..} = electric $ do
   -- Get the /possibly/ updated tip of the ImmutableDB
   atomically $ ImmutableDB.getTipSlot cdbImmutableDB
  where
-  SecurityParam k = configSecurityParam cdbTopLevelConfig
   trace = traceWith (contramap TraceCopyToImmutableDBEvent cdbTracer)
 
   -- \| Remove the header corresponding to the given point from the beginning
@@ -218,9 +218,11 @@ copyToImmutableDB CDB{..} = electric $ do
 -- | Copy blocks from the VolatileDB to ImmutableDB and trigger further tasks in
 -- other threads.
 --
--- We watch the chain for changes. Whenever the chain is longer than @k@, then
--- the headers older than @k@ are copied from the VolatileDB to the ImmutableDB
--- (using 'copyToImmutableDB'). Once that is complete,
+-- Wait until the current chain ('cdbChain') is longer than its volatile suffix
+-- ('getCurrentChain'). When this occurs, it indicates that new blocks have
+-- become immutable. These newly immutable blocks are then copied are copied
+-- from the VolatileDB to the ImmutableDB (using 'copyToImmutableDB'). Once that
+-- is complete,
 --
 -- * Trigger LedgerDB maintenance tasks, namely flushing, taking snapshots and
 --   garbage collection.
@@ -254,15 +256,15 @@ copyToImmutableDBRunner cdb@CDB{..} ledgerDbTasksTrigger gcSchedule fuse = do
   LedgerDB.tryFlush cdbLedgerDB
   forever copyAndTrigger
  where
-  SecurityParam k = configSecurityParam cdbTopLevelConfig
-
   copyAndTrigger :: m ()
   copyAndTrigger = do
-    -- Wait for the chain to grow larger than @k@
+    -- Wait for 'cdbChain' to become longer than 'getCurrentChain'.
     numToWrite <- atomically $ do
       curChain <- icWithoutTime <$> readTVar cdbChain
-      check $ fromIntegral (AF.length curChain) > unNonZero k
-      return $ fromIntegral (AF.length curChain) - unNonZero k
+      curChainVolSuffix <- Query.getCurrentChain cdb
+      let numToWrite = AF.length curChain - AF.length curChainVolSuffix
+      check $ numToWrite > 0
+      return $ fromIntegral numToWrite
 
     -- Copy blocks to ImmutableDB
     --

From c66b0aaeae7586fc2ea987c23af2fb833225571e Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Fri, 8 Aug 2025 18:18:35 +0200
Subject: [PATCH 03/42] LedgerDB: abstract out immutability criterion
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This is a preparatory change for Peras, which uses a different immutability
criterion (based on weight of chains, instead of (just) length).

The only remaining use of the `SecurityParam` is for the snapshot policy 🙃
---
 .../Cardano/Tools/DBAnalyser/Run.hs           |  2 +
 ...7_alexander.esgen_decouple_immutability.md |  7 ++++
 .../Consensus/Storage/ChainDB/Impl.hs         |  2 +
 .../Ouroboros/Consensus/Storage/LedgerDB.hs   |  6 ++-
 .../Consensus/Storage/LedgerDB/Args.hs        | 37 ++++++++++++++++++-
 .../Consensus/Storage/LedgerDB/V1.hs          | 36 ++++++++++--------
 .../Consensus/Storage/LedgerDB/V2.hs          | 23 +++++++-----
 .../MiniProtocol/LocalStateQuery/Server.hs    |  1 +
 .../Storage/LedgerDB/StateMachine.hs          |  2 +
 9 files changed, 88 insertions(+), 28 deletions(-)
 create mode 100644 ouroboros-consensus/changelog.d/20250811_150947_alexander.esgen_decouple_immutability.md

diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
index 3c63f5d2ee..b84fd96157 100644
--- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
+++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
@@ -71,6 +71,7 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.L
           lgrDbArgs
           bss
           (\_ -> error "no replay")
+          (LedgerDB.praosGetVolatileSuffix $ LedgerDB.ledgerDbCfgSecParam $ LedgerDB.lgrConfig lgrDbArgs)
       )
       emptyStream
       genesisPoint
@@ -83,6 +84,7 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.L
           lgrDbArgs
           args
           (\_ -> error "no replay")
+          (LedgerDB.praosGetVolatileSuffix $ LedgerDB.ledgerDbCfgSecParam $ LedgerDB.lgrConfig lgrDbArgs)
       )
       emptyStream
       genesisPoint
diff --git a/ouroboros-consensus/changelog.d/20250811_150947_alexander.esgen_decouple_immutability.md b/ouroboros-consensus/changelog.d/20250811_150947_alexander.esgen_decouple_immutability.md
new file mode 100644
index 0000000000..c48e80ce56
--- /dev/null
+++ b/ouroboros-consensus/changelog.d/20250811_150947_alexander.esgen_decouple_immutability.md
@@ -0,0 +1,7 @@
+### Breaking
+
+- LedgerDB: generalized over the criterion used to determine which states are
+  volatile/immutable, in preparation for Ouroboros Peras.
+
+  Concretely, `LedgerDB.openDB` takes a new argument, `GetVolatileSuffix m blk`.
+  For Praos behavior, use `praosGetVolatileSuffix`.
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index 3ee8da303f..7e04b7a473 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -160,12 +160,14 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
   (chainDB, testing, env) <- lift $ do
     traceWith tracer $ TraceOpenEvent (OpenedVolatileDB maxSlot)
     traceWith tracer $ TraceOpenEvent StartedOpeningLgrDB
+    let secParam = configSecurityParam $ Args.cdbsTopLevelConfig cdbSpecificArgs
     (lgrDB, replayed) <-
       LedgerDB.openDB
         argsLgrDb
         (ImmutableDB.streamAPI immutableDB)
         immutableDbTipPoint
         (Query.getAnyKnownBlock immutableDB volatileDB)
+        (LedgerDB.praosGetVolatileSuffix secParam)
     traceWith tracer $ TraceOpenEvent OpenedLgrDB
 
     varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0))
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs
index 77129b8a56..3a44722b8b 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs
@@ -58,18 +58,21 @@ openDB ::
   Point blk ->
   -- | How to get blocks from the ChainDB
   ResolveBlock m blk ->
+  GetVolatileSuffix m blk ->
   m (LedgerDB' m blk, Word64)
 openDB
   args
   stream
   replayGoal
-  getBlock = case lgrFlavorArgs args of
+  getBlock
+  getVolatileSuffix = case lgrFlavorArgs args of
     LedgerDbFlavorArgsV1 bss ->
       let initDb =
             V1.mkInitDb
               args
               bss
               getBlock
+              getVolatileSuffix
        in doOpenDB args initDb stream replayGoal
     LedgerDbFlavorArgsV2 bss ->
       let initDb =
@@ -77,6 +80,7 @@ openDB
               args
               bss
               getBlock
+              getVolatileSuffix
        in doOpenDB args initDb stream replayGoal
 
 {-------------------------------------------------------------------------------
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs
index 63935c89fa..fa3835306a 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -22,14 +22,21 @@ module Ouroboros.Consensus.Storage.LedgerDB.Args
   , QueryBatchSize (..)
   , defaultArgs
   , defaultQueryBatchSize
+
+    -- * 'GetVolatileSuffix'
+  , GetVolatileSuffix (..)
+  , praosGetVolatileSuffix
   ) where
 
+import Cardano.Ledger.BaseTypes (unNonZero)
 import Control.ResourceRegistry
 import Control.Tracer
 import Data.Kind
 import Data.Word
 import GHC.Generics (Generic)
 import NoThunks.Class
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Config.SecurityParam
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.Extended
 import Ouroboros.Consensus.Storage.LedgerDB.API
@@ -38,6 +45,9 @@ import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
 import Ouroboros.Consensus.Util.Args
+import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Network.AnchoredSeq (AnchoredSeq)
+import qualified Ouroboros.Network.AnchoredSeq as AS
 import System.FS.API
 
 {-------------------------------------------------------------------------------
@@ -120,3 +130,28 @@ defaultQueryBatchSize requestedQueryBatchSize = case requestedQueryBatchSize of
   -- acceptable performance. We might want to tweak this further, but for now
   -- this default seems good enough.
   DefaultQueryBatchSize -> 100_000
+
+{-------------------------------------------------------------------------------
+  GetVolatileSuffix
+-------------------------------------------------------------------------------}
+
+-- | Get the volatile suffix of the given 'AnchoredSeq' of states that the
+-- LedgerDB maintains.
+newtype GetVolatileSuffix m blk = GetVolatileSuffix
+  { getVolatileSuffix ::
+      forall s.
+      AS.Anchorable (WithOrigin SlotNo) s s =>
+      STM
+        m
+        ( AnchoredSeq (WithOrigin SlotNo) s s ->
+          AnchoredSeq (WithOrigin SlotNo) s s
+        )
+  }
+  deriving NoThunks via OnlyCheckWhnfNamed "GetVolatileSuffix" (GetVolatileSuffix m blk)
+
+-- | Return the the most recent @k@ blocks, which is the rule mandated by Praos.
+praosGetVolatileSuffix :: IOLike m => SecurityParam -> GetVolatileSuffix m blk
+praosGetVolatileSuffix secParam =
+  GetVolatileSuffix $ pure $ AS.anchorNewest k
+ where
+  k = unNonZero $ maxRollbacks secParam
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs
index d03775f0a6..6bae6131b6 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs
@@ -19,7 +19,6 @@
 -- module will be gone.
 module Ouroboros.Consensus.Storage.LedgerDB.V1 (mkInitDb) where
 
-import Cardano.Ledger.BaseTypes.NonZero (NonZero (..))
 import Control.Arrow ((>>>))
 import Control.Monad
 import Control.Monad.Except
@@ -84,8 +83,9 @@ mkInitDb ::
   Complete LedgerDbArgs m blk ->
   Complete V1.LedgerDbFlavorArgs m ->
   ResolveBlock m blk ->
+  GetVolatileSuffix m blk ->
   InitDB (DbChangelog' blk, ResourceKey m, BackingStore' m blk) m blk
-mkInitDb args bss getBlock =
+mkInitDb args bss getBlock getVolatileSuffix =
   InitDB
     { initFromGenesis = do
         st <- lgrGenesis
@@ -143,6 +143,7 @@ mkInitDb args bss getBlock =
                 , ldbShouldFlush = shouldFlush flushFreq
                 , ldbQueryBatchSize = lgrQueryBatchSize
                 , ldbResolveBlock = getBlock
+                , ldbGetVolatileSuffix = getVolatileSuffix
                 }
         h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
         pure $ implMkLedgerDb h
@@ -204,10 +205,11 @@ implGetImmutableTip ::
   (MonadSTM m, GetTip l) =>
   LedgerDBEnv m l blk ->
   STM m (l EmptyMK)
-implGetImmutableTip env =
+implGetImmutableTip env = do
+  volSuffix <- getVolatileSuffix $ ldbGetVolatileSuffix env
   -- The DbChangelog might contain more than k states if they have not yet
   -- been garbage-collected.
-  fmap (AS.anchor . AS.anchorNewest (envMaxRollbacks env) . changelogStates)
+  fmap (AS.anchor . volSuffix . changelogStates)
     . readTVar
     $ ldbChangelog env
 
@@ -220,7 +222,8 @@ implGetPastLedgerState ::
   , HeaderHash l ~ HeaderHash blk
   ) =>
   LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
-implGetPastLedgerState env point =
+implGetPastLedgerState env point = do
+  volSuffix <- getVolatileSuffix $ ldbGetVolatileSuffix env
   readTVar (ldbChangelog env) <&> \chlog -> do
     -- The DbChangelog might contain more than k states if they have not yet
     -- been garbage-collected, so make sure that the point is volatile (or the
@@ -229,7 +232,7 @@ implGetPastLedgerState env point =
       AS.withinBounds
         (pointSlot point)
         ((point ==) . castPoint . either getTip getTip)
-        (AS.anchorNewest (envMaxRollbacks env) (changelogStates chlog))
+        (volSuffix (changelogStates chlog))
     getPastLedgerAt point chlog
 
 implGetHeaderStateHistory ::
@@ -242,6 +245,7 @@ implGetHeaderStateHistory ::
   LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
 implGetHeaderStateHistory env = do
   ldb <- readTVar (ldbChangelog env)
+  volSuffix <- getVolatileSuffix $ ldbGetVolatileSuffix env
   let currentLedgerState = ledgerState $ current ldb
       -- This summary can convert all tip slots of the ledger states in the
       -- @ledgerDb@ as these are not newer than the tip slot of the current
@@ -255,7 +259,7 @@ implGetHeaderStateHistory env = do
     . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime'
     -- The DbChangelog might contain more than k states if they have not yet
     -- been garbage-collected, so only take the corresponding suffix.
-    . AS.anchorNewest (envMaxRollbacks env)
+    . volSuffix
     $ changelogStates ldb
 
 implValidate ::
@@ -571,6 +575,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv
   -- frequency that was provided when opening the LedgerDB.
   , ldbQueryBatchSize :: !QueryBatchSize
   , ldbResolveBlock :: !(ResolveBlock m blk)
+  , ldbGetVolatileSuffix :: !(GetVolatileSuffix m blk)
   }
   deriving Generic
 
@@ -584,10 +589,6 @@ deriving instance
   ) =>
   NoThunks (LedgerDBEnv m l blk)
 
--- | Return the security parameter @k@. Convenience function.
-envMaxRollbacks :: LedgerDBEnv m l blk -> Word64
-envMaxRollbacks = unNonZero . maxRollbacks . ledgerDbCfgSecParam . ldbCfg
-
 -- | Check if the LedgerDB is open, if so, executing the given function on the
 -- 'LedgerDBEnv', otherwise, throw a 'CloseDBError'.
 getEnv ::
@@ -759,10 +760,16 @@ acquireAtTarget ::
   ReadLocked m (Either GetForkerError (DbChangelog l))
 acquireAtTarget ldbEnv target = readLocked $ runExceptT $ do
   dblog <- lift $ readTVarIO (ldbChangelog ldbEnv)
+  volSuffix <- lift $ atomically $ getVolatileSuffix $ ldbGetVolatileSuffix ldbEnv
   -- The DbChangelog might contain more than k states if they have not yet
   -- been garbage-collected.
-  let immTip :: Point blk
-      immTip = castPoint $ getTip $ AS.anchor $ AS.anchorNewest k $ changelogStates dblog
+  let volStates = volSuffix $ changelogStates dblog
+
+      immTip :: Point blk
+      immTip = castPoint $ getTip $ AS.anchor volStates
+
+      rollbackMax :: Word64
+      rollbackMax = fromIntegral $ AS.length volStates
 
       rollbackTo pt
         | pointSlot pt < pointSlot immTip = throwError $ PointTooOld Nothing
@@ -775,7 +782,6 @@ acquireAtTarget ldbEnv target = readLocked $ runExceptT $ do
     Right ImmutableTip -> rollbackTo immTip
     Right (SpecificPoint pt) -> rollbackTo pt
     Left n -> do
-      let rollbackMax = maxRollback dblog `min` k
       when (n > rollbackMax) $
         throwError $
           PointTooOld $
@@ -787,8 +793,6 @@ acquireAtTarget ldbEnv target = readLocked $ runExceptT $ do
       case rollbackN n dblog of
         Nothing -> error "unreachable"
         Just dblog' -> pure dblog'
- where
-  k = envMaxRollbacks ldbEnv
 
 {-------------------------------------------------------------------------------
   Make forkers from consistent views
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs
index 5188460233..4d7f073eab 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs
@@ -16,7 +16,6 @@
 
 module Ouroboros.Consensus.Storage.LedgerDB.V2 (mkInitDb) where
 
-import Cardano.Ledger.BaseTypes (unNonZero)
 import Control.Arrow ((>>>))
 import Control.Monad (join)
 import qualified Control.Monad as Monad (void, (>=>))
@@ -79,8 +78,9 @@ mkInitDb ::
   Complete LedgerDbArgs m blk ->
   Complete V2.LedgerDbFlavorArgs m ->
   ResolveBlock m blk ->
+  GetVolatileSuffix m blk ->
   InitDB (LedgerSeq' m blk) m blk
-mkInitDb args flavArgs getBlock =
+mkInitDb args flavArgs getBlock getVolatileSuffix =
   InitDB
     { initFromGenesis = emptyF =<< lgrGenesis
     , initFromSnapshot =
@@ -110,6 +110,7 @@ mkInitDb args flavArgs getBlock =
                 , ldbResolveBlock = getBlock
                 , ldbQueryBatchSize = lgrQueryBatchSize
                 , ldbOpenHandlesLock = lock
+                , ldbGetVolatileSuffix = getVolatileSuffix
                 }
         h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
         pure $ implMkLedgerDb h bss
@@ -486,6 +487,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv
   --
   --  * Modify 'ldbSeq' while holding a write lock, and then close the removed
   --    handles without any locking. See e.g. 'implGarbageCollect'.
+  , ldbGetVolatileSuffix :: !(GetVolatileSuffix m blk)
   }
   deriving Generic
 
@@ -575,15 +577,16 @@ getEnvSTM (LDBHandle varState) f =
   Acquiring consistent views
 -------------------------------------------------------------------------------}
 
--- | Take the suffix of the 'ldbSeq' containing the @k@ most recent states. The
--- 'LedgerSeq' can contain more than @k@ states if we adopted new blocks, but
--- garbage collection has not yet been run.
+-- | Take the suffix of the 'ldbSeq' containing the only the volatile states
+-- (and the first immutable state at the anchor). The 'LedgerSeq' can contain
+-- more than one immutable state if we adopted new blocks, but garbage
+-- collection has not yet been run.
 getVolatileLedgerSeq ::
-  (MonadSTM m, GetTip l) => LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
-getVolatileLedgerSeq env =
-  LedgerSeq . AS.anchorNewest k . getLedgerSeq <$> readTVar (ldbSeq env)
- where
-  k = unNonZero $ maxRollbacks $ ledgerDbCfgSecParam $ ldbCfg env
+  (MonadSTM m, GetTip l) =>
+  LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
+getVolatileLedgerSeq env = do
+  volSuffix <- getVolatileSuffix (ldbGetVolatileSuffix env)
+  LedgerSeq . volSuffix . getLedgerSeq <$> readTVar (ldbSeq env)
 
 -- | Get a 'StateRef' from the 'LedgerSeq' (via 'getVolatileLedgerSeq') in the
 -- 'LedgerDBEnv', with the 'LedgerTablesHandle' having been duplicated (such
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
index 0ab66ab540..efafdc18aa 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
@@ -244,6 +244,7 @@ initLedgerDB s c = do
         streamAPI
         (Chain.headPoint c)
         (\rpt -> pure $ fromMaybe (error "impossible") $ Chain.findBlock ((rpt ==) . blockRealPoint) c)
+        (LedgerDB.praosGetVolatileSuffix s)
 
   result <-
     LedgerDB.validateFork
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs
index 85ce9ac039..1540d3850c 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs
@@ -504,6 +504,7 @@ openLedgerDB flavArgs env cfg fs = do
               args
               bss
               getBlock
+              (praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg)
        in openDBInternal args initDb stream replayGoal
     LedgerDbFlavorArgsV2 bss ->
       let initDb =
@@ -511,6 +512,7 @@ openLedgerDB flavArgs env cfg fs = do
               args
               bss
               getBlock
+              (praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg)
        in openDBInternal args initDb stream replayGoal
   withRegistry $ \reg -> do
     vr <- validateFork ldb reg (const $ pure ()) BlockCache.empty 0 (map getHeader volBlocks)

From cfae3c7785ddd11f114e8f77df8e39bc3d2e7e8b Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 11 Aug 2025 15:04:54 +0200
Subject: [PATCH 04/42] ChainDB: define `LedgerDB.GetVolatileSuffix` via
 `getCurrentChain`

This requires some knot tying as we initialize the LedgerDB before the ChainDB
is fully initialized.

This is preparing for Peras, which will introduce a refined immutability
criterion. Due to this change, the LedgerDB will automatically use the same
criterion as the ChainDB (via `getCurrentChain`).
---
 .../Consensus/Storage/ChainDB/Impl.hs         | 42 ++++++++++++++++++-
 1 file changed, 40 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index 7e04b7a473..e5f7b21014 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -53,6 +53,7 @@ import Data.Functor.Contravariant ((>$<))
 import qualified Data.Map.Strict as Map
 import Data.Maybe.Strict (StrictMaybe (..))
 import GHC.Stack (HasCallStack)
+import NoThunks.Class
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
 import qualified Ouroboros.Consensus.Fragment.Validated as VF
@@ -86,6 +87,7 @@ import Ouroboros.Consensus.Util.STM
   ( Fingerprint (..)
   , WithFingerprint (..)
   )
+import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import Ouroboros.Network.BlockFetch.ConsensusInterface
   ( ChainSelStarvation (..)
@@ -160,14 +162,15 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
   (chainDB, testing, env) <- lift $ do
     traceWith tracer $ TraceOpenEvent (OpenedVolatileDB maxSlot)
     traceWith tracer $ TraceOpenEvent StartedOpeningLgrDB
-    let secParam = configSecurityParam $ Args.cdbsTopLevelConfig cdbSpecificArgs
+    (ledgerDbGetVolatileSuffix, setGetCurrentChainForLedgerDB) <-
+      mkLedgerDbGetVolatileSuffix
     (lgrDB, replayed) <-
       LedgerDB.openDB
         argsLgrDb
         (ImmutableDB.streamAPI immutableDB)
         immutableDbTipPoint
         (Query.getAnyKnownBlock immutableDB volatileDB)
-        (LedgerDB.praosGetVolatileSuffix secParam)
+        ledgerDbGetVolatileSuffix
     traceWith tracer $ TraceOpenEvent OpenedLgrDB
 
     varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0))
@@ -248,6 +251,9 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , cdbLoE = Args.cdbsLoE cdbSpecificArgs
             , cdbChainSelStarvation = varChainSelStarvation
             }
+
+    setGetCurrentChainForLedgerDB $ Query.getCurrentChain env
+
     h <- fmap CDBHandle $ newTVarIO $ ChainDbOpen env
     let chainDB =
           API.ChainDB
@@ -306,6 +312,38 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
   tracer = Args.cdbsTracer cdbSpecificArgs
   Args.ChainDbArgs argsImmutableDb argsVolatileDb argsLgrDb cdbSpecificArgs = args
 
+  -- The LedgerDB requires a criterion ('LedgerDB.GetVolatileSuffix')
+  -- determining which of its states are volatile/immutable. Once we have
+  -- initialized the ChainDB we can defer this decision to
+  -- 'Query.getCurrentChain'.
+  --
+  -- However, we initialize the LedgerDB before the ChainDB (for initial chain
+  -- selection), so during that period, we temporarily consider no state (apart
+  -- from the anchor state) as immutable. This is fine as we don't perform eg
+  -- any rollbacks during this period.
+  mkLedgerDbGetVolatileSuffix ::
+    m
+      ( LedgerDB.GetVolatileSuffix m blk
+      , STM m (AnchoredFragment (Header blk)) -> m ()
+      )
+  mkLedgerDbGetVolatileSuffix = do
+    varGetCurrentChain ::
+      StrictTMVar m (OnlyCheckWhnf (STM m (AnchoredFragment (Header blk)))) <-
+      newEmptyTMVarIO
+    let getVolatileSuffix =
+          LedgerDB.GetVolatileSuffix $
+            tryReadTMVar varGetCurrentChain >>= \case
+              -- If @setVarChain@ has not yet been invoked, return the entire
+              -- suffix as volatile.
+              Nothing -> pure id
+              -- Otherwise, return the suffix with the same length as the
+              -- current chain.
+              Just (OnlyCheckWhnf getCurrentChain) -> do
+                curChainLen <- AF.length <$> getCurrentChain
+                pure $ AF.anchorNewest (fromIntegral curChainLen)
+        setVarChain = atomically . writeTMVar varGetCurrentChain . OnlyCheckWhnf
+    pure (getVolatileSuffix, setVarChain)
+
 -- | We use 'runInnerWithTempRegistry' for the component databases.
 innerOpenCont ::
   IOLike m =>

From 572b241a48218c39e0ac9b7e268be3ded1ff98e1 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 11 Aug 2025 15:15:33 +0200
Subject: [PATCH 05/42] ChainSync.Client: remove overzealous assertion

In case of data loss in the VolatileDB and a node restart, this condition can be
violated until we received `k` headers again.

Additionally, Ouroboros Peras will use a different immutability criterion where
it is perfectly fine to have less than `k` headers on our chain (as long as they
have sufficient weight).
---
 .../MiniProtocol/ChainSync/Client.hs          | 40 +++++--------------
 1 file changed, 9 insertions(+), 31 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
index c7c30ba1be..a3de6a4d73 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
@@ -691,12 +691,10 @@ checkKnownIntersectionInvariants ::
   ( HasHeader blk
   , HasHeader (Header blk)
   , HasAnnTip blk
-  , ConsensusProtocol (BlockProtocol blk)
   ) =>
-  ConsensusConfig (BlockProtocol blk) ->
   KnownIntersectionState blk ->
   Either String ()
-checkKnownIntersectionInvariants cfg kis
+checkKnownIntersectionInvariants kis
   -- 'theirHeaderStateHistory' invariant
   | let HeaderStateHistory snapshots = theirHeaderStateHistory
         historyTips :: [WithOrigin (AnnTip blk)]
@@ -723,19 +721,6 @@ checkKnownIntersectionInvariants cfg kis
           , show fragmentAnchorPoint
           ]
   -- 'ourFrag' invariants
-  | let nbHeaders = AF.length ourFrag
-        ourAnchorPoint = AF.anchorPoint ourFrag
-  , nbHeaders < fromIntegral (unNonZero k)
-  , ourAnchorPoint /= GenesisPoint =
-      throwError $
-        unwords
-          [ "ourFrag contains fewer than k headers and not close to genesis:"
-          , show nbHeaders
-          , "vs"
-          , show k
-          , "with anchor"
-          , show ourAnchorPoint
-          ]
   | let ourFragAnchor = AF.anchorPoint ourFrag
         theirFragAnchor = AF.anchorPoint theirFrag
   , ourFragAnchor /= castPoint theirFragAnchor =
@@ -761,8 +746,6 @@ checkKnownIntersectionInvariants cfg kis
   | otherwise =
       return ()
  where
-  SecurityParam k = protocolSecurityParam cfg
-
   KnownIntersectionState
     { mostRecentIntersection
     , ourFrag
@@ -774,14 +757,12 @@ assertKnownIntersectionInvariants ::
   ( HasHeader blk
   , HasHeader (Header blk)
   , HasAnnTip blk
-  , ConsensusProtocol (BlockProtocol blk)
   , HasCallStack
   ) =>
-  ConsensusConfig (BlockProtocol blk) ->
   KnownIntersectionState blk ->
   KnownIntersectionState blk
-assertKnownIntersectionInvariants cfg kis =
-  assertWithMsg (checkKnownIntersectionInvariants cfg kis) kis
+assertKnownIntersectionInvariants kis =
+  assertWithMsg (checkKnownIntersectionInvariants kis) kis
 
 {-------------------------------------------------------------------------------
   The ChainSync client definition
@@ -892,8 +873,7 @@ chainSyncClient cfgEnv dynEnv =
             (ForkTooDeep GenesisPoint)
  where
   ConfigEnv
-    { cfg
-    , chainDbView
+    { chainDbView
     , tracer
     } = cfgEnv
 
@@ -995,7 +975,7 @@ chainSyncClient cfgEnv dynEnv =
                   -- we will /never/ adopt them, which is handled in the "no
                   -- more intersection case".
                   StillIntersects () $
-                    assertKnownIntersectionInvariants (configConsensus cfg) $
+                    assertKnownIntersectionInvariants $
                       KnownIntersectionState
                         { mostRecentIntersection = castPoint intersection
                         , ourFrag = ourFrag'
@@ -1158,7 +1138,7 @@ findIntersectionTop cfgEnv dynEnv intEnv =
                 (ourTipFromChain ourFrag)
                 theirTip
       let kis =
-            assertKnownIntersectionInvariants (configConsensus cfg) $
+            assertKnownIntersectionInvariants $
               KnownIntersectionState
                 { mostRecentIntersection = intersection
                 , ourFrag
@@ -1234,7 +1214,6 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv =
   ConfigEnv
     { mkPipelineDecision0
     , tracer
-    , cfg
     , historicityCheck
     } = cfgEnv
 
@@ -1622,9 +1601,8 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv =
                         else mostRecentIntersection
 
                     kis' =
-                      assertKnownIntersectionInvariants
-                        (configConsensus cfg)
-                        $ KnownIntersectionState
+                      assertKnownIntersectionInvariants $
+                        KnownIntersectionState
                           { mostRecentIntersection = mostRecentIntersection'
                           , ourFrag = ourFrag
                           , theirFrag = theirFrag'
@@ -1961,7 +1939,7 @@ checkValid cfgEnv intEnv hdr hdrSlotTime theirTip kis ledgerView = do
   traceWith (tracer cfgEnv) $ TraceValidatedHeader hdr
 
   pure $
-    assertKnownIntersectionInvariants (configConsensus cfg) $
+    assertKnownIntersectionInvariants $
       KnownIntersectionState
         { mostRecentIntersection = mostRecentIntersection'
         , ourFrag = ourFrag

From 2ce3053755336899db75d7d7b3f284f197ceacc2 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 3 Jul 2025 15:58:10 +0200
Subject: [PATCH 06/42] Scaffolding for Peras certs and PerasCertDB

---
 ouroboros-consensus/ouroboros-consensus.cabal |   4 +
 .../Ouroboros/Consensus/Block.hs              |   1 +
 .../Consensus/Block/SupportsPeras.hs          |  57 +++++
 .../Consensus/Storage/ChainDB/Impl.hs         |  11 +-
 .../Consensus/Storage/ChainDB/Impl/Args.hs    |   9 +
 .../Consensus/Storage/ChainDB/Impl/Types.hs   |   4 +
 .../Consensus/Storage/PerasCertDB.hs          |   4 +
 .../Consensus/Storage/PerasCertDB/API.hs      |  52 +++++
 .../Consensus/Storage/PerasCertDB/Impl.hs     | 201 ++++++++++++++++++
 .../Test/Util/ChainDB.hs                      |   5 +
 .../Ouroboros/Storage/ChainDB/StateMachine.hs |   4 +
 11 files changed, 351 insertions(+), 1 deletion(-)
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs

diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index e92be3db64..a391ba4b89 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -75,6 +75,7 @@ library
     Ouroboros.Consensus.Block.RealPoint
     Ouroboros.Consensus.Block.SupportsDiffusionPipelining
     Ouroboros.Consensus.Block.SupportsMetrics
+    Ouroboros.Consensus.Block.SupportsPeras
     Ouroboros.Consensus.Block.SupportsProtocol
     Ouroboros.Consensus.Block.SupportsSanityCheck
     Ouroboros.Consensus.BlockchainTime
@@ -254,6 +255,9 @@ library
     Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
     Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
     Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
+    Ouroboros.Consensus.Storage.PerasCertDB
+    Ouroboros.Consensus.Storage.PerasCertDB.API
+    Ouroboros.Consensus.Storage.PerasCertDB.Impl
     Ouroboros.Consensus.Storage.Serialisation
     Ouroboros.Consensus.Storage.VolatileDB
     Ouroboros.Consensus.Storage.VolatileDB.API
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs
index 0ee718be4a..7c8b020e33 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs
@@ -8,5 +8,6 @@ import Ouroboros.Consensus.Block.NestedContent as X
 import Ouroboros.Consensus.Block.RealPoint as X
 import Ouroboros.Consensus.Block.SupportsDiffusionPipelining as X
 import Ouroboros.Consensus.Block.SupportsMetrics as X
+import Ouroboros.Consensus.Block.SupportsPeras as X
 import Ouroboros.Consensus.Block.SupportsProtocol as X
 import Ouroboros.Consensus.Block.SupportsSanityCheck as X
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
new file mode 100644
index 0000000000..70d547c913
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Ouroboros.Consensus.Block.SupportsPeras
+  ( PerasRoundNo (..)
+  , PerasWeight (..)
+  , boostPerCert
+  , BlockSupportsPeras (..)
+  ) where
+
+import Data.Monoid (Sum (..))
+import Data.Word (Word64)
+import GHC.Generics (Generic)
+import NoThunks.Class
+import Ouroboros.Consensus.Block.Abstract
+
+newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
+  deriving stock Show
+  deriving newtype (Eq, Ord, NoThunks)
+
+newtype PerasWeight = PerasWeight {unPerasWeight :: Word64}
+  deriving stock Show
+  deriving newtype (Eq, Ord, NoThunks)
+  deriving (Semigroup, Monoid) via Sum Word64
+
+-- | TODO this will become a Ledger protocol parameter
+boostPerCert :: PerasWeight
+boostPerCert = PerasWeight 15
+
+class
+  NoThunks (PerasCert blk) =>
+  BlockSupportsPeras blk
+  where
+  data PerasCert blk
+
+  perasCertRound :: PerasCert blk -> PerasRoundNo
+
+  perasCertBoostedBlock :: PerasCert blk -> Point blk
+
+-- TODO degenerate instance for all blks to get things to compile
+instance StandardHash blk => BlockSupportsPeras blk where
+  data PerasCert blk = PerasCert
+    { pcCertRound :: PerasRoundNo
+    , pcCertBoostedBlock :: Point blk
+    }
+    deriving stock Generic
+    deriving anyclass NoThunks
+
+  perasCertRound = pcCertRound
+  perasCertBoostedBlock = pcCertBoostedBlock
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index e5f7b21014..c0b0785d02 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -79,6 +79,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB
 import Ouroboros.Consensus.Storage.LedgerDB (LedgerSupportsLedgerDB)
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
+import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util (newFuse, whenJust, withFuse)
 import Ouroboros.Consensus.Util.Args
@@ -173,6 +174,8 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
         ledgerDbGetVolatileSuffix
     traceWith tracer $ TraceOpenEvent OpenedLgrDB
 
+    perasCertDB <- PerasCertDB.openDB argsPerasCertDB
+
     varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0))
 
     let initChainSelTracer = TraceInitChainSelEvent >$< tracer
@@ -250,6 +253,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , cdbChainSelQueue = chainSelQueue
             , cdbLoE = Args.cdbsLoE cdbSpecificArgs
             , cdbChainSelStarvation = varChainSelStarvation
+            , cdbPerasCertDB = perasCertDB
             }
 
     setGetCurrentChainForLedgerDB $ Query.getCurrentChain env
@@ -310,7 +314,12 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
   return ((chainDB, testing), env)
  where
   tracer = Args.cdbsTracer cdbSpecificArgs
-  Args.ChainDbArgs argsImmutableDb argsVolatileDb argsLgrDb cdbSpecificArgs = args
+  Args.ChainDbArgs
+    argsImmutableDb
+    argsVolatileDb
+    argsLgrDb
+    argsPerasCertDB
+    cdbSpecificArgs = args
 
   -- The LedgerDB requires a criterion ('LedgerDB.GetVolatileSuffix')
   -- determining which of its states are volatile/immutable. Once we have
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs
index db793c8f0d..cc285627a4 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs
@@ -41,6 +41,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import Ouroboros.Consensus.Storage.LedgerDB (LedgerDbFlavorArgs)
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
 import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
+import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.IOLike
@@ -54,6 +55,7 @@ data ChainDbArgs f m blk = ChainDbArgs
   { cdbImmDbArgs :: ImmutableDB.ImmutableDbArgs f m blk
   , cdbVolDbArgs :: VolatileDB.VolatileDbArgs f m blk
   , cdbLgrDbArgs :: LedgerDB.LedgerDbArgs f m blk
+  , cdbPerasCertDbArgs :: PerasCertDB.PerasCertDbArgs f m blk
   , cdbsArgs :: ChainDbSpecificArgs f m blk
   }
 
@@ -138,6 +140,7 @@ defaultArgs =
     ImmutableDB.defaultArgs
     VolatileDB.defaultArgs
     LedgerDB.defaultArgs
+    PerasCertDB.defaultArgs
     defaultSpecificArgs
 
 ensureValidateAll ::
@@ -209,6 +212,10 @@ completeChainDbArgs
             , LedgerDB.lgrFlavorArgs = flavorArgs
             , LedgerDB.lgrRegistry = registry
             }
+      , cdbPerasCertDbArgs =
+          PerasCertDB.PerasCertDbArgs
+            { PerasCertDB.pcdbaTracer = PerasCertDB.pcdbaTracer (cdbPerasCertDbArgs defArgs)
+            }
       , cdbsArgs =
           (cdbsArgs defArgs)
             { cdbsRegistry = registry
@@ -226,6 +233,8 @@ updateTracer trcr args =
     { cdbImmDbArgs = (cdbImmDbArgs args){ImmutableDB.immTracer = TraceImmutableDBEvent >$< trcr}
     , cdbVolDbArgs = (cdbVolDbArgs args){VolatileDB.volTracer = TraceVolatileDBEvent >$< trcr}
     , cdbLgrDbArgs = (cdbLgrDbArgs args){LedgerDB.lgrTracer = TraceLedgerDBEvent >$< trcr}
+    , cdbPerasCertDbArgs =
+        (cdbPerasCertDbArgs args){PerasCertDB.pcdbaTracer = TracePerasCertDbEvent >$< trcr}
     , cdbsArgs = (cdbsArgs args){cdbsTracer = trcr}
     }
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
index 3fe7ca9ab6..fb35b09651 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
@@ -124,6 +124,8 @@ import Ouroboros.Consensus.Storage.LedgerDB
   , LedgerDbSerialiseConstraints
   )
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
+import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDB)
+import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
 import Ouroboros.Consensus.Storage.Serialisation
 import Ouroboros.Consensus.Storage.VolatileDB
   ( VolatileDB
@@ -349,6 +351,7 @@ data ChainDbEnv m blk = CDB
   , cdbChainSelStarvation :: !(StrictTVar m ChainSelStarvation)
   -- ^ Information on the last starvation of ChainSel, whether ongoing or
   -- ended recently.
+  , cdbPerasCertDB :: !(PerasCertDB m blk)
   }
   deriving Generic
 
@@ -717,6 +720,7 @@ data TraceEvent blk
   | TraceLedgerDBEvent (LedgerDB.TraceEvent blk)
   | TraceImmutableDBEvent (ImmutableDB.TraceEvent blk)
   | TraceVolatileDBEvent (VolatileDB.TraceEvent blk)
+  | TracePerasCertDbEvent (PerasCertDB.TraceEvent blk)
   | TraceLastShutdownUnclean
   | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk)
   deriving Generic
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs
new file mode 100644
index 0000000000..288039b30c
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs
@@ -0,0 +1,4 @@
+module Ouroboros.Consensus.Storage.PerasCertDB (module X) where
+
+import Ouroboros.Consensus.Storage.PerasCertDB.API as X
+import Ouroboros.Consensus.Storage.PerasCertDB.Impl as X
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
new file mode 100644
index 0000000000..92f55946e4
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Ouroboros.Consensus.Storage.PerasCertDB.API
+  ( PerasCertDB (..)
+  , PerasWeightSnapshot (..)
+  , boostedWeightForPoint
+  , boostedWeightForFragment
+  ) where
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import NoThunks.Class
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+
+data PerasCertDB m blk = PerasCertDB
+  { addCert :: PerasCert blk -> m ()
+  , getWeightSnapshot :: STM m (PerasWeightSnapshot blk)
+  , closeDB :: m ()
+  }
+  deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk)
+
+newtype PerasWeightSnapshot blk = PerasWeightSnapshot
+  { getPerasWeightSnapshot :: Map (Point blk) PerasWeight
+  }
+  deriving stock Show
+  deriving newtype NoThunks
+
+boostedWeightForPoint ::
+  forall blk.
+  StandardHash blk =>
+  PerasWeightSnapshot blk -> Point blk -> PerasWeight
+boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt =
+  Map.findWithDefault mempty pt weightByPoint
+
+boostedWeightForFragment ::
+  forall blk.
+  HasHeader blk =>
+  PerasWeightSnapshot blk ->
+  AnchoredFragment blk ->
+  PerasWeight
+boostedWeightForFragment weightSnap frag =
+  -- TODO think about whether this could be done in sublinear complexity
+  -- probably should write microbenchmarks at some point to see if this is a bottleneck
+  foldMap
+    (boostedWeightForPoint weightSnap)
+    (blockPoint <$> AF.toOldestFirst frag)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
new file mode 100644
index 0000000000..1369a691eb
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
@@ -0,0 +1,201 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module Ouroboros.Consensus.Storage.PerasCertDB.Impl
+  ( -- * Opening
+    PerasCertDbArgs (..)
+  , defaultArgs
+  , openDB
+
+    -- * Trace types
+  , TraceEvent (..)
+
+    -- * Exceptions
+  , PerasCertDbError (..)
+  ) where
+
+import Control.Monad (join)
+import Control.Tracer (Tracer, nullTracer, traceWith)
+import Data.Kind (Type)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import GHC.Generics (Generic)
+import NoThunks.Class
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Storage.PerasCertDB.API
+import Ouroboros.Consensus.Util.Args
+import Ouroboros.Consensus.Util.CallStack
+import Ouroboros.Consensus.Util.IOLike
+
+{------------------------------------------------------------------------------
+  Opening the database
+------------------------------------------------------------------------------}
+
+type PerasCertDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type
+data PerasCertDbArgs f m blk = PerasCertDbArgs
+  { pcdbaTracer :: Tracer m (TraceEvent blk)
+  }
+
+defaultArgs :: Applicative m => Incomplete PerasCertDbArgs m blk
+defaultArgs =
+  PerasCertDbArgs
+    { pcdbaTracer = nullTracer
+    }
+
+openDB ::
+  forall m blk.
+  ( IOLike m
+  , StandardHash blk
+  ) =>
+  Complete PerasCertDbArgs m blk ->
+  m (PerasCertDB m blk)
+openDB args = do
+  pcdbRoundNos <- newTVarIO Set.empty
+  pcdbWeightByPoint <- newTVarIO Map.empty
+  let env =
+        PerasCertDbEnv
+          { pcdbTracer
+          , pcdbRoundNos
+          , pcdbWeightByPoint
+          }
+  h <- PerasCertDbHandle <$> newTVarIO (PerasCertDbOpen env)
+  traceWith pcdbTracer OpenedPerasCertDB
+  pure
+    PerasCertDB
+      { addCert = getEnv1 h implAddCert
+      , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot
+      , closeDB = implCloseDB h
+      }
+ where
+  PerasCertDbArgs
+    { pcdbaTracer = pcdbTracer
+    } = args
+
+{-------------------------------------------------------------------------------
+  Database state
+-------------------------------------------------------------------------------}
+
+newtype PerasCertDbHandle m blk = PerasCertDbHandle (StrictTVar m (PerasCertDbState m blk))
+
+data PerasCertDbState m blk
+  = PerasCertDbOpen !(PerasCertDbEnv m blk)
+  | PerasCertDbClosed
+  deriving stock Generic
+  deriving anyclass NoThunks
+
+data PerasCertDbEnv m blk = PerasCertDbEnv
+  { pcdbTracer :: !(Tracer m (TraceEvent blk))
+  , pcdbRoundNos :: !(StrictTVar m (Set PerasRoundNo))
+  -- ^ The 'RoundNo's of all certificates currently in the db.
+  , pcdbWeightByPoint :: !(StrictTVar m (Map (Point blk) PerasWeight))
+  -- ^ The weight of boosted blocks w.r.t. the certificates currently in the
+  -- db.
+  --
+  -- INVARIANT: In sync with 'pcdbRoundNos'.
+  }
+  deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDbEnv" (PerasCertDbEnv m blk)
+
+getEnv ::
+  (IOLike m, HasCallStack) =>
+  PerasCertDbHandle m blk ->
+  (PerasCertDbEnv m blk -> m r) ->
+  m r
+getEnv (PerasCertDbHandle varState) f =
+  readTVarIO varState >>= \case
+    PerasCertDbOpen env -> f env
+    PerasCertDbClosed -> throwIO $ ClosedDBError prettyCallStack
+
+getEnv1 ::
+  (IOLike m, HasCallStack) =>
+  PerasCertDbHandle m blk ->
+  (PerasCertDbEnv m blk -> a -> m r) ->
+  a ->
+  m r
+getEnv1 h f a = getEnv h (\env -> f env a)
+
+getEnvSTM ::
+  (IOLike m, HasCallStack) =>
+  PerasCertDbHandle m blk ->
+  (PerasCertDbEnv m blk -> STM m r) ->
+  STM m r
+getEnvSTM (PerasCertDbHandle varState) f =
+  readTVar varState >>= \case
+    PerasCertDbOpen env -> f env
+    PerasCertDbClosed -> throwIO $ ClosedDBError prettyCallStack
+
+{-------------------------------------------------------------------------------
+  API implementation
+-------------------------------------------------------------------------------}
+
+implCloseDB :: IOLike m => PerasCertDbHandle m blk -> m ()
+implCloseDB (PerasCertDbHandle varState) =
+  atomically (swapTVar varState PerasCertDbClosed) >>= \case
+    PerasCertDbOpen PerasCertDbEnv{pcdbTracer} -> do
+      traceWith pcdbTracer ClosedPerasCertDB
+    -- DB was already closed.
+    PerasCertDbClosed -> pure ()
+
+-- TODO: validation
+implAddCert ::
+  ( IOLike m
+  , StandardHash blk
+  ) =>
+  PerasCertDbEnv m blk ->
+  PerasCert blk ->
+  m ()
+implAddCert env cert = do
+  traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt
+  join $ atomically $ do
+    roundNos <- readTVar pcdbRoundNos
+    if Set.member roundNo roundNos
+      then do
+        pure $ traceWith pcdbTracer $ IgnoredCertAlreadyInDB roundNo boostedPt
+      else do
+        writeTVar pcdbRoundNos $ Set.insert roundNo roundNos
+        -- Note that the same block might be boosted by multiple points.
+        modifyTVar pcdbWeightByPoint $ Map.insertWith (<>) boostedPt boostPerCert
+        pure $ traceWith pcdbTracer $ AddedPerasCert roundNo boostedPt
+ where
+  PerasCertDbEnv
+    { pcdbTracer
+    , pcdbRoundNos
+    , pcdbWeightByPoint
+    } = env
+
+  roundNo = perasCertRound cert
+  boostedPt = perasCertBoostedBlock cert
+
+implGetWeightSnapshot ::
+  IOLike m =>
+  PerasCertDbEnv m blk -> STM m (PerasWeightSnapshot blk)
+implGetWeightSnapshot PerasCertDbEnv{pcdbWeightByPoint} =
+  PerasWeightSnapshot <$> readTVar pcdbWeightByPoint
+
+{-------------------------------------------------------------------------------
+  Trace types
+-------------------------------------------------------------------------------}
+
+data TraceEvent blk
+  = OpenedPerasCertDB
+  | ClosedPerasCertDB
+  | AddingPerasCert PerasRoundNo (Point blk)
+  | AddedPerasCert PerasRoundNo (Point blk)
+  | IgnoredCertAlreadyInDB PerasRoundNo (Point blk)
+  deriving stock (Show, Eq, Generic)
+
+{-------------------------------------------------------------------------------
+  Exceptions
+-------------------------------------------------------------------------------}
+
+data PerasCertDbError
+  = ClosedDBError PrettyCallStack
+  deriving stock Show
+  deriving anyclass Exception
diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
index d32ee6522b..75110df40e 100644
--- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
+++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
@@ -32,6 +32,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import Ouroboros.Consensus.Storage.LedgerDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB
 import Ouroboros.Consensus.Storage.LedgerDB.V2.Args
+import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDbArgs (..))
 import Ouroboros.Consensus.Storage.VolatileDB
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util.Args
@@ -135,6 +136,10 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} =
           , lgrQueryBatchSize = DefaultQueryBatchSize
           , lgrStartSnapshot = Nothing
           }
+    , cdbPerasCertDbArgs =
+        PerasCertDbArgs
+          { pcdbaTracer = nullTracer
+          }
     , cdbsArgs =
         ChainDbSpecificArgs
           { cdbsBlocksToAddSize = 1
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
index f9dc991a34..69b40e4f92 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
@@ -127,6 +127,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal
 import Ouroboros.Consensus.Storage.LedgerDB (LedgerSupportsLedgerDB)
 import qualified Ouroboros.Consensus.Storage.LedgerDB.TraceEvent as LedgerDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbChangelog
+import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util (split)
 import Ouroboros.Consensus.Util.CallStack
@@ -1330,6 +1331,8 @@ deriving instance SOP.Generic (ImmutableDB.TraceEvent blk)
 deriving instance SOP.HasDatatypeInfo (ImmutableDB.TraceEvent blk)
 deriving instance SOP.Generic (VolatileDB.TraceEvent blk)
 deriving instance SOP.HasDatatypeInfo (VolatileDB.TraceEvent blk)
+deriving instance SOP.Generic (PerasCertDB.TraceEvent blk)
+deriving instance SOP.HasDatatypeInfo (PerasCertDB.TraceEvent blk)
 deriving anyclass instance SOP.Generic (TraceChainSelStarvationEvent blk)
 deriving anyclass instance SOP.HasDatatypeInfo (TraceChainSelStarvationEvent blk)
 
@@ -1756,6 +1759,7 @@ traceEventName = \case
   TraceLedgerDBEvent ev -> "Ledger." <> constrName ev
   TraceImmutableDBEvent ev -> "ImmutableDB." <> constrName ev
   TraceVolatileDBEvent ev -> "VolatileDB." <> constrName ev
+  TracePerasCertDbEvent ev -> "PerasCertDB." <> constrName ev
   TraceLastShutdownUnclean -> "LastShutdownUnclean"
   TraceChainSelStarvationEvent ev -> "ChainSelStarvation." <> constrName ev
 

From 5246a5414f64596591ce699912824290e720a58d Mon Sep 17 00:00:00 2001
From: Thomas BAGREL <thomas.bagrel@tweag.io>
Date: Mon, 7 Jul 2025 17:18:43 +0200
Subject: [PATCH 07/42] [WIP] set structure for model-based testing for
 PerasCertDB

---
 ouroboros-consensus/ouroboros-consensus.cabal |  3 +
 .../Consensus/Block/SupportsPeras.hs          |  3 +-
 .../Consensus/Storage/PerasCertDB/API.hs      |  3 +
 .../storage-test/Test/Ouroboros/Storage.hs    |  3 +
 .../Test/Ouroboros/Storage/PerasCertDB.hs     | 17 ++++++
 .../Ouroboros/Storage/PerasCertDB/Model.hs    | 60 +++++++++++++++++++
 .../Storage/PerasCertDB/StateMachine.hs       | 29 +++++++++
 7 files changed, 117 insertions(+), 1 deletion(-)
 create mode 100644 ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs
 create mode 100644 ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
 create mode 100644 ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs

diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index a391ba4b89..9482550ab6 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -712,6 +712,9 @@ test-suite storage-test
     Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog
     Test.Ouroboros.Storage.LedgerDB.V1.LMDB
     Test.Ouroboros.Storage.Orphans
+    Test.Ouroboros.Storage.PerasCertDB
+    Test.Ouroboros.Storage.PerasCertDB.Model
+    Test.Ouroboros.Storage.PerasCertDB.StateMachine
     Test.Ouroboros.Storage.VolatileDB
     Test.Ouroboros.Storage.VolatileDB.Mock
     Test.Ouroboros.Storage.VolatileDB.Model
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
index 70d547c913..e70914f5c3 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
@@ -23,6 +23,7 @@ import Ouroboros.Consensus.Block.Abstract
 
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving stock Show
+  deriving Generic
   deriving newtype (Eq, Ord, NoThunks)
 
 newtype PerasWeight = PerasWeight {unPerasWeight :: Word64}
@@ -50,7 +51,7 @@ instance StandardHash blk => BlockSupportsPeras blk where
     { pcCertRound :: PerasRoundNo
     , pcCertBoostedBlock :: Point blk
     }
-    deriving stock Generic
+    deriving stock (Generic, Eq, Ord, Show)
     deriving anyclass NoThunks
 
   perasCertRound = pcCertRound
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
index 92f55946e4..0f9eb80894 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 module Ouroboros.Consensus.Storage.PerasCertDB.API
   ( PerasCertDB (..)
@@ -17,6 +18,7 @@ import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
+import GHC.Generics (Generic)
 
 data PerasCertDB m blk = PerasCertDB
   { addCert :: PerasCert blk -> m ()
@@ -29,6 +31,7 @@ newtype PerasWeightSnapshot blk = PerasWeightSnapshot
   { getPerasWeightSnapshot :: Map (Point blk) PerasWeight
   }
   deriving stock Show
+  deriving Generic
   deriving newtype NoThunks
 
 boostedWeightForPoint ::
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
index 419d8872a7..c8deb68894 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
@@ -6,6 +6,8 @@ import qualified Test.Ouroboros.Storage.ChainDB as ChainDB
 import qualified Test.Ouroboros.Storage.ImmutableDB as ImmutableDB
 import qualified Test.Ouroboros.Storage.LedgerDB as LedgerDB
 import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB
+import qualified Test.Ouroboros.Storage.PerasCertDB as PerasCertDB
+
 import Test.Tasty (TestTree, testGroup)
 
 --
@@ -20,4 +22,5 @@ tests =
     , VolatileDB.tests
     , LedgerDB.tests
     , ChainDB.tests
+    , PerasCertDB.tests
     ]
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs
new file mode 100644
index 0000000000..6a3f06bf90
--- /dev/null
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE CPP #-}
+
+module Test.Ouroboros.Storage.PerasCertDB (tests) where
+
+import qualified Test.Ouroboros.Storage.PerasCertDB.StateMachine as StateMachine
+import Test.Tasty (TestTree, testGroup)
+
+--
+-- The list of all PerasCertDB tests
+--
+
+tests :: TestTree
+tests =
+  testGroup
+    "PerasCertDB"
+    [ StateMachine.tests
+    ]
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
new file mode 100644
index 0000000000..5cb66374f1
--- /dev/null
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Test.Ouroboros.Storage.PerasCertDB.Model
+  ( PerasCertDBModel,
+    initPerasCertDBModel,
+    openDBModel,
+    closeDBModel,
+    addCertModel,
+    getWeightSnapshotModel
+  ) where
+import Ouroboros.Consensus.Block (PerasCert, boostPerCert, perasCertBoostedBlock, StandardHash)
+import Data.Set (Set)
+import GHC.Generics (Generic)
+import Data.Proxy (Proxy)
+import qualified Data.Set as Set
+import Ouroboros.Consensus.Storage.PerasCertDB.API
+import qualified Data.Map as Map
+import Data.Vector.Internal.Check (HasCallStack)
+import Ouroboros.Consensus.Storage.PerasCertDB.Impl (PerasCertDbError(..))
+import Ouroboros.Consensus.Util.CallStack (prettyCallStack)
+
+data PerasCertDBModel blk = PerasCertDBModel
+    {
+        open :: Bool,
+        certs :: Set (PerasCert blk)
+    } deriving Generic
+
+deriving instance (StandardHash blk) => Show (PerasCertDBModel blk)
+
+initPerasCertDBModel :: Proxy blk -> PerasCertDBModel blk
+initPerasCertDBModel _ = PerasCertDBModel
+    { open = False
+    , certs = Set.empty
+    }
+
+openDBModel :: PerasCertDBModel blk -> PerasCertDBModel blk
+openDBModel model = model { open = True }
+
+closeDBModel :: PerasCertDBModel blk -> PerasCertDBModel blk
+closeDBModel model = model { open = False }
+
+addCertModel :: (HasCallStack, StandardHash blk) => PerasCertDBModel blk -> PerasCert blk -> Either PerasCertDbError (PerasCertDBModel blk)
+addCertModel model cert =
+    if open model
+    then Right model { certs = Set.insert cert (certs model) }
+    else Left (ClosedDBError prettyCallStack)
+
+getWeightSnapshotModel :: (HasCallStack, StandardHash blk) => PerasCertDBModel blk -> Either PerasCertDbError (PerasWeightSnapshot blk)
+getWeightSnapshotModel model =
+    if open model
+    then
+        Right $ PerasWeightSnapshot {
+            getPerasWeightSnapshot = Set.fold
+                (\cert acc -> Map.insertWith (<>) (perasCertBoostedBlock cert) boostPerCert acc)
+                Map.empty
+                (certs model)
+        }
+    else Left (ClosedDBError prettyCallStack)
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
new file mode 100644
index 0000000000..1f635bec7f
--- /dev/null
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -0,0 +1,29 @@
+
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where
+import Test.Tasty (TestTree)
+import Test.Ouroboros.Storage.TestBlock (TestBlock)
+import Ouroboros.Consensus.Block.SupportsPeras
+import Test.Ouroboros.Storage.PerasCertDB.Model
+import Test.QuickCheck.StateModel
+import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot)
+
+tests :: TestTree
+tests = undefined
+
+type Block = TestBlock
+newtype Model = Model (PerasCertDBModel Block) deriving (Show, Generic)
+
+instance StateModel Model where
+  data Action Model a where
+    OpenDB :: Action Model ()
+    CloseDB :: Action Model ()
+    AddCert :: PerasCert Block -> Action Model ()
+    GetWeightSnapshot :: Action Model (PerasWeightSnapshot Block)
+
+  arbitraryAction _ _ = error "arbitraryAction not implemented"
+  initialState = error "initialState not implemented"

From aa94e92134b35da230d44e32b99eaf142a49518b Mon Sep 17 00:00:00 2001
From: Thomas BAGREL <thomas.bagrel@tweag.io>
Date: Tue, 8 Jul 2025 11:21:25 +0200
Subject: [PATCH 08/42] Fix missing instances

---
 .../Ouroboros/Storage/PerasCertDB/StateMachine.hs     | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
index 1f635bec7f..2712b8698f 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -11,6 +11,7 @@ import Ouroboros.Consensus.Block.SupportsPeras
 import Test.Ouroboros.Storage.PerasCertDB.Model
 import Test.QuickCheck.StateModel
 import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot)
+import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDbError)
 
 tests :: TestTree
 tests = undefined
@@ -22,8 +23,14 @@ instance StateModel Model where
   data Action Model a where
     OpenDB :: Action Model ()
     CloseDB :: Action Model ()
-    AddCert :: PerasCert Block -> Action Model ()
-    GetWeightSnapshot :: Action Model (PerasWeightSnapshot Block)
+    AddCert :: PerasCert Block -> Action Model (Either PerasCertDbError ())
+    GetWeightSnapshot :: Action Model (Either PerasCertDbError (PerasWeightSnapshot Block))
 
   arbitraryAction _ _ = error "arbitraryAction not implemented"
   initialState = error "initialState not implemented"
+
+deriving instance Show (Action Model a)
+
+instance HasVariables (Action Model a) where
+  getAllVariables _ = mempty
+

From 5fc441d98b871457caeb80774dd45a3fdce4ad63 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Tue, 8 Jul 2025 13:01:39 +0200
Subject: [PATCH 09/42] Pairing

---
 .../Consensus/Block/SupportsPeras.hs          |   1 +
 .../Consensus/Storage/PerasCertDB/API.hs      |   6 +-
 .../Ouroboros/Storage/PerasCertDB/Model.hs    | 104 ++++++++-------
 .../Storage/PerasCertDB/StateMachine.hs       | 122 +++++++++++++++---
 4 files changed, 160 insertions(+), 73 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
index e70914f5c3..d55a9cd214 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
@@ -13,6 +13,7 @@ module Ouroboros.Consensus.Block.SupportsPeras
   , PerasWeight (..)
   , boostPerCert
   , BlockSupportsPeras (..)
+  , PerasCert (..)
   ) where
 
 import Data.Monoid (Sum (..))
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
index 0f9eb80894..3d0c610887 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
@@ -1,8 +1,8 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DeriveGeneric #-}
 
 module Ouroboros.Consensus.Storage.PerasCertDB.API
   ( PerasCertDB (..)
@@ -13,12 +13,12 @@ module Ouroboros.Consensus.Storage.PerasCertDB.API
 
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
-import GHC.Generics (Generic)
 
 data PerasCertDB m blk = PerasCertDB
   { addCert :: PerasCert blk -> m ()
@@ -30,7 +30,7 @@ data PerasCertDB m blk = PerasCertDB
 newtype PerasWeightSnapshot blk = PerasWeightSnapshot
   { getPerasWeightSnapshot :: Map (Point blk) PerasWeight
   }
-  deriving stock Show
+  deriving stock (Show, Eq)
   deriving Generic
   deriving newtype NoThunks
 
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
index 5cb66374f1..390ffe36bc 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
@@ -1,60 +1,58 @@
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
+
 module Test.Ouroboros.Storage.PerasCertDB.Model
-  ( PerasCertDBModel,
-    initPerasCertDBModel,
-    openDBModel,
-    closeDBModel,
-    addCertModel,
-    getWeightSnapshotModel
+  ( Model (..)
+  , initModel
+  , openDB
+  , closeDB
+  , addCert
+  , getWeightSnapshot
   ) where
-import Ouroboros.Consensus.Block (PerasCert, boostPerCert, perasCertBoostedBlock, StandardHash)
+
+import qualified Data.Map as Map
 import Data.Set (Set)
-import GHC.Generics (Generic)
-import Data.Proxy (Proxy)
 import qualified Data.Set as Set
-import Ouroboros.Consensus.Storage.PerasCertDB.API
-import qualified Data.Map as Map
-import Data.Vector.Internal.Check (HasCallStack)
-import Ouroboros.Consensus.Storage.PerasCertDB.Impl (PerasCertDbError(..))
-import Ouroboros.Consensus.Util.CallStack (prettyCallStack)
-
-data PerasCertDBModel blk = PerasCertDBModel
-    {
-        open :: Bool,
-        certs :: Set (PerasCert blk)
-    } deriving Generic
-
-deriving instance (StandardHash blk) => Show (PerasCertDBModel blk)
-
-initPerasCertDBModel :: Proxy blk -> PerasCertDBModel blk
-initPerasCertDBModel _ = PerasCertDBModel
-    { open = False
-    , certs = Set.empty
-    }
-
-openDBModel :: PerasCertDBModel blk -> PerasCertDBModel blk
-openDBModel model = model { open = True }
-
-closeDBModel :: PerasCertDBModel blk -> PerasCertDBModel blk
-closeDBModel model = model { open = False }
-
-addCertModel :: (HasCallStack, StandardHash blk) => PerasCertDBModel blk -> PerasCert blk -> Either PerasCertDbError (PerasCertDBModel blk)
-addCertModel model cert =
-    if open model
-    then Right model { certs = Set.insert cert (certs model) }
-    else Left (ClosedDBError prettyCallStack)
-
-getWeightSnapshotModel :: (HasCallStack, StandardHash blk) => PerasCertDBModel blk -> Either PerasCertDbError (PerasWeightSnapshot blk)
-getWeightSnapshotModel model =
-    if open model
-    then
-        Right $ PerasWeightSnapshot {
-            getPerasWeightSnapshot = Set.fold
-                (\cert acc -> Map.insertWith (<>) (perasCertBoostedBlock cert) boostPerCert acc)
-                Map.empty
-                (certs model)
-        }
-    else Left (ClosedDBError prettyCallStack)
+import GHC.Generics (Generic)
+import Ouroboros.Consensus.Block (PerasCert, StandardHash, boostPerCert, perasCertBoostedBlock)
+import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot (..))
+
+data Model blk = Model
+  { certs :: Set (PerasCert blk)
+  , open :: Bool
+  }
+  deriving Generic
+
+deriving instance StandardHash blk => Show (Model blk)
+
+initModel :: Model blk
+initModel = Model{open = False, certs = Set.empty}
+
+openDB :: Model blk -> Model blk
+openDB model = model{open = True}
+
+closeDB :: Model blk -> Model blk
+closeDB _ = Model{open = False, certs = Set.empty}
+
+addCert ::
+  StandardHash blk =>
+  Model blk -> PerasCert blk -> Model blk
+addCert model@Model{certs} cert =
+  model{certs = Set.insert cert certs}
+
+getWeightSnapshot ::
+  StandardHash blk =>
+  Model blk -> PerasWeightSnapshot blk
+getWeightSnapshot Model{certs} = snap
+ where
+  snap =
+    PerasWeightSnapshot
+      { getPerasWeightSnapshot =
+          Set.fold
+            (\cert acc -> Map.insertWith (<>) (perasCertBoostedBlock cert) boostPerCert acc)
+            Map.empty
+            certs
+      }
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
index 2712b8698f..de815c8ffe 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -1,36 +1,124 @@
-
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where
-import Test.Tasty (TestTree)
-import Test.Ouroboros.Storage.TestBlock (TestBlock)
-import Ouroboros.Consensus.Block.SupportsPeras
-import Test.Ouroboros.Storage.PerasCertDB.Model
+
+import Control.Monad.State
+import Control.Tracer (nullTracer)
+import qualified Data.List.NonEmpty as NE
+import Ouroboros.Consensus.Block
+import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
+import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB, PerasWeightSnapshot)
+import Ouroboros.Consensus.Util.IOLike
+import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model
+import Test.QuickCheck hiding (Some (..))
+import qualified Test.QuickCheck.Monadic as QC
 import Test.QuickCheck.StateModel
-import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot)
-import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDbError)
+import Test.Tasty
+import Test.Tasty.QuickCheck hiding (Some (..))
+import Test.Util.TestBlock (TestBlock, TestHash (..))
+import Test.Util.TestEnv (adjustQuickCheckTests)
 
 tests :: TestTree
-tests = undefined
+tests =
+  testGroup
+    "PerasCertDB"
+    [ adjustQuickCheckTests (* 100) $ testProperty "q-d" $ prop_qd
+    ]
+
+prop_qd :: Actions Model -> Property
+prop_qd actions = QC.monadic f $ property () <$ runActions actions
+ where
+  f :: StateT (PerasCertDB IO TestBlock) IO Property -> Property
+  f = ioProperty . flip evalStateT (error "unreachable")
 
 type Block = TestBlock
-newtype Model = Model (PerasCertDBModel Block) deriving (Show, Generic)
+newtype Model = Model (Model.Model Block) deriving (Show, Generic)
 
 instance StateModel Model where
   data Action Model a where
     OpenDB :: Action Model ()
     CloseDB :: Action Model ()
-    AddCert :: PerasCert Block -> Action Model (Either PerasCertDbError ())
-    GetWeightSnapshot :: Action Model (Either PerasCertDbError (PerasWeightSnapshot Block))
+    AddCert :: PerasCert Block -> Action Model ()
+    GetWeightSnapshot :: Action Model (PerasWeightSnapshot Block)
+
+  arbitraryAction _ (Model model)
+    | model.open =
+        frequency
+          [ (1, pure $ Some CloseDB)
+          , (20, Some <$> genAddCert)
+          , (20, pure $ Some GetWeightSnapshot)
+          ]
+    | otherwise = pure $ Some OpenDB
+   where
+    genAddCert = do
+      pcCertRound <- PerasRoundNo <$> arbitrary
+      pcCertBoostedBlock <- arbitrary
+      pure $ AddCert PerasCert{pcCertRound, pcCertBoostedBlock}
+
+  initialState = Model Model.initModel
 
-  arbitraryAction _ _ = error "arbitraryAction not implemented"
-  initialState = error "initialState not implemented"
+  nextState (Model model) action _ = Model $ case action of
+    OpenDB -> Model.openDB model
+    CloseDB -> Model.closeDB model
+    AddCert cert -> Model.addCert model cert
+    GetWeightSnapshot -> model
 
-deriving instance Show (Action Model a)
+  precondition (Model model) = \case
+    OpenDB -> not model.open
+    action ->
+      model.open && case action of
+        CloseDB -> True
+        AddCert cert -> all p model.certs
+         where
+          p cert' = perasCertRound cert /= perasCertRound cert' || cert == cert'
+        GetWeightSnapshot -> True
+
+deriving stock instance Show (Action Model a)
+deriving stock instance Eq (Action Model a)
 
 instance HasVariables (Action Model a) where
   getAllVariables _ = mempty
 
+instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where
+  perform _ action _ = case action of
+    OpenDB -> do
+      perasCertDB <- lift $ PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs nullTracer)
+      put perasCertDB
+    CloseDB -> do
+      perasCertDB <- get
+      lift $ PerasCertDB.closeDB perasCertDB
+    AddCert cert -> do
+      perasCertDB <- get
+      lift $ PerasCertDB.addCert perasCertDB cert
+    GetWeightSnapshot -> do
+      perasCertDB <- get
+      lift $ atomically $ PerasCertDB.getWeightSnapshot perasCertDB
+
+  -- TODO: check open state consistency
+  postcondition (Model model, _) GetWeightSnapshot _ actual = do
+    let expected = Model.getWeightSnapshot model
+    counterexamplePost $ "Model: " <> show expected
+    counterexamplePost $ "SUT: " <> show actual
+    pure $ expected == actual
+  postcondition _ _ _ _ = pure True
+
+-- TODO very ugly
+instance Arbitrary (Point TestBlock) where
+  arbitrary =
+    oneof
+      [ return GenesisPoint
+      , BlockPoint <$> (SlotNo <$> arbitrary) <*> (TestHash . NE.fromList . getNonEmpty <$> arbitrary)
+      ]

From b5cea4745e917a3ae21c38e6e94be0d34be59cc9 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Wed, 9 Jul 2025 12:48:14 +0200
Subject: [PATCH 10/42] Minor polishing

 - Avoid orphans

 - We actually can't check that the open states are consistent directly as we
   would need to statefully get that info from the SUT.
---
 .../storage-test/Test/Ouroboros/Storage.hs    |  3 +-
 .../Storage/PerasCertDB/StateMachine.hs       | 29 +++++++++----------
 2 files changed, 15 insertions(+), 17 deletions(-)

diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
index c8deb68894..1153457c70 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
@@ -5,9 +5,8 @@ module Test.Ouroboros.Storage (tests) where
 import qualified Test.Ouroboros.Storage.ChainDB as ChainDB
 import qualified Test.Ouroboros.Storage.ImmutableDB as ImmutableDB
 import qualified Test.Ouroboros.Storage.LedgerDB as LedgerDB
-import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB
 import qualified Test.Ouroboros.Storage.PerasCertDB as PerasCertDB
-
+import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB
 import Test.Tasty (TestTree, testGroup)
 
 --
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
index de815c8ffe..6a9d60d73a 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -11,7 +11,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where
 
@@ -44,15 +43,14 @@ prop_qd actions = QC.monadic f $ property () <$ runActions actions
   f :: StateT (PerasCertDB IO TestBlock) IO Property -> Property
   f = ioProperty . flip evalStateT (error "unreachable")
 
-type Block = TestBlock
-newtype Model = Model (Model.Model Block) deriving (Show, Generic)
+newtype Model = Model (Model.Model TestBlock) deriving (Show, Generic)
 
 instance StateModel Model where
   data Action Model a where
     OpenDB :: Action Model ()
     CloseDB :: Action Model ()
-    AddCert :: PerasCert Block -> Action Model ()
-    GetWeightSnapshot :: Action Model (PerasWeightSnapshot Block)
+    AddCert :: PerasCert TestBlock -> Action Model ()
+    GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock)
 
   arbitraryAction _ (Model model)
     | model.open =
@@ -65,9 +63,18 @@ instance StateModel Model where
    where
     genAddCert = do
       pcCertRound <- PerasRoundNo <$> arbitrary
-      pcCertBoostedBlock <- arbitrary
+      pcCertBoostedBlock <- genPoint
       pure $ AddCert PerasCert{pcCertRound, pcCertBoostedBlock}
 
+    genPoint :: Gen (Point TestBlock)
+    genPoint =
+      oneof
+        [ return GenesisPoint
+        , BlockPoint <$> (SlotNo <$> arbitrary) <*> genHash
+        ]
+     where
+      genHash = TestHash . NE.fromList . getNonEmpty <$> arbitrary
+
   initialState = Model Model.initModel
 
   nextState (Model model) action _ = Model $ case action of
@@ -81,6 +88,7 @@ instance StateModel Model where
     action ->
       model.open && case action of
         CloseDB -> True
+        -- Do not add equivocating certificates.
         AddCert cert -> all p model.certs
          where
           p cert' = perasCertRound cert /= perasCertRound cert' || cert == cert'
@@ -107,18 +115,9 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where
       perasCertDB <- get
       lift $ atomically $ PerasCertDB.getWeightSnapshot perasCertDB
 
-  -- TODO: check open state consistency
   postcondition (Model model, _) GetWeightSnapshot _ actual = do
     let expected = Model.getWeightSnapshot model
     counterexamplePost $ "Model: " <> show expected
     counterexamplePost $ "SUT: " <> show actual
     pure $ expected == actual
   postcondition _ _ _ _ = pure True
-
--- TODO very ugly
-instance Arbitrary (Point TestBlock) where
-  arbitrary =
-    oneof
-      [ return GenesisPoint
-      , BlockPoint <$> (SlotNo <$> arbitrary) <*> (TestHash . NE.fromList . getNonEmpty <$> arbitrary)
-      ]

From 5a58067dc8278fb683657f02ab5b9398ae0feb42 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Wed, 9 Jul 2025 18:03:46 +0200
Subject: [PATCH 11/42] PerasCertDB: implement garbage collection

---
 .../Consensus/Storage/PerasCertDB/API.hs      |   2 +
 .../Consensus/Storage/PerasCertDB/Impl.hs     | 104 ++++++++++++++----
 .../Ouroboros/Storage/PerasCertDB/Model.hs    |   9 +-
 .../Storage/PerasCertDB/StateMachine.hs       |   7 ++
 4 files changed, 100 insertions(+), 22 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
index 3d0c610887..030393dbbc 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
@@ -23,6 +23,8 @@ import qualified Ouroboros.Network.AnchoredFragment as AF
 data PerasCertDB m blk = PerasCertDB
   { addCert :: PerasCert blk -> m ()
   , getWeightSnapshot :: STM m (PerasWeightSnapshot blk)
+  , garbageCollect :: SlotNo -> m ()
+  -- ^ Garbage-collect state older than the given slot number.
   , closeDB :: m ()
   }
   deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
index 1369a691eb..ae35b03f67 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
@@ -23,10 +23,9 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl
 import Control.Monad (join)
 import Control.Tracer (Tracer, nullTracer, traceWith)
 import Data.Kind (Type)
+import qualified Data.Map.Merge.Strict as Map
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
@@ -58,13 +57,11 @@ openDB ::
   Complete PerasCertDbArgs m blk ->
   m (PerasCertDB m blk)
 openDB args = do
-  pcdbRoundNos <- newTVarIO Set.empty
-  pcdbWeightByPoint <- newTVarIO Map.empty
+  pcdbVolatileState <- newTVarIO initialPerasVolatileCertState
   let env =
         PerasCertDbEnv
           { pcdbTracer
-          , pcdbRoundNos
-          , pcdbWeightByPoint
+          , pcdbVolatileState
           }
   h <- PerasCertDbHandle <$> newTVarIO (PerasCertDbOpen env)
   traceWith pcdbTracer OpenedPerasCertDB
@@ -72,6 +69,7 @@ openDB args = do
     PerasCertDB
       { addCert = getEnv1 h implAddCert
       , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot
+      , garbageCollect = getEnv1 h implGarbageCollect
       , closeDB = implCloseDB h
       }
  where
@@ -93,13 +91,8 @@ data PerasCertDbState m blk
 
 data PerasCertDbEnv m blk = PerasCertDbEnv
   { pcdbTracer :: !(Tracer m (TraceEvent blk))
-  , pcdbRoundNos :: !(StrictTVar m (Set PerasRoundNo))
+  , pcdbVolatileState :: !(StrictTVar m (PerasVolatileCertState blk))
   -- ^ The 'RoundNo's of all certificates currently in the db.
-  , pcdbWeightByPoint :: !(StrictTVar m (Map (Point blk) PerasWeight))
-  -- ^ The weight of boosted blocks w.r.t. the certificates currently in the
-  -- db.
-  --
-  -- INVARIANT: In sync with 'pcdbRoundNos'.
   }
   deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDbEnv" (PerasCertDbEnv m blk)
 
@@ -154,20 +147,25 @@ implAddCert ::
 implAddCert env cert = do
   traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt
   join $ atomically $ do
-    roundNos <- readTVar pcdbRoundNos
-    if Set.member roundNo roundNos
+    PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} <- readTVar pcdbVolatileState
+    if Map.member roundNo pvcsCerts
       then do
         pure $ traceWith pcdbTracer $ IgnoredCertAlreadyInDB roundNo boostedPt
       else do
-        writeTVar pcdbRoundNos $ Set.insert roundNo roundNos
-        -- Note that the same block might be boosted by multiple points.
-        modifyTVar pcdbWeightByPoint $ Map.insertWith (<>) boostedPt boostPerCert
+        writeTVar
+          pcdbVolatileState
+          PerasVolatileCertState
+            { pvcsCerts =
+                Map.insert roundNo cert pvcsCerts
+            , -- Note that the same block might be boosted by multiple points.
+              pvcsWeightByPoint =
+                Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint
+            }
         pure $ traceWith pcdbTracer $ AddedPerasCert roundNo boostedPt
  where
   PerasCertDbEnv
     { pcdbTracer
-    , pcdbRoundNos
-    , pcdbWeightByPoint
+    , pcdbVolatileState
     } = env
 
   roundNo = perasCertRound cert
@@ -176,8 +174,72 @@ implAddCert env cert = do
 implGetWeightSnapshot ::
   IOLike m =>
   PerasCertDbEnv m blk -> STM m (PerasWeightSnapshot blk)
-implGetWeightSnapshot PerasCertDbEnv{pcdbWeightByPoint} =
-  PerasWeightSnapshot <$> readTVar pcdbWeightByPoint
+implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} =
+  PerasWeightSnapshot . pvcsWeightByPoint <$> readTVar pcdbVolatileState
+
+implGarbageCollect ::
+  forall m blk.
+  (IOLike m, StandardHash blk) =>
+  PerasCertDbEnv m blk -> SlotNo -> m ()
+implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
+  atomically $ modifyTVar pcdbVolatileState gc
+ where
+  gc :: PerasVolatileCertState blk -> PerasVolatileCertState blk
+  gc PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} =
+    PerasVolatileCertState
+      { pvcsCerts = certsToKeep
+      , pvcsWeightByPoint =
+          Map.merge
+            -- Do not touch weight of boosted blocks that we do not subtract any
+            -- weight from.
+            Map.preserveMissing
+            -- Irrelevant, the key set of @weightToRemove@ is a subset of the
+            -- key set of @pvcsWeightByPoint@.
+            Map.dropMissing
+            (Map.zipWithMaybeMatched $ \_pt -> subtractWeight)
+            pvcsWeightByPoint
+            weightToRemove
+      }
+   where
+    (certsToRemove, certsToKeep) =
+      Map.partition isTooOld pvcsCerts
+    isTooOld cert =
+      pointSlot (perasCertBoostedBlock cert) < NotOrigin slot
+    weightToRemove =
+      Map.fromListWith
+        (<>)
+        [ (perasCertBoostedBlock cert, boostPerCert)
+        | cert <- Map.elems certsToRemove
+        ]
+
+  subtractWeight :: PerasWeight -> PerasWeight -> Maybe PerasWeight
+  subtractWeight (PerasWeight w1) (PerasWeight w2)
+    | w1 > w2 = Just $ PerasWeight (w1 - w2)
+    | otherwise = Nothing
+
+{-------------------------------------------------------------------------------
+  Implementation-internal types
+-------------------------------------------------------------------------------}
+
+-- | Volatile Peras certificate state, i.e. certificates that could influence
+-- chain selection by boosting a volatile block.
+data PerasVolatileCertState blk = PerasVolatileCertState
+  { pvcsCerts :: !(Map PerasRoundNo (PerasCert blk))
+  -- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db.
+  , pvcsWeightByPoint :: !(Map (Point blk) PerasWeight)
+  -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db.
+  --
+  -- INVARIANT: In sync with 'pvcsCerts'.
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass NoThunks
+
+initialPerasVolatileCertState :: PerasVolatileCertState blk
+initialPerasVolatileCertState =
+  PerasVolatileCertState
+    { pvcsCerts = Map.empty
+    , pvcsWeightByPoint = Map.empty
+    }
 
 {-------------------------------------------------------------------------------
   Trace types
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
index 390ffe36bc..6b28875a2b 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
@@ -11,13 +11,14 @@ module Test.Ouroboros.Storage.PerasCertDB.Model
   , closeDB
   , addCert
   , getWeightSnapshot
+  , garbageCollect
   ) where
 
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import GHC.Generics (Generic)
-import Ouroboros.Consensus.Block (PerasCert, StandardHash, boostPerCert, perasCertBoostedBlock)
+import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot (..))
 
 data Model blk = Model
@@ -56,3 +57,9 @@ getWeightSnapshot Model{certs} = snap
             Map.empty
             certs
       }
+
+garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk
+garbageCollect slot model@Model{certs} =
+  model{certs = Set.filter keepCert certs}
+ where
+  keepCert cert = pointSlot (perasCertBoostedBlock cert) >= NotOrigin slot
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
index 6a9d60d73a..516883fcba 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -51,6 +51,7 @@ instance StateModel Model where
     CloseDB :: Action Model ()
     AddCert :: PerasCert TestBlock -> Action Model ()
     GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock)
+    GarbageCollect :: SlotNo -> Action Model ()
 
   arbitraryAction _ (Model model)
     | model.open =
@@ -58,6 +59,7 @@ instance StateModel Model where
           [ (1, pure $ Some CloseDB)
           , (20, Some <$> genAddCert)
           , (20, pure $ Some GetWeightSnapshot)
+          , (5, Some . GarbageCollect . SlotNo <$> arbitrary)
           ]
     | otherwise = pure $ Some OpenDB
    where
@@ -82,6 +84,7 @@ instance StateModel Model where
     CloseDB -> Model.closeDB model
     AddCert cert -> Model.addCert model cert
     GetWeightSnapshot -> model
+    GarbageCollect slot -> Model.garbageCollect slot model
 
   precondition (Model model) = \case
     OpenDB -> not model.open
@@ -93,6 +96,7 @@ instance StateModel Model where
          where
           p cert' = perasCertRound cert /= perasCertRound cert' || cert == cert'
         GetWeightSnapshot -> True
+        GarbageCollect _slot -> True
 
 deriving stock instance Show (Action Model a)
 deriving stock instance Eq (Action Model a)
@@ -114,6 +118,9 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where
     GetWeightSnapshot -> do
       perasCertDB <- get
       lift $ atomically $ PerasCertDB.getWeightSnapshot perasCertDB
+    GarbageCollect slot -> do
+      perasCertDB <- get
+      lift $ PerasCertDB.garbageCollect perasCertDB slot
 
   postcondition (Model model, _) GetWeightSnapshot _ actual = do
     let expected = Model.getWeightSnapshot model

From 45b3add5402828673cdc7440e006b18c84934baf Mon Sep 17 00:00:00 2001
From: Georgy Lukyanov <georgy.lukyanov@iohk.io>
Date: Mon, 7 Jul 2025 11:53:33 +0200
Subject: [PATCH 12/42] Mention ChainSync Client benchmark

---
 docs/website/contents/for-developers/Benchmarks.md | 13 ++++++++++++-
 1 file changed, 12 insertions(+), 1 deletion(-)

diff --git a/docs/website/contents/for-developers/Benchmarks.md b/docs/website/contents/for-developers/Benchmarks.md
index 36190736a4..48a93d5039 100644
--- a/docs/website/contents/for-developers/Benchmarks.md
+++ b/docs/website/contents/for-developers/Benchmarks.md
@@ -1,6 +1,11 @@
 # Consensus benchmarks
 
 We are in the process of adding component level microbenchmarks for Consensus.
+
+We check for regressions in performance on CI.
+
+## Mempool Benchmark
+
 We started with microbenchmarks for adding transactions to the mempool. The
 mempool benchmarks can be run using the following command.
 
@@ -8,4 +13,10 @@ mempool benchmarks can be run using the following command.
 cabal new-run ouroboros-consensus:mempool-bench
 ```
 
-We check for regressions in performance on CI. We might publish benchmark results in this site shortly.
+## ChainSync Client Benchmark
+
+To aid the refactoring of the ChainSync client, we added a benchmark for it in [PR#823](https://github.com/IntersectMBO/ouroboros-consensus/pull/823). The benchmark could be invoked as follows:
+
+```sh
+cabal new-run ouroboros-consensus:ChainSync-client-bench -- 10 10
+```

From 046e0ff0a95527908bb632d927ff94c5e2e784e0 Mon Sep 17 00:00:00 2001
From: Georgy Lukyanov <georgy.lukyanov@iohk.io>
Date: Mon, 7 Jul 2025 15:09:51 +0200
Subject: [PATCH 13/42] ouroboros-consensus: add Peras chain weight benchmark

---
 .../contents/for-developers/Benchmarks.md     |  10 ++
 .../bench/PerasCertDB-bench/Main.hs           | 102 ++++++++++++++++++
 ouroboros-consensus/ouroboros-consensus.cabal |  14 +++
 3 files changed, 126 insertions(+)
 create mode 100644 ouroboros-consensus/bench/PerasCertDB-bench/Main.hs

diff --git a/docs/website/contents/for-developers/Benchmarks.md b/docs/website/contents/for-developers/Benchmarks.md
index 48a93d5039..94ce7fc0c7 100644
--- a/docs/website/contents/for-developers/Benchmarks.md
+++ b/docs/website/contents/for-developers/Benchmarks.md
@@ -20,3 +20,13 @@ To aid the refactoring of the ChainSync client, we added a benchmark for it in [
 ```sh
 cabal new-run ouroboros-consensus:ChainSync-client-bench -- 10 10
 ```
+
+## PerasCertDB Benchmark
+
+We have a microbenchmark for the boosted chain fragment weight calculation, which could be run as follows:
+
+```sh
+cabal run ouroboros-consensus:PerasCertDB-bench -- +RTS -T -A32m -RTS
+```
+
+We request GHC runtime system statistics with `-T` to get a memory usage estimate, and also request a large nursery with `-A32m` to minimise garbage collection. See `tasty-bench` [documentation](https://github.com/Bodigrim/tasty-bench?tab=readme-ov-file#troubleshooting) for more tips.
diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
new file mode 100644
index 0000000000..99e730c5d6
--- /dev/null
+++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | This module contains benchmarks for Peras chain weight calculation as implemented by
+--   the by the 'Ouroboros.Consensus.Storage.PerasCertDB.API.boostedWeightForFragment'
+--   function.
+--
+--   We benchmark the calculation on a static sequence of chain fragments of increasing
+--   length, ranging from 0 to around 8640, with a sampling rate of 100. The chain fragments
+--   are instantiated with 'TestBlock', and every 5 blocks there is a booster block with
+--   weight 15. All parameters are set in 'benchmarkParams'.
+module Main (main) where
+
+import Data.List (iterate')
+import Data.Map.Strict qualified as Map
+import Numeric.Natural (Natural)
+import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..))
+import Ouroboros.Consensus.Storage.PerasCertDB.API
+  ( PerasWeightSnapshot (..)
+  , boostedWeightForFragment
+  )
+import Ouroboros.Network.AnchoredFragment qualified as AF
+import Test.Ouroboros.Storage.TestBlock (TestBlock (..), TestBody (..), TestHeader (..))
+import Test.Ouroboros.Storage.TestBlock qualified as TestBlock
+import Test.Tasty.Bench
+
+data BenchmarkParams = BenchmarkParams
+  { blockRate :: SlotNo
+  -- ^ How often the fragments will contain blocks, in slots
+  , fragmentLenghtSamplingRate :: Natural
+  -- ^ The rate of length increase for generate chain fragments
+  , fragmentMaxLenght :: Natural
+  -- ^ the maximum length of a fragment
+  , boostedBlockRate :: Natural
+  -- ^ How often boosted blocks occur, in blocks
+  , boostWeight :: PerasWeight
+  -- ^ The weight of the boost
+  }
+
+benchmarkParams :: BenchmarkParams
+benchmarkParams =
+  BenchmarkParams
+    { blockRate = 20
+    , fragmentLenghtSamplingRate = 100
+    , fragmentMaxLenght = 2160 + 3 * 2160
+    , boostedBlockRate = 5
+    , boostWeight = PerasWeight 15
+    }
+
+main :: IO ()
+main =
+  Test.Tasty.Bench.defaultMain $ map benchBoostedWeightForFragment inputs
+ where
+  -- NOTE: we do not use the 'env' combinator to set up the test data since
+  --       it requires 'NFData' for 'AF.AnchoredFragment'. While the necessary
+  --       instances could be provided, we do not think is necessary for this
+  --       benchmark, as the input data is rather small.
+  inputs :: [(Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock))]
+  inputs =
+    getEveryN (fragmentLenghtSamplingRate benchmarkParams) $
+      take (fromIntegral $ fragmentMaxLenght benchmarkParams) $
+        zip [0 ..] $
+          zip (map uniformWeightSnapshot fragments) fragments
+
+benchBoostedWeightForFragment ::
+  (Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock)) -> Benchmark
+benchBoostedWeightForFragment (i, (weightSnapshot, fragment)) =
+  bench ("boostedWeightForFragment of length " <> show i) $
+    whnf (boostedWeightForFragment weightSnapshot) fragment
+
+-- | An infinite list of chain fragments
+fragments :: [AF.AnchoredFragment TestBlock]
+fragments = iterate' addSuccessorBlock genesisFragment
+ where
+  genesisFragment :: AF.AnchoredFragment TestBlock
+  genesisFragment = AF.Empty AF.AnchorGenesis
+
+  addSuccessorBlock :: AF.AnchoredFragment TestBlock -> AF.AnchoredFragment TestBlock
+  addSuccessorBlock = \case
+    AF.Empty _ -> (AF.Empty AF.AnchorGenesis) AF.:> (TestBlock.firstBlock 0 dummyBody)
+    (xs AF.:> x) ->
+      let nextBlockSlot = blockRate benchmarkParams + (thSlotNo . testHeader $ x)
+       in (xs AF.:> x) AF.:> TestBlock.mkNextBlock x nextBlockSlot dummyBody
+
+  dummyBody :: TestBody
+  dummyBody = TestBody{tbForkNo = 0, tbIsValid = True}
+
+-- | Given a chain fragment, construct a weight snapshot where there's a boosted block every 90 slots
+uniformWeightSnapshot :: AF.AnchoredFragment TestBlock -> PerasWeightSnapshot TestBlock
+uniformWeightSnapshot fragment =
+  let pointsToBoost =
+        map snd
+          . getEveryN (boostedBlockRate benchmarkParams)
+          . zip [0 ..]
+          . map AF.blockPoint
+          . AF.toOldestFirst
+          $ fragment
+      weights = repeat (boostWeight benchmarkParams)
+   in PerasWeightSnapshot{getPerasWeightSnapshot = Map.fromList $ zip pointsToBoost weights}
+
+getEveryN :: Natural -> [(Natural, a)] -> [(Natural, a)]
+getEveryN n = filter (\(i, _) -> (i `mod` n) == 0)
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index 9482550ab6..86ffb09b7e 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -824,6 +824,20 @@ benchmark ChainSync-client-bench
     unstable-consensus-testlib,
     with-utf8,
 
+benchmark PerasCertDB-bench
+  import: common-bench
+  type: exitcode-stdio-1.0
+  hs-source-dirs: bench/PerasCertDB-bench
+  main-is: Main.hs
+  other-modules:
+  build-depends:
+    base,
+    containers,
+    ouroboros-consensus,
+    ouroboros-network-api,
+    tasty-bench,
+    unstable-consensus-testlib,
+
 test-suite doctest
   import: common-test
   main-is: doctest.hs

From 138078332f55ead125c543d8d855eb3fb59d9c71 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 17 Jul 2025 12:13:24 +0200
Subject: [PATCH 14/42] ChainDB: expose PerasCertDB functionality

---
 .../Ouroboros/Consensus/Storage/ChainDB/API.hs              | 5 +++++
 .../Ouroboros/Consensus/Storage/ChainDB/Impl.hs             | 5 +++++
 .../Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs       | 6 ++++++
 3 files changed, 16 insertions(+)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
index 303fbcf78e..3631292a7d 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
@@ -90,6 +90,7 @@ import Ouroboros.Consensus.Storage.LedgerDB
   , ReadOnlyForker'
   , Statistics
   )
+import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot)
 import Ouroboros.Consensus.Storage.Serialisation
 import Ouroboros.Consensus.Util.CallStack
 import Ouroboros.Consensus.Util.IOLike
@@ -386,6 +387,10 @@ data ChainDB m blk = ChainDB
   , getStatistics :: m (Maybe Statistics)
   -- ^ Get statistics from the LedgerDB, in particular the number of entries
   -- in the tables.
+  , addPerasCert :: PerasCert blk -> m ()
+  -- ^ TODO
+  , getPerasWeightSnapshot :: STM m (PerasWeightSnapshot blk)
+  -- ^ TODO
   , closeDB :: m ()
   -- ^ Close the ChainDB
   --
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index c0b0785d02..f1db247f96 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -284,6 +284,11 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , getHeaderStateHistory = getEnvSTM h Query.getHeaderStateHistory
             , getReadOnlyForkerAtPoint = getEnv2 h Query.getReadOnlyForkerAtPoint
             , getStatistics = getEnv h Query.getStatistics
+            , addPerasCert = getEnv1 h $ \cdb@CDB{..} cert -> do
+                PerasCertDB.addCert cdbPerasCertDB cert
+                -- TODO trigger chain selection in a more efficient way
+                waitChainSelectionPromise =<< ChainSel.triggerChainSelectionAsync cdb
+            , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot
             }
     addBlockTestFuse <- newFuse "test chain selection"
     copyTestFuse <- newFuse "test copy to immutable db"
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
index 821586f745..3fcaf2ab3f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
@@ -18,6 +18,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query
   , getIsValid
   , getMaxSlotNo
   , getPastLedger
+  , getPerasWeightSnapshot
   , getReadOnlyForkerAtPoint
   , getStatistics
   , getTipBlock
@@ -52,6 +53,8 @@ import Ouroboros.Consensus.Storage.ChainDB.Impl.Types
 import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
+import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
+import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot)
 import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB)
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util (eitherToMaybe)
@@ -262,6 +265,9 @@ getReadOnlyForkerAtPoint CDB{..} = LedgerDB.getReadOnlyForker cdbLedgerDB
 getStatistics :: IOLike m => ChainDbEnv m blk -> m (Maybe LedgerDB.Statistics)
 getStatistics CDB{..} = LedgerDB.getTipStatistics cdbLedgerDB
 
+getPerasWeightSnapshot :: ChainDbEnv m blk -> STM m (PerasWeightSnapshot blk)
+getPerasWeightSnapshot CDB{..} = PerasCertDB.getWeightSnapshot cdbPerasCertDB
+
 {-------------------------------------------------------------------------------
   Unifying interface over the immutable DB and volatile DB, but independent
   of the ledger DB. These functions therefore do not require the entire

From 5eca0851bc9db4dc829c0603d018c6d79d556470 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 17 Jul 2025 12:13:45 +0200
Subject: [PATCH 15/42] ChainDB: invoke PerasCertDB GC

---
 .../Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs      | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
index 3df09ab9ea..4c0e9229cf 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
@@ -71,6 +71,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query
 import Ouroboros.Consensus.Storage.ChainDB.Impl.Types
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
+import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.Condense
@@ -399,6 +400,7 @@ garbageCollectBlocks CDB{..} slotNo = do
   VolatileDB.garbageCollect cdbVolatileDB slotNo
   atomically $ do
     modifyTVar cdbInvalid $ fmap $ Map.filter ((>= slotNo) . invalidBlockSlotNo)
+  PerasCertDB.garbageCollect cdbPerasCertDB slotNo
   traceWith cdbTracer $ TraceGCEvent $ PerformedGC slotNo
 
 {-------------------------------------------------------------------------------

From f727c6c4dcb67f044e38748383769598767e48a1 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 17 Jul 2025 12:55:20 +0200
Subject: [PATCH 16/42] Move `PerasWeightSnapshot` to separate module

It makes sense to use this without using an entire PerasCertDB, so decouple
these.

It might be nice to rename PerasCertDB-bench, but doesn't seem like a priority.
---
 .../bench/PerasCertDB-bench/Main.hs           |  8 ++--
 ouroboros-consensus/ouroboros-consensus.cabal |  1 +
 .../Ouroboros/Consensus/Peras/Weight.hs       | 45 +++++++++++++++++++
 .../Consensus/Storage/ChainDB/API.hs          |  2 +-
 .../Consensus/Storage/ChainDB/Impl/Query.hs   |  2 +-
 .../Consensus/Storage/PerasCertDB/API.hs      | 38 +---------------
 .../Consensus/Storage/PerasCertDB/Impl.hs     |  1 +
 .../Ouroboros/Storage/PerasCertDB/Model.hs    |  2 +-
 .../Storage/PerasCertDB/StateMachine.hs       |  3 +-
 9 files changed, 57 insertions(+), 45 deletions(-)
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs

diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
index 99e730c5d6..a72c1800c8 100644
--- a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
+++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
@@ -1,9 +1,9 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE LambdaCase #-}
 
--- | This module contains benchmarks for Peras chain weight calculation as implemented by
---   the by the 'Ouroboros.Consensus.Storage.PerasCertDB.API.boostedWeightForFragment'
---   function.
+-- | This module contains benchmarks for Peras chain weight calculation as
+--   implemented by the by the
+--   'Ouroboros.Consensus.Peras.Weight.boostedWeightForFragment' function.
 --
 --   We benchmark the calculation on a static sequence of chain fragments of increasing
 --   length, ranging from 0 to around 8640, with a sampling rate of 100. The chain fragments
@@ -15,7 +15,7 @@ import Data.List (iterate')
 import Data.Map.Strict qualified as Map
 import Numeric.Natural (Natural)
 import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..))
-import Ouroboros.Consensus.Storage.PerasCertDB.API
+import Ouroboros.Consensus.Peras.Weight
   ( PerasWeightSnapshot (..)
   , boostedWeightForFragment
   )
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index 86ffb09b7e..b51d4b44f9 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -190,6 +190,7 @@ library
     Ouroboros.Consensus.Node.Run
     Ouroboros.Consensus.Node.Serialisation
     Ouroboros.Consensus.NodeId
+    Ouroboros.Consensus.Peras.Weight
     Ouroboros.Consensus.Protocol.Abstract
     Ouroboros.Consensus.Protocol.BFT
     Ouroboros.Consensus.Protocol.LeaderSchedule
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
new file mode 100644
index 0000000000..a6cc93627a
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Ouroboros.Consensus.Peras.Weight
+  ( PerasWeightSnapshot (..)
+  , boostedWeightForPoint
+  , boostedWeightForFragment
+  ) where
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import GHC.Generics (Generic)
+import NoThunks.Class
+import Ouroboros.Consensus.Block
+import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+
+newtype PerasWeightSnapshot blk = PerasWeightSnapshot
+  { getPerasWeightSnapshot :: Map (Point blk) PerasWeight
+  }
+  deriving stock (Show, Eq)
+  deriving Generic
+  deriving newtype NoThunks
+
+boostedWeightForPoint ::
+  forall blk.
+  StandardHash blk =>
+  PerasWeightSnapshot blk -> Point blk -> PerasWeight
+boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt =
+  Map.findWithDefault mempty pt weightByPoint
+
+boostedWeightForFragment ::
+  forall blk.
+  HasHeader blk =>
+  PerasWeightSnapshot blk ->
+  AnchoredFragment blk ->
+  PerasWeight
+boostedWeightForFragment weightSnap frag =
+  -- TODO think about whether this could be done in sublinear complexity
+  foldMap
+    (boostedWeightForPoint weightSnap)
+    (blockPoint <$> AF.toOldestFirst frag)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
index 3631292a7d..ea83c72e7b 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
@@ -83,6 +83,7 @@ import Ouroboros.Consensus.HeaderStateHistory
 import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.Extended
+import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
 import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment
 import Ouroboros.Consensus.Storage.Common
 import Ouroboros.Consensus.Storage.LedgerDB
@@ -90,7 +91,6 @@ import Ouroboros.Consensus.Storage.LedgerDB
   , ReadOnlyForker'
   , Statistics
   )
-import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot)
 import Ouroboros.Consensus.Storage.Serialisation
 import Ouroboros.Consensus.Util.CallStack
 import Ouroboros.Consensus.Util.IOLike
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
index 3fcaf2ab3f..4e5dc818b0 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
@@ -44,6 +44,7 @@ import Ouroboros.Consensus.HeaderStateHistory
 import Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
 import Ouroboros.Consensus.Ledger.Abstract (EmptyMK)
 import Ouroboros.Consensus.Ledger.Extended
+import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( BlockComponent (..)
@@ -54,7 +55,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
 import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
-import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot)
 import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB)
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util (eitherToMaybe)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
index 030393dbbc..f82dd751b6 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
@@ -1,24 +1,15 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Ouroboros.Consensus.Storage.PerasCertDB.API
   ( PerasCertDB (..)
-  , PerasWeightSnapshot (..)
-  , boostedWeightForPoint
-  , boostedWeightForFragment
   ) where
 
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Util.IOLike
-import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
-import qualified Ouroboros.Network.AnchoredFragment as AF
 
 data PerasCertDB m blk = PerasCertDB
   { addCert :: PerasCert blk -> m ()
@@ -28,30 +19,3 @@ data PerasCertDB m blk = PerasCertDB
   , closeDB :: m ()
   }
   deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk)
-
-newtype PerasWeightSnapshot blk = PerasWeightSnapshot
-  { getPerasWeightSnapshot :: Map (Point blk) PerasWeight
-  }
-  deriving stock (Show, Eq)
-  deriving Generic
-  deriving newtype NoThunks
-
-boostedWeightForPoint ::
-  forall blk.
-  StandardHash blk =>
-  PerasWeightSnapshot blk -> Point blk -> PerasWeight
-boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt =
-  Map.findWithDefault mempty pt weightByPoint
-
-boostedWeightForFragment ::
-  forall blk.
-  HasHeader blk =>
-  PerasWeightSnapshot blk ->
-  AnchoredFragment blk ->
-  PerasWeight
-boostedWeightForFragment weightSnap frag =
-  -- TODO think about whether this could be done in sublinear complexity
-  -- probably should write microbenchmarks at some point to see if this is a bottleneck
-  foldMap
-    (boostedWeightForPoint weightSnap)
-    (blockPoint <$> AF.toOldestFirst frag)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
index ae35b03f67..5c76c8fd0a 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
@@ -29,6 +29,7 @@ import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Storage.PerasCertDB.API
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.CallStack
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
index 6b28875a2b..63eeb91fdd 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
@@ -19,7 +19,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import GHC.Generics (Generic)
 import Ouroboros.Consensus.Block
-import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot (..))
+import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot (..))
 
 data Model blk = Model
   { certs :: Set (PerasCert blk)
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
index 516883fcba..6748f5ea2c 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -18,8 +18,9 @@ import Control.Monad.State
 import Control.Tracer (nullTracer)
 import qualified Data.List.NonEmpty as NE
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
 import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
-import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB, PerasWeightSnapshot)
+import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB)
 import Ouroboros.Consensus.Util.IOLike
 import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model
 import Test.QuickCheck hiding (Some (..))

From 9231e680737d6e0ca5f7ee9a88da35b23ca4aca1 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 21 Jul 2025 11:58:09 +0200
Subject: [PATCH 17/42] PerasCertDB.getWeightSnapshot: add `Fingerprint`

---
 .../Consensus/Storage/ChainDB/API.hs          |  2 +-
 .../Consensus/Storage/ChainDB/Impl/Query.hs   |  3 +-
 .../Consensus/Storage/PerasCertDB/API.hs      | 10 +++-
 .../Consensus/Storage/PerasCertDB/Impl.hs     | 50 ++++++++++++-------
 .../Storage/PerasCertDB/StateMachine.hs       |  3 +-
 5 files changed, 45 insertions(+), 23 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
index ea83c72e7b..e76fa7069c 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
@@ -389,7 +389,7 @@ data ChainDB m blk = ChainDB
   -- in the tables.
   , addPerasCert :: PerasCert blk -> m ()
   -- ^ TODO
-  , getPerasWeightSnapshot :: STM m (PerasWeightSnapshot blk)
+  , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
   -- ^ TODO
   , closeDB :: m ()
   -- ^ Close the ChainDB
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
index 4e5dc818b0..37838d7c44 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
@@ -265,7 +265,8 @@ getReadOnlyForkerAtPoint CDB{..} = LedgerDB.getReadOnlyForker cdbLedgerDB
 getStatistics :: IOLike m => ChainDbEnv m blk -> m (Maybe LedgerDB.Statistics)
 getStatistics CDB{..} = LedgerDB.getTipStatistics cdbLedgerDB
 
-getPerasWeightSnapshot :: ChainDbEnv m blk -> STM m (PerasWeightSnapshot blk)
+getPerasWeightSnapshot ::
+  ChainDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk))
 getPerasWeightSnapshot CDB{..} = PerasCertDB.getWeightSnapshot cdbPerasCertDB
 
 {-------------------------------------------------------------------------------
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
index f82dd751b6..4f2bb46140 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
@@ -10,10 +10,18 @@ import NoThunks.Class
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Consensus.Util.STM (WithFingerprint (..))
 
 data PerasCertDB m blk = PerasCertDB
   { addCert :: PerasCert blk -> m ()
-  , getWeightSnapshot :: STM m (PerasWeightSnapshot blk)
+  , getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
+  -- ^ Return the Peras weights in order compare the current selection against
+  -- potential candidate chains, namely the weights for blocks not older than
+  -- the current immutable tip. It might contain weights for even older blocks
+  -- if they have not yet been garbage-collected.
+  --
+  -- The 'Fingerprint' is updated every time a new certificate is added, but it
+  -- stays the same when certificates are garbage-collected.
   , garbageCollect :: SlotNo -> m ()
   -- ^ Garbage-collect state older than the given slot number.
   , closeDB :: m ()
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
index 5c76c8fd0a..0fdffc85d0 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
@@ -34,6 +34,7 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.CallStack
 import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Consensus.Util.STM
 
 {------------------------------------------------------------------------------
   Opening the database
@@ -92,7 +93,7 @@ data PerasCertDbState m blk
 
 data PerasCertDbEnv m blk = PerasCertDbEnv
   { pcdbTracer :: !(Tracer m (TraceEvent blk))
-  , pcdbVolatileState :: !(StrictTVar m (PerasVolatileCertState blk))
+  , pcdbVolatileState :: !(StrictTVar m (WithFingerprint (PerasVolatileCertState blk)))
   -- ^ The 'RoundNo's of all certificates currently in the db.
   }
   deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDbEnv" (PerasCertDbEnv m blk)
@@ -148,20 +149,27 @@ implAddCert ::
 implAddCert env cert = do
   traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt
   join $ atomically $ do
-    PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} <- readTVar pcdbVolatileState
+    WithFingerprint
+      PerasVolatileCertState
+        { pvcsCerts
+        , pvcsWeightByPoint
+        }
+      fp <-
+      readTVar pcdbVolatileState
     if Map.member roundNo pvcsCerts
       then do
         pure $ traceWith pcdbTracer $ IgnoredCertAlreadyInDB roundNo boostedPt
       else do
-        writeTVar
-          pcdbVolatileState
-          PerasVolatileCertState
-            { pvcsCerts =
-                Map.insert roundNo cert pvcsCerts
-            , -- Note that the same block might be boosted by multiple points.
-              pvcsWeightByPoint =
-                Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint
-            }
+        writeTVar pcdbVolatileState $
+          WithFingerprint
+            PerasVolatileCertState
+              { pvcsCerts =
+                  Map.insert roundNo cert pvcsCerts
+              , -- Note that the same block might be boosted by multiple points.
+                pvcsWeightByPoint =
+                  Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint
+              }
+            (succ fp)
         pure $ traceWith pcdbTracer $ AddedPerasCert roundNo boostedPt
  where
   PerasCertDbEnv
@@ -174,16 +182,18 @@ implAddCert env cert = do
 
 implGetWeightSnapshot ::
   IOLike m =>
-  PerasCertDbEnv m blk -> STM m (PerasWeightSnapshot blk)
+  PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk))
 implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} =
-  PerasWeightSnapshot . pvcsWeightByPoint <$> readTVar pcdbVolatileState
+  fmap (PerasWeightSnapshot . pvcsWeightByPoint) <$> readTVar pcdbVolatileState
 
 implGarbageCollect ::
   forall m blk.
   (IOLike m, StandardHash blk) =>
   PerasCertDbEnv m blk -> SlotNo -> m ()
 implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
-  atomically $ modifyTVar pcdbVolatileState gc
+  -- No need to update the 'Fingerprint' as we only remove certificates that do
+  -- not matter for comparing interesting chains.
+  atomically $ modifyTVar pcdbVolatileState (fmap gc)
  where
   gc :: PerasVolatileCertState blk -> PerasVolatileCertState blk
   gc PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} =
@@ -235,12 +245,14 @@ data PerasVolatileCertState blk = PerasVolatileCertState
   deriving stock (Show, Generic)
   deriving anyclass NoThunks
 
-initialPerasVolatileCertState :: PerasVolatileCertState blk
+initialPerasVolatileCertState :: WithFingerprint (PerasVolatileCertState blk)
 initialPerasVolatileCertState =
-  PerasVolatileCertState
-    { pvcsCerts = Map.empty
-    , pvcsWeightByPoint = Map.empty
-    }
+  WithFingerprint
+    PerasVolatileCertState
+      { pvcsCerts = Map.empty
+      , pvcsWeightByPoint = Map.empty
+      }
+    (Fingerprint 0)
 
 {-------------------------------------------------------------------------------
   Trace types
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
index 6748f5ea2c..5a36d8795f 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -22,6 +22,7 @@ import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
 import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
 import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB)
 import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Consensus.Util.STM
 import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model
 import Test.QuickCheck hiding (Some (..))
 import qualified Test.QuickCheck.Monadic as QC
@@ -118,7 +119,7 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where
       lift $ PerasCertDB.addCert perasCertDB cert
     GetWeightSnapshot -> do
       perasCertDB <- get
-      lift $ atomically $ PerasCertDB.getWeightSnapshot perasCertDB
+      lift $ atomically $ forgetFingerprint <$> PerasCertDB.getWeightSnapshot perasCertDB
     GarbageCollect slot -> do
       perasCertDB <- get
       lift $ PerasCertDB.garbageCollect perasCertDB slot

From 395381dd490cde1d4b9ad5eaba1558b62c038051 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 21 Jul 2025 13:52:30 +0200
Subject: [PATCH 18/42] PerasCertDB.addCert: return whether we added the cert

---
 .../Ouroboros/Consensus/Storage/ChainDB/Impl.hs    |  2 +-
 .../Ouroboros/Consensus/Storage/PerasCertDB/API.hs |  6 +++++-
 .../Consensus/Storage/PerasCertDB/Impl.hs          | 14 ++++++++------
 .../Ouroboros/Storage/PerasCertDB/StateMachine.hs  | 11 +++++++++--
 4 files changed, 23 insertions(+), 10 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index f1db247f96..94575db258 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -285,7 +285,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , getReadOnlyForkerAtPoint = getEnv2 h Query.getReadOnlyForkerAtPoint
             , getStatistics = getEnv h Query.getStatistics
             , addPerasCert = getEnv1 h $ \cdb@CDB{..} cert -> do
-                PerasCertDB.addCert cdbPerasCertDB cert
+                _ <- PerasCertDB.addCert cdbPerasCertDB cert
                 -- TODO trigger chain selection in a more efficient way
                 waitChainSelectionPromise =<< ChainSel.triggerChainSelectionAsync cdb
             , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
index 4f2bb46140..18d50c82a7 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
@@ -4,6 +4,7 @@
 
 module Ouroboros.Consensus.Storage.PerasCertDB.API
   ( PerasCertDB (..)
+  , AddPerasCertResult (..)
   ) where
 
 import NoThunks.Class
@@ -13,7 +14,7 @@ import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.STM (WithFingerprint (..))
 
 data PerasCertDB m blk = PerasCertDB
-  { addCert :: PerasCert blk -> m ()
+  { addCert :: PerasCert blk -> m AddPerasCertResult
   , getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
   -- ^ Return the Peras weights in order compare the current selection against
   -- potential candidate chains, namely the weights for blocks not older than
@@ -27,3 +28,6 @@ data PerasCertDB m blk = PerasCertDB
   , closeDB :: m ()
   }
   deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk)
+
+data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB
+  deriving stock (Show, Eq)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
index 0fdffc85d0..4c455ddfcb 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
@@ -20,7 +20,6 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl
   , PerasCertDbError (..)
   ) where
 
-import Control.Monad (join)
 import Control.Tracer (Tracer, nullTracer, traceWith)
 import Data.Kind (Type)
 import qualified Data.Map.Merge.Strict as Map
@@ -145,10 +144,10 @@ implAddCert ::
   ) =>
   PerasCertDbEnv m blk ->
   PerasCert blk ->
-  m ()
+  m AddPerasCertResult
 implAddCert env cert = do
   traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt
-  join $ atomically $ do
+  res <- atomically $ do
     WithFingerprint
       PerasVolatileCertState
         { pvcsCerts
@@ -157,8 +156,7 @@ implAddCert env cert = do
       fp <-
       readTVar pcdbVolatileState
     if Map.member roundNo pvcsCerts
-      then do
-        pure $ traceWith pcdbTracer $ IgnoredCertAlreadyInDB roundNo boostedPt
+      then pure PerasCertAlreadyInDB
       else do
         writeTVar pcdbVolatileState $
           WithFingerprint
@@ -170,7 +168,11 @@ implAddCert env cert = do
                   Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint
               }
             (succ fp)
-        pure $ traceWith pcdbTracer $ AddedPerasCert roundNo boostedPt
+        pure AddedPerasCertToDB
+  traceWith pcdbTracer $ case res of
+    AddedPerasCertToDB -> AddedPerasCert roundNo boostedPt
+    PerasCertAlreadyInDB -> IgnoredCertAlreadyInDB roundNo boostedPt
+  pure res
  where
   PerasCertDbEnv
     { pcdbTracer
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
index 5a36d8795f..917c96eef6 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -17,10 +17,11 @@ module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where
 import Control.Monad.State
 import Control.Tracer (nullTracer)
 import qualified Data.List.NonEmpty as NE
+import qualified Data.Set as Set
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
 import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB
-import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB)
+import Ouroboros.Consensus.Storage.PerasCertDB.API (AddPerasCertResult (..), PerasCertDB)
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.STM
 import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model
@@ -51,7 +52,7 @@ instance StateModel Model where
   data Action Model a where
     OpenDB :: Action Model ()
     CloseDB :: Action Model ()
-    AddCert :: PerasCert TestBlock -> Action Model ()
+    AddCert :: PerasCert TestBlock -> Action Model AddPerasCertResult
     GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock)
     GarbageCollect :: SlotNo -> Action Model ()
 
@@ -124,6 +125,12 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where
       perasCertDB <- get
       lift $ PerasCertDB.garbageCollect perasCertDB slot
 
+  postcondition (Model model, _) (AddCert cert) _ actual = do
+    let expected
+          | cert `Set.member` model.certs = PerasCertAlreadyInDB
+          | otherwise = AddedPerasCertToDB
+    counterexamplePost $ show expected <> " /= " <> show actual
+    pure $ expected == actual
   postcondition (Model model, _) GetWeightSnapshot _ actual = do
     let expected = Model.getWeightSnapshot model
     counterexamplePost $ "Model: " <> show expected

From 04f48fb8eb1949ad2ea6687948470df95ccbe249 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Wed, 23 Jul 2025 23:35:37 +0200
Subject: [PATCH 19/42] Peras: minor tweaks

---
 .../Ouroboros/Consensus/Block/SupportsPeras.hs           | 5 ++---
 .../Ouroboros/Consensus/Peras/Weight.hs                  | 9 +++++----
 2 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
index d55a9cd214..5cdd95c992 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
@@ -23,12 +23,11 @@ import NoThunks.Class
 import Ouroboros.Consensus.Block.Abstract
 
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
-  deriving stock Show
-  deriving Generic
+  deriving stock (Show, Generic)
   deriving newtype (Eq, Ord, NoThunks)
 
 newtype PerasWeight = PerasWeight {unPerasWeight :: Word64}
-  deriving stock Show
+  deriving stock (Show, Generic)
   deriving newtype (Eq, Ord, NoThunks)
   deriving (Semigroup, Monoid) via Sum Word64
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
index a6cc93627a..1931bd5cea 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Ouroboros.Consensus.Peras.Weight
   ( PerasWeightSnapshot (..)
@@ -33,13 +34,13 @@ boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt =
   Map.findWithDefault mempty pt weightByPoint
 
 boostedWeightForFragment ::
-  forall blk.
-  HasHeader blk =>
+  forall blk h.
+  (HasHeader blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
   PerasWeightSnapshot blk ->
-  AnchoredFragment blk ->
+  AnchoredFragment h ->
   PerasWeight
 boostedWeightForFragment weightSnap frag =
   -- TODO think about whether this could be done in sublinear complexity
   foldMap
     (boostedWeightForPoint weightSnap)
-    (blockPoint <$> AF.toOldestFirst frag)
+    (castPoint . blockPoint <$> AF.toOldestFirst frag)

From f919246d0d420aa97b67cea7e9bf0891fdc0d775 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 24 Jul 2025 14:31:31 +0200
Subject: [PATCH 20/42] Make `PerasWeightSnapshot` opaque

---
 .../bench/PerasCertDB-bench/Main.hs           |  6 +--
 ouroboros-consensus/ouroboros-consensus.cabal |  1 -
 .../Ouroboros/Consensus/Peras/Weight.hs       | 47 ++++++++++++++++++-
 .../Consensus/Storage/PerasCertDB/Impl.hs     | 38 +++++----------
 .../Ouroboros/Storage/PerasCertDB/Model.hs    | 19 +++-----
 5 files changed, 69 insertions(+), 42 deletions(-)

diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
index a72c1800c8..94d0bdd408 100644
--- a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
+++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
@@ -12,12 +12,12 @@
 module Main (main) where
 
 import Data.List (iterate')
-import Data.Map.Strict qualified as Map
 import Numeric.Natural (Natural)
 import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..))
 import Ouroboros.Consensus.Peras.Weight
-  ( PerasWeightSnapshot (..)
+  ( PerasWeightSnapshot
   , boostedWeightForFragment
+  , mkPerasWeightSnapshot
   )
 import Ouroboros.Network.AnchoredFragment qualified as AF
 import Test.Ouroboros.Storage.TestBlock (TestBlock (..), TestBody (..), TestHeader (..))
@@ -96,7 +96,7 @@ uniformWeightSnapshot fragment =
           . AF.toOldestFirst
           $ fragment
       weights = repeat (boostWeight benchmarkParams)
-   in PerasWeightSnapshot{getPerasWeightSnapshot = Map.fromList $ zip pointsToBoost weights}
+   in mkPerasWeightSnapshot $ pointsToBoost `zip` weights
 
 getEveryN :: Natural -> [(Natural, a)] -> [(Natural, a)]
 getEveryN n = filter (\(i, _) -> (i `mod` n) == 0)
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index b51d4b44f9..d8476cd1a3 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -833,7 +833,6 @@ benchmark PerasCertDB-bench
   other-modules:
   build-depends:
     base,
-    containers,
     ouroboros-consensus,
     ouroboros-network-api,
     tasty-bench,
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
index 1931bd5cea..ad53914bc2 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -6,11 +6,18 @@
 {-# LANGUAGE TypeOperators #-}
 
 module Ouroboros.Consensus.Peras.Weight
-  ( PerasWeightSnapshot (..)
+  ( -- * 'PerasWeightSnapshot'
+    PerasWeightSnapshot
+  , emptyPerasWeightSnapshot
+  , mkPerasWeightSnapshot
+  , perasWeightSnapshotToList
+  , addToPerasWeightSnapshot
+  , removeFromPerasWeightSnapshot
   , boostedWeightForPoint
   , boostedWeightForFragment
   ) where
 
+import Data.Foldable as Foldable (foldl')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
@@ -26,6 +33,44 @@ newtype PerasWeightSnapshot blk = PerasWeightSnapshot
   deriving Generic
   deriving newtype NoThunks
 
+emptyPerasWeightSnapshot :: PerasWeightSnapshot blk
+emptyPerasWeightSnapshot = PerasWeightSnapshot Map.empty
+
+mkPerasWeightSnapshot ::
+  StandardHash blk =>
+  [(Point blk, PerasWeight)] ->
+  PerasWeightSnapshot blk
+mkPerasWeightSnapshot =
+  Foldable.foldl'
+    (\s (pt, weight) -> addToPerasWeightSnapshot pt weight s)
+    emptyPerasWeightSnapshot
+
+perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)]
+perasWeightSnapshotToList = Map.toList . getPerasWeightSnapshot
+
+addToPerasWeightSnapshot ::
+  StandardHash blk =>
+  Point blk ->
+  PerasWeight ->
+  PerasWeightSnapshot blk ->
+  PerasWeightSnapshot blk
+addToPerasWeightSnapshot pt weight =
+  PerasWeightSnapshot . Map.insertWith (<>) pt weight . getPerasWeightSnapshot
+
+removeFromPerasWeightSnapshot ::
+  StandardHash blk =>
+  Point blk ->
+  PerasWeight ->
+  PerasWeightSnapshot blk ->
+  PerasWeightSnapshot blk
+removeFromPerasWeightSnapshot pt (PerasWeight weight) =
+  PerasWeightSnapshot . Map.update subtractWeight pt . getPerasWeightSnapshot
+ where
+  subtractWeight :: PerasWeight -> Maybe PerasWeight
+  subtractWeight (PerasWeight w)
+    | w > weight = Just $ PerasWeight (w - weight)
+    | otherwise = Nothing
+
 boostedWeightForPoint ::
   forall blk.
   StandardHash blk =>
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
index 4c455ddfcb..4471c6bd53 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
@@ -21,8 +21,8 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl
   ) where
 
 import Control.Tracer (Tracer, nullTracer, traceWith)
+import Data.Foldable as Foldable (foldl')
 import Data.Kind (Type)
-import qualified Data.Map.Merge.Strict as Map
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
@@ -165,7 +165,7 @@ implAddCert env cert = do
                   Map.insert roundNo cert pvcsCerts
               , -- Note that the same block might be boosted by multiple points.
                 pvcsWeightByPoint =
-                  Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint
+                  addToPerasWeightSnapshot boostedPt boostPerCert pvcsWeightByPoint
               }
             (succ fp)
         pure AddedPerasCertToDB
@@ -186,7 +186,7 @@ implGetWeightSnapshot ::
   IOLike m =>
   PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk))
 implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} =
-  fmap (PerasWeightSnapshot . pvcsWeightByPoint) <$> readTVar pcdbVolatileState
+  fmap pvcsWeightByPoint <$> readTVar pcdbVolatileState
 
 implGarbageCollect ::
   forall m blk.
@@ -202,33 +202,21 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
     PerasVolatileCertState
       { pvcsCerts = certsToKeep
       , pvcsWeightByPoint =
-          Map.merge
-            -- Do not touch weight of boosted blocks that we do not subtract any
-            -- weight from.
-            Map.preserveMissing
-            -- Irrelevant, the key set of @weightToRemove@ is a subset of the
-            -- key set of @pvcsWeightByPoint@.
-            Map.dropMissing
-            (Map.zipWithMaybeMatched $ \_pt -> subtractWeight)
+          Foldable.foldl'
+            ( \s cert ->
+                removeFromPerasWeightSnapshot
+                  (perasCertBoostedBlock cert)
+                  boostPerCert
+                  s
+            )
             pvcsWeightByPoint
-            weightToRemove
+            certsToRemove
       }
    where
     (certsToRemove, certsToKeep) =
       Map.partition isTooOld pvcsCerts
     isTooOld cert =
       pointSlot (perasCertBoostedBlock cert) < NotOrigin slot
-    weightToRemove =
-      Map.fromListWith
-        (<>)
-        [ (perasCertBoostedBlock cert, boostPerCert)
-        | cert <- Map.elems certsToRemove
-        ]
-
-  subtractWeight :: PerasWeight -> PerasWeight -> Maybe PerasWeight
-  subtractWeight (PerasWeight w1) (PerasWeight w2)
-    | w1 > w2 = Just $ PerasWeight (w1 - w2)
-    | otherwise = Nothing
 
 {-------------------------------------------------------------------------------
   Implementation-internal types
@@ -239,7 +227,7 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
 data PerasVolatileCertState blk = PerasVolatileCertState
   { pvcsCerts :: !(Map PerasRoundNo (PerasCert blk))
   -- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db.
-  , pvcsWeightByPoint :: !(Map (Point blk) PerasWeight)
+  , pvcsWeightByPoint :: !(PerasWeightSnapshot blk)
   -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db.
   --
   -- INVARIANT: In sync with 'pvcsCerts'.
@@ -252,7 +240,7 @@ initialPerasVolatileCertState =
   WithFingerprint
     PerasVolatileCertState
       { pvcsCerts = Map.empty
-      , pvcsWeightByPoint = Map.empty
+      , pvcsWeightByPoint = emptyPerasWeightSnapshot
       }
     (Fingerprint 0)
 
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
index 63eeb91fdd..a1cda0e044 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
@@ -14,12 +14,14 @@ module Test.Ouroboros.Storage.PerasCertDB.Model
   , garbageCollect
   ) where
 
-import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import GHC.Generics (Generic)
 import Ouroboros.Consensus.Block
-import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot (..))
+import Ouroboros.Consensus.Peras.Weight
+  ( PerasWeightSnapshot
+  , mkPerasWeightSnapshot
+  )
 
 data Model blk = Model
   { certs :: Set (PerasCert blk)
@@ -47,16 +49,9 @@ addCert model@Model{certs} cert =
 getWeightSnapshot ::
   StandardHash blk =>
   Model blk -> PerasWeightSnapshot blk
-getWeightSnapshot Model{certs} = snap
- where
-  snap =
-    PerasWeightSnapshot
-      { getPerasWeightSnapshot =
-          Set.fold
-            (\cert acc -> Map.insertWith (<>) (perasCertBoostedBlock cert) boostPerCert acc)
-            Map.empty
-            certs
-      }
+getWeightSnapshot Model{certs} =
+  mkPerasWeightSnapshot
+    [(perasCertBoostedBlock cert, boostPerCert) | cert <- Set.toList certs]
 
 garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk
 garbageCollect slot model@Model{certs} =

From bee6981ba994c8c1175eb9a8b83818cf545d24cc Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 13:36:45 +0200
Subject: [PATCH 21/42] Nomenclature: "weight boost" instead of "boosted
 weight"

---
 .../bench/PerasCertDB-bench/Main.hs              | 14 +++++++-------
 .../Ouroboros/Consensus/Peras/Weight.hs          | 16 ++++++++--------
 2 files changed, 15 insertions(+), 15 deletions(-)

diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
index 94d0bdd408..40642021d4 100644
--- a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
+++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
@@ -3,7 +3,7 @@
 
 -- | This module contains benchmarks for Peras chain weight calculation as
 --   implemented by the by the
---   'Ouroboros.Consensus.Peras.Weight.boostedWeightForFragment' function.
+--   'Ouroboros.Consensus.Peras.Weight.weightBoostOfFragment' function.
 --
 --   We benchmark the calculation on a static sequence of chain fragments of increasing
 --   length, ranging from 0 to around 8640, with a sampling rate of 100. The chain fragments
@@ -16,8 +16,8 @@ import Numeric.Natural (Natural)
 import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..))
 import Ouroboros.Consensus.Peras.Weight
   ( PerasWeightSnapshot
-  , boostedWeightForFragment
   , mkPerasWeightSnapshot
+  , weightBoostOfFragment
   )
 import Ouroboros.Network.AnchoredFragment qualified as AF
 import Test.Ouroboros.Storage.TestBlock (TestBlock (..), TestBody (..), TestHeader (..))
@@ -49,7 +49,7 @@ benchmarkParams =
 
 main :: IO ()
 main =
-  Test.Tasty.Bench.defaultMain $ map benchBoostedWeightForFragment inputs
+  Test.Tasty.Bench.defaultMain $ map benchWeightBoostOfFragment inputs
  where
   -- NOTE: we do not use the 'env' combinator to set up the test data since
   --       it requires 'NFData' for 'AF.AnchoredFragment'. While the necessary
@@ -62,11 +62,11 @@ main =
         zip [0 ..] $
           zip (map uniformWeightSnapshot fragments) fragments
 
-benchBoostedWeightForFragment ::
+benchWeightBoostOfFragment ::
   (Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock)) -> Benchmark
-benchBoostedWeightForFragment (i, (weightSnapshot, fragment)) =
-  bench ("boostedWeightForFragment of length " <> show i) $
-    whnf (boostedWeightForFragment weightSnapshot) fragment
+benchWeightBoostOfFragment (i, (weightSnapshot, fragment)) =
+  bench ("weightBoostOfFragment of length " <> show i) $
+    whnf (weightBoostOfFragment weightSnapshot) fragment
 
 -- | An infinite list of chain fragments
 fragments :: [AF.AnchoredFragment TestBlock]
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
index ad53914bc2..7895f91ff9 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -13,8 +13,8 @@ module Ouroboros.Consensus.Peras.Weight
   , perasWeightSnapshotToList
   , addToPerasWeightSnapshot
   , removeFromPerasWeightSnapshot
-  , boostedWeightForPoint
-  , boostedWeightForFragment
+  , weightBoostOfPoint
+  , weightBoostOfFragment
   ) where
 
 import Data.Foldable as Foldable (foldl')
@@ -71,21 +71,21 @@ removeFromPerasWeightSnapshot pt (PerasWeight weight) =
     | w > weight = Just $ PerasWeight (w - weight)
     | otherwise = Nothing
 
-boostedWeightForPoint ::
+weightBoostOfPoint ::
   forall blk.
   StandardHash blk =>
   PerasWeightSnapshot blk -> Point blk -> PerasWeight
-boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt =
+weightBoostOfPoint (PerasWeightSnapshot weightByPoint) pt =
   Map.findWithDefault mempty pt weightByPoint
 
-boostedWeightForFragment ::
+weightBoostOfFragment ::
   forall blk h.
   (HasHeader blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
   PerasWeightSnapshot blk ->
   AnchoredFragment h ->
   PerasWeight
-boostedWeightForFragment weightSnap frag =
+weightBoostOfFragment weightSnap frag =
   -- TODO think about whether this could be done in sublinear complexity
   foldMap
-    (boostedWeightForPoint weightSnap)
-    (castPoint . blockPoint <$> AF.toOldestFirst frag)
+    (weightBoostOfPoint weightSnap . castPoint . blockPoint)
+    (AF.toOldestFirst frag)

From a5ad9eda1714495e00e3bf65d84d3ebfa21956ef Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 13:36:48 +0200
Subject: [PATCH 22/42] Glossary: add Peras weight-related terms

---
 docs/website/contents/for-developers/Glossary.md | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/docs/website/contents/for-developers/Glossary.md b/docs/website/contents/for-developers/Glossary.md
index 060436be9b..0191056faf 100644
--- a/docs/website/contents/for-developers/Glossary.md
+++ b/docs/website/contents/for-developers/Glossary.md
@@ -473,6 +473,19 @@ These kinds are maintained by the Networking layer:
 - [Public root peers](#public-root-peers).
 - [Shared peers](#shared-peers).
 
+## ;Peras ;weight ;boost
+
+Peras is an extension of Praos enabling faster settlement under optimistic conditions.
+To this end, Peras can result in a block `B` receiving a *boost*, which means that any chain containing `B` gets additional weight when being compared to other chains.
+
+Consider a chain fragment `F`:
+
+- Its ;*weight boost* is the sum of all boosts received by points on this fragment (excluding the anchor). Note that the same point can be boosted multiple times.
+
+- Its ;*total weight* is its tip block number plus its weight boost.
+
+Note that these notions are always relative to a particular anchor, so different chain fragments must have the same anchor when their total weight is to be compared.
+
 ## ;Phases
 
 Byron, Shelley, Goguen (current one as of August 2023), Basho, Voltaire.

From 1cfcd954628ae4f62f509eb440037d91d137c121 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 13:36:51 +0200
Subject: [PATCH 23/42] PerasWeightSnapshot: minimize API

---
 .../Ouroboros/Consensus/Peras/Weight.hs        | 18 +++++++-----------
 .../Consensus/Storage/PerasCertDB/Impl.hs      | 14 ++------------
 2 files changed, 9 insertions(+), 23 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
index 7895f91ff9..2711a779f5 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -12,7 +12,7 @@ module Ouroboros.Consensus.Peras.Weight
   , mkPerasWeightSnapshot
   , perasWeightSnapshotToList
   , addToPerasWeightSnapshot
-  , removeFromPerasWeightSnapshot
+  , prunePerasWeightSnapshot
   , weightBoostOfPoint
   , weightBoostOfFragment
   ) where
@@ -57,19 +57,15 @@ addToPerasWeightSnapshot ::
 addToPerasWeightSnapshot pt weight =
   PerasWeightSnapshot . Map.insertWith (<>) pt weight . getPerasWeightSnapshot
 
-removeFromPerasWeightSnapshot ::
-  StandardHash blk =>
-  Point blk ->
-  PerasWeight ->
+prunePerasWeightSnapshot ::
+  SlotNo ->
   PerasWeightSnapshot blk ->
   PerasWeightSnapshot blk
-removeFromPerasWeightSnapshot pt (PerasWeight weight) =
-  PerasWeightSnapshot . Map.update subtractWeight pt . getPerasWeightSnapshot
+prunePerasWeightSnapshot slot =
+  PerasWeightSnapshot . Map.dropWhileAntitone isTooOld . getPerasWeightSnapshot
  where
-  subtractWeight :: PerasWeight -> Maybe PerasWeight
-  subtractWeight (PerasWeight w)
-    | w > weight = Just $ PerasWeight (w - weight)
-    | otherwise = Nothing
+  isTooOld :: Point blk -> Bool
+  isTooOld pt = pointSlot pt < NotOrigin slot
 
 weightBoostOfPoint ::
   forall blk.
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
index 4471c6bd53..6547afa521 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
@@ -21,7 +21,6 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl
   ) where
 
 import Control.Tracer (Tracer, nullTracer, traceWith)
-import Data.Foldable as Foldable (foldl')
 import Data.Kind (Type)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -201,19 +200,10 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
   gc PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} =
     PerasVolatileCertState
       { pvcsCerts = certsToKeep
-      , pvcsWeightByPoint =
-          Foldable.foldl'
-            ( \s cert ->
-                removeFromPerasWeightSnapshot
-                  (perasCertBoostedBlock cert)
-                  boostPerCert
-                  s
-            )
-            pvcsWeightByPoint
-            certsToRemove
+      , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint
       }
    where
-    (certsToRemove, certsToKeep) =
+    (_, certsToKeep) =
       Map.partition isTooOld pvcsCerts
     isTooOld cert =
       pointSlot (perasCertBoostedBlock cert) < NotOrigin slot

From 0a217b9d682bfd6b227b1b5d1b2bc3bf735ab97b Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 13:36:54 +0200
Subject: [PATCH 24/42] PerasRoundNo/PerasWeight: terse output

---
 .../Ouroboros/Consensus/Block/SupportsPeras.hs             | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
index 5cdd95c992..e2d559d9c3 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
@@ -21,13 +21,16 @@ import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block.Abstract
+import Quiet (Quiet (..))
 
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
-  deriving stock (Show, Generic)
+  deriving Show via Quiet PerasRoundNo
+  deriving stock Generic
   deriving newtype (Eq, Ord, NoThunks)
 
 newtype PerasWeight = PerasWeight {unPerasWeight :: Word64}
-  deriving stock (Show, Generic)
+  deriving Show via Quiet PerasWeight
+  deriving stock Generic
   deriving newtype (Eq, Ord, NoThunks)
   deriving (Semigroup, Monoid) via Sum Word64
 

From e975d0dd0c39872f89eb6c061c5a109cf143b253 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 13:36:57 +0200
Subject: [PATCH 25/42] O.C.Peras.Weight: add haddocks

using cabal-docspec (not yet nixified)
---
 .../Ouroboros/Consensus/Peras/Weight.hs       | 167 +++++++++++++++++-
 1 file changed, 163 insertions(+), 4 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
index 2711a779f5..baa72875a3 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -5,14 +5,25 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
 
+-- | Data structure for tracking the weight of blocks due to Peras boosts.
 module Ouroboros.Consensus.Peras.Weight
-  ( -- * 'PerasWeightSnapshot'
+  ( -- * 'PerasWeightSnapshot' type
     PerasWeightSnapshot
+
+    -- * Construction
   , emptyPerasWeightSnapshot
   , mkPerasWeightSnapshot
+
+    -- * Conversion
   , perasWeightSnapshotToList
+
+    -- * Insertion
   , addToPerasWeightSnapshot
+
+    -- * Pruning
   , prunePerasWeightSnapshot
+
+    -- * Query
   , weightBoostOfPoint
   , weightBoostOfFragment
   ) where
@@ -26,16 +37,37 @@ import Ouroboros.Consensus.Block
 import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 
+-- | Data structure for tracking the weight of blocks due to Peras boosts.
 newtype PerasWeightSnapshot blk = PerasWeightSnapshot
   { getPerasWeightSnapshot :: Map (Point blk) PerasWeight
   }
-  deriving stock (Show, Eq)
+  deriving stock Eq
   deriving Generic
   deriving newtype NoThunks
 
+instance StandardHash blk => Show (PerasWeightSnapshot blk) where
+  show = show . perasWeightSnapshotToList
+
+-- | An empty 'PerasWeightSnapshot' not containing any boosted blocks.
 emptyPerasWeightSnapshot :: PerasWeightSnapshot blk
 emptyPerasWeightSnapshot = PerasWeightSnapshot Map.empty
 
+-- | Create a weight snapshot from a list of boosted points with an associated
+-- weight. In case of duplicate points, their weights are combined.
+--
+-- >>> :{
+-- weights :: [(Point Blk, PerasWeight)]
+-- weights =
+--   [ (BlockPoint 2 "foo", PerasWeight 2)
+--   , (GenesisPoint,       PerasWeight 3)
+--   , (BlockPoint 3 "bar", PerasWeight 2)
+--   , (BlockPoint 2 "foo", PerasWeight 2)
+--   ]
+-- :}
+--
+-- >>> snap = mkPerasWeightSnapshot weights
+-- >>> snap
+-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
 mkPerasWeightSnapshot ::
   StandardHash blk =>
   [(Point blk, PerasWeight)] ->
@@ -45,9 +77,47 @@ mkPerasWeightSnapshot =
     (\s (pt, weight) -> addToPerasWeightSnapshot pt weight s)
     emptyPerasWeightSnapshot
 
+-- | Return the list of boosted points with their associated weight, sorted
+-- based on their point. Does not contain duplicate points.
+--
+-- >>> :{
+-- weights :: [(Point Blk, PerasWeight)]
+-- weights =
+--   [ (BlockPoint 2 "foo", PerasWeight 2)
+--   , (GenesisPoint,       PerasWeight 3)
+--   , (BlockPoint 3 "bar", PerasWeight 2)
+--   , (BlockPoint 2 "foo", PerasWeight 2)
+--   ]
+-- :}
+--
+-- >>> snap = mkPerasWeightSnapshot weights
+-- >>> perasWeightSnapshotToList snap
+-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
 perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)]
-perasWeightSnapshotToList = Map.toList . getPerasWeightSnapshot
+perasWeightSnapshotToList = Map.toAscList . getPerasWeightSnapshot
 
+-- | Add weight for the given point to the 'PerasWeightSnapshot'. If the point
+-- already has some weight, it is added on top.
+--
+-- >>> :{
+-- weights :: [(Point Blk, PerasWeight)]
+-- weights =
+--   [ (BlockPoint 2 "foo", PerasWeight 2)
+--   , (GenesisPoint,       PerasWeight 3)
+--   ]
+-- :}
+--
+-- >>> snap0 = mkPerasWeightSnapshot weights
+-- >>> snap0
+-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 2)]
+--
+-- >>> snap1 = addToPerasWeightSnapshot (BlockPoint 3 "bar") (PerasWeight 2) snap0
+-- >>> snap1
+-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 2),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
+--
+-- >>> snap2 = addToPerasWeightSnapshot (BlockPoint 2 "foo") (PerasWeight 2) snap1
+-- >>> snap2
+-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
 addToPerasWeightSnapshot ::
   StandardHash blk =>
   Point blk ->
@@ -57,6 +127,29 @@ addToPerasWeightSnapshot ::
 addToPerasWeightSnapshot pt weight =
   PerasWeightSnapshot . Map.insertWith (<>) pt weight . getPerasWeightSnapshot
 
+-- | Prune the given 'PerasWeightSnapshot' by removing the weight of all blocks
+-- strictly older than the given slot.
+--
+-- This function is used to get garbage-collect boosted blocks blocks which are
+-- older than our immutable tip as we will never adopt a chain containing them.
+--
+-- >>> :{
+-- weights :: [(Point Blk, PerasWeight)]
+-- weights =
+--   [ (BlockPoint 2 "foo", PerasWeight 2)
+--   , (GenesisPoint,       PerasWeight 3)
+--   , (BlockPoint 3 "bar", PerasWeight 2)
+--   , (BlockPoint 2 "foo", PerasWeight 2)
+--   ]
+-- :}
+--
+-- >>> snap = mkPerasWeightSnapshot weights
+--
+-- >>> prunePerasWeightSnapshot (SlotNo 2) snap
+-- [(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
+--
+-- >>> prunePerasWeightSnapshot (SlotNo 3) snap
+-- [(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
 prunePerasWeightSnapshot ::
   SlotNo ->
   PerasWeightSnapshot blk ->
@@ -67,6 +160,25 @@ prunePerasWeightSnapshot slot =
   isTooOld :: Point blk -> Bool
   isTooOld pt = pointSlot pt < NotOrigin slot
 
+-- | Get the weight boost for a point, or @'mempty' :: 'PerasWeight'@ otherwise.
+--
+-- >>> :{
+-- weights :: [(Point Blk, PerasWeight)]
+-- weights =
+--   [ (BlockPoint 2 "foo", PerasWeight 2)
+--   , (GenesisPoint,       PerasWeight 3)
+--   , (BlockPoint 3 "bar", PerasWeight 2)
+--   , (BlockPoint 2 "foo", PerasWeight 2)
+--   ]
+-- :}
+--
+-- >>> snap = mkPerasWeightSnapshot weights
+--
+-- >>> weightBoostOfPoint snap (BlockPoint 2 "foo")
+-- PerasWeight 4
+--
+-- >>> weightBoostOfPoint snap (BlockPoint 2 "baz")
+-- PerasWeight 0
 weightBoostOfPoint ::
   forall blk.
   StandardHash blk =>
@@ -74,9 +186,47 @@ weightBoostOfPoint ::
 weightBoostOfPoint (PerasWeightSnapshot weightByPoint) pt =
   Map.findWithDefault mempty pt weightByPoint
 
+-- | Get the weight boost for a fragment, ie the sum of all
+-- 'weightBoostOfPoint' for all points on the fragment (excluding the anchor).
+--
+-- Note that this quantity is relative to the anchor of the fragment, so it
+-- should only be compared against other fragments with the same anchor.
+--
+-- >>> :{
+-- weights :: [(Point Blk, PerasWeight)]
+-- weights =
+--   [ (BlockPoint 2 "foo", PerasWeight 2)
+--   , (GenesisPoint,       PerasWeight 3)
+--   , (BlockPoint 3 "bar", PerasWeight 2)
+--   , (BlockPoint 2 "foo", PerasWeight 2)
+--   ]
+-- :}
+--
+-- >>> :{
+-- snap = mkPerasWeightSnapshot weights
+-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo"
+-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar"
+-- frag0 :: AnchoredFragment (HeaderFields Blk)
+-- frag0 = Empty AnchorGenesis :> foo :> bar
+-- :}
+--
+-- >>> weightBoostOfFragment snap frag0
+-- PerasWeight 6
+--
+-- Only keeping the last block from @frag0@:
+--
+-- >>> frag1 = AF.anchorNewest 1 frag0
+-- >>> weightBoostOfFragment snap frag1
+-- PerasWeight 2
+--
+-- Dropping the head from @frag0@, and instead adding an unboosted point:
+--
+-- >>> frag2 = AF.dropNewest 1 frag0 :> HeaderFields (SlotNo 4) (BlockNo 2) "baz"
+-- >>> weightBoostOfFragment snap frag2
+-- PerasWeight 4
 weightBoostOfFragment ::
   forall blk h.
-  (HasHeader blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
+  (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
   PerasWeightSnapshot blk ->
   AnchoredFragment h ->
   PerasWeight
@@ -85,3 +235,12 @@ weightBoostOfFragment weightSnap frag =
   foldMap
     (weightBoostOfPoint weightSnap . castPoint . blockPoint)
     (AF.toOldestFirst frag)
+
+-- $setup
+-- >>> import Ouroboros.Consensus.Block
+-- >>> import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq(..), Anchor(..))
+-- >>> import qualified Ouroboros.Network.AnchoredFragment as AF
+-- >>> :set -XTypeFamilies
+-- >>> data Blk = Blk
+-- >>> type instance HeaderHash Blk = String
+-- >>> instance StandardHash Blk

From c1df4829197dcb44f451ec04efeb2411cf0e087f Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 18:37:18 +0200
Subject: [PATCH 26/42] `SecurityParam`: mention weighted nature

---
 .../Consensus/Config/SecurityParam.hs         | 19 +++++++++++++++++--
 1 file changed, 17 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs
index bebe022e8d..2aade1eeb9 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs
@@ -3,24 +3,39 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) where
+module Ouroboros.Consensus.Config.SecurityParam
+  ( SecurityParam (..)
+  , maxRollbackWeight
+  ) where
 
 import Cardano.Binary
 import Cardano.Ledger.BaseTypes.NonZero
 import Data.Word
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
+import Ouroboros.Consensus.Block.SupportsPeras (PerasWeight (..))
 import Quiet
 
 -- | Protocol security parameter
 --
--- We interpret this as the number of rollbacks we support.
+-- In longest-chain protocols, we interpret this as the number of rollbacks we
+-- support.
 --
 -- i.e., k == 1: we can roll back at most one block
 --       k == 2: we can roll back at most two blocks, etc
 --
 -- NOTE: This talks about the number of /blocks/ we can roll back, not
 -- the number of /slots/.
+--
+-- In weightiest-chain protocols (Ouroboros Peras), we interpret this as the
+-- maximum amount of weight we can roll back.
+--
+-- i.e. k == 30: we can roll back at most 30 unweighted blocks, or two blocks
+-- each having additional weight 14.
 newtype SecurityParam = SecurityParam {maxRollbacks :: NonZero Word64}
   deriving (Eq, Generic, NoThunks, ToCBOR, FromCBOR)
   deriving Show via Quiet SecurityParam
+
+-- | The maximum amount of weight we can roll back.
+maxRollbackWeight :: SecurityParam -> PerasWeight
+maxRollbackWeight = PerasWeight . unNonZero . maxRollbacks

From 6b44e97caf51aa11ca579e550f6c5e005099bc62 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Tue, 29 Jul 2025 19:47:10 +0200
Subject: [PATCH 27/42] `PerasRoundNo`/`PerasWeight`: add `Condense` instances

This is purely for concise QuickCheck counterexample output.
---
 .../Ouroboros/Consensus/Block/SupportsPeras.hs             | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
index e2d559d9c3..7709e759cf 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
@@ -21,6 +21,7 @@ import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block.Abstract
+import Ouroboros.Consensus.Util.Condense
 import Quiet (Quiet (..))
 
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
@@ -28,12 +29,18 @@ newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving stock Generic
   deriving newtype (Eq, Ord, NoThunks)
 
+instance Condense PerasRoundNo where
+  condense = show . unPerasRoundNo
+
 newtype PerasWeight = PerasWeight {unPerasWeight :: Word64}
   deriving Show via Quiet PerasWeight
   deriving stock Generic
   deriving newtype (Eq, Ord, NoThunks)
   deriving (Semigroup, Monoid) via Sum Word64
 
+instance Condense PerasWeight where
+  condense = show . unPerasWeight
+
 -- | TODO this will become a Ledger protocol parameter
 boostPerCert :: PerasWeight
 boostPerCert = PerasWeight 15

From 6fd217e0a43c351ab7827f2e3a7f51c768c131dd Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 15:15:35 +0200
Subject: [PATCH 28/42] O.C.Peras.Weight: add
 `totalWeightForFragment`/`takeVolatileSuffix`

---
 .../Ouroboros/Consensus/Peras/Weight.hs       | 135 +++++++++++++++++-
 1 file changed, 134 insertions(+), 1 deletion(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
index baa72875a3..fed6d63844 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -26,14 +26,18 @@ module Ouroboros.Consensus.Peras.Weight
     -- * Query
   , weightBoostOfPoint
   , weightBoostOfFragment
+  , totalWeightOfFragment
+  , takeVolatileSuffix
   ) where
 
 import Data.Foldable as Foldable (foldl')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Config.SecurityParam
 import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 
@@ -236,11 +240,140 @@ weightBoostOfFragment weightSnap frag =
     (weightBoostOfPoint weightSnap . castPoint . blockPoint)
     (AF.toOldestFirst frag)
 
+-- | Get the total weight for a fragment, ie the length plus the weight boost
+-- ('weightBoostOfFragment') of the fragment.
+--
+-- Note that this quantity is relative to the anchor of the fragment, so it
+-- should only be compared against other fragments with the same anchor.
+--
+-- >>> :{
+-- weights :: [(Point Blk, PerasWeight)]
+-- weights =
+--   [ (BlockPoint 2 "foo", PerasWeight 2)
+--   , (GenesisPoint,       PerasWeight 3)
+--   , (BlockPoint 3 "bar", PerasWeight 2)
+--   , (BlockPoint 2 "foo", PerasWeight 2)
+--   ]
+-- :}
+--
+-- >>> :{
+-- snap = mkPerasWeightSnapshot weights
+-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo"
+-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar"
+-- frag0 :: AnchoredFragment (HeaderFields Blk)
+-- frag0 = Empty AnchorGenesis :> foo :> bar
+-- :}
+--
+-- >>> totalWeightOfFragment snap frag0
+-- PerasWeight 8
+--
+-- Only keeping the last block from @frag0@:
+--
+-- >>> frag1 = AF.anchorNewest 1 frag0
+-- >>> totalWeightOfFragment snap frag1
+-- PerasWeight 3
+--
+-- Dropping the head from @frag0@, and instead adding an unboosted point:
+--
+-- >>> frag2 = AF.dropNewest 1 frag0 :> HeaderFields (SlotNo 4) (BlockNo 2) "baz"
+-- >>> totalWeightOfFragment snap frag2
+-- PerasWeight 6
+totalWeightOfFragment ::
+  forall blk h.
+  (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
+  PerasWeightSnapshot blk ->
+  AnchoredFragment h ->
+  PerasWeight
+totalWeightOfFragment weightSnap frag =
+  weightLength <> weightBoost
+ where
+  weightLength = PerasWeight $ fromIntegral $ AF.length frag
+  weightBoost = weightBoostOfFragment weightSnap frag
+
+-- | Take the longest suffix of the given fragment with total weight
+-- ('totalWeightOfFragment') at most @k@. This is the volatile suffix of blocks
+-- which are subject to rollback.
+--
+-- If the total weight of the input fragment is at least @k@, then the anchor of
+-- the output fragment is the most recent point on the input fragment that is
+-- buried under at least weight @k@ (also counting the weight boost of that
+-- point).
+--
+-- >>> :{
+-- weights :: [(Point Blk, PerasWeight)]
+-- weights =
+--   [ (BlockPoint 2 "foo", PerasWeight 2)
+--   , (GenesisPoint,       PerasWeight 3)
+--   , (BlockPoint 3 "bar", PerasWeight 2)
+--   , (BlockPoint 2 "foo", PerasWeight 2)
+--   ]
+-- snap = mkPerasWeightSnapshot weights
+-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo"
+-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar"
+-- frag :: AnchoredFragment (HeaderFields Blk)
+-- frag = Empty AnchorGenesis :> foo :> bar
+-- :}
+--
+-- >>> k1 = SecurityParam $ knownNonZeroBounded @1
+-- >>> k3 = SecurityParam $ knownNonZeroBounded @3
+-- >>> k6 = SecurityParam $ knownNonZeroBounded @6
+-- >>> k9 = SecurityParam $ knownNonZeroBounded @9
+--
+-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k1 frag
+-- []
+--
+-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k3 frag
+-- [HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}]
+--
+-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k6 frag
+-- [HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}]
+--
+-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k9 frag
+-- [HeaderFields {headerFieldSlot = SlotNo 2, headerFieldBlockNo = BlockNo 1, headerFieldHash = "foo"},HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}]
+takeVolatileSuffix ::
+  forall blk h.
+  (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
+  PerasWeightSnapshot blk ->
+  -- | The security parameter @k@ is interpreted as a weight.
+  SecurityParam ->
+  AnchoredFragment h ->
+  AnchoredFragment h
+takeVolatileSuffix snap secParam frag
+  | Map.null $ getPerasWeightSnapshot snap =
+      -- Optimize the case where Peras is disabled.
+      AF.anchorNewest (unPerasWeight k) frag
+  | hasAtMostWeightK frag = frag
+  | otherwise = go 0 lenFrag (AF.Empty $ AF.headAnchor frag)
+ where
+  k :: PerasWeight
+  k = maxRollbackWeight secParam
+
+  hasAtMostWeightK :: AnchoredFragment h -> Bool
+  hasAtMostWeightK f = totalWeightOfFragment snap f <= k
+
+  lenFrag = fromIntegral $ AF.length frag
+
+  -- Binary search for the longest suffix of @frag@ which 'hasAtMostWeightK'.
+  go ::
+    Word64 -> -- lb. The length lb suffix satisfies 'hasAtMostWeightK'.
+    Word64 -> -- ub. The length ub suffix does not satisfy 'hasAtMostWeightK'.
+    AnchoredFragment h -> -- The length lb suffix.
+    AnchoredFragment h
+  go lb ub lbFrag
+    | lb + 1 == ub = lbFrag
+    | hasAtMostWeightK midFrag = go mid ub midFrag
+    | otherwise = go lb mid lbFrag
+   where
+    mid = (lb + ub) `div` 2
+    midFrag = AF.anchorNewest mid frag
+
 -- $setup
+-- >>> import Cardano.Ledger.BaseTypes
 -- >>> import Ouroboros.Consensus.Block
+-- >>> import Ouroboros.Consensus.Config.SecurityParam
 -- >>> import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq(..), Anchor(..))
 -- >>> import qualified Ouroboros.Network.AnchoredFragment as AF
--- >>> :set -XTypeFamilies
+-- >>> :set -XDataKinds -XTypeApplications -XTypeFamilies
 -- >>> data Blk = Blk
 -- >>> type instance HeaderHash Blk = String
 -- >>> instance StandardHash Blk

From dd53c3685d46e2b1fba96471a13b3dbea4156aa4 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Tue, 29 Jul 2025 19:49:32 +0200
Subject: [PATCH 29/42] Add test for `PerasWeightSnapshot`

---
 ouroboros-consensus/ouroboros-consensus.cabal |   1 +
 .../test/consensus-test/Main.hs               |   2 +
 .../Test/Consensus/Peras/WeightSnapshot.hs    | 176 ++++++++++++++++++
 3 files changed, 179 insertions(+)
 create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs

diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index d8476cd1a3..0b9ae03ab2 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -592,6 +592,7 @@ test-suite consensus-test
     Test.Consensus.MiniProtocol.ChainSync.CSJ
     Test.Consensus.MiniProtocol.ChainSync.Client
     Test.Consensus.MiniProtocol.LocalStateQuery.Server
+    Test.Consensus.Peras.WeightSnapshot
     Test.Consensus.Util.MonadSTM.NormalForm
     Test.Consensus.Util.Versioned
 
diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs
index 88681b82fa..beddd1f7d2 100644
--- a/ouroboros-consensus/test/consensus-test/Main.hs
+++ b/ouroboros-consensus/test/consensus-test/Main.hs
@@ -16,6 +16,7 @@ import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests)
 import qualified Test.Consensus.MiniProtocol.ChainSync.CSJ (tests)
 import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests)
 import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests)
+import qualified Test.Consensus.Peras.WeightSnapshot (tests)
 import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests)
 import qualified Test.Consensus.Util.Versioned (tests)
 import Test.Tasty
@@ -43,6 +44,7 @@ tests =
         , Test.Consensus.Mempool.Fairness.tests
         , Test.Consensus.Mempool.StateMachine.tests
         ]
+    , Test.Consensus.Peras.WeightSnapshot.tests
     , Test.Consensus.Util.MonadSTM.NormalForm.tests
     , Test.Consensus.Util.Versioned.tests
     , testGroup
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs
new file mode 100644
index 0000000000..59fd52d636
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+#if __GLASGOW_HASKELL__ >= 910
+{-# OPTIONS_GHC -Wno-x-partial #-}
+#endif
+
+-- | Test that 'PerasWeightSnapshot' can correctly compute the weight of points
+-- and fragments.
+module Test.Consensus.Peras.WeightSnapshot (tests) where
+
+import Cardano.Ledger.BaseTypes (unNonZero)
+import Data.Containers.ListUtils (nubOrd)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes)
+import Data.Traversable (for)
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Config.SecurityParam
+import Ouroboros.Consensus.Peras.Weight
+import Ouroboros.Consensus.Util.Condense
+import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+import qualified Ouroboros.Network.Mock.Chain as Chain
+import Test.QuickCheck
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.Util.Orphans.Arbitrary ()
+import Test.Util.QuickCheck
+import Test.Util.TestBlock
+
+tests :: TestTree
+tests =
+  testGroup
+    "PerasWeightSnapshot"
+    [ testProperty "correctness" prop_perasWeightSnapshot
+    ]
+
+prop_perasWeightSnapshot :: TestSetup -> Property
+prop_perasWeightSnapshot testSetup =
+  tabulate "log₂ # of points" [show $ round @Double @Int $ logBase 2 (fromIntegral (length tsPoints))]
+    . counterexample ("PerasWeightSnapshot: " <> show snap)
+    $ conjoin
+      [ conjoin
+          [ counterexample ("Incorrect weight for " <> condense pt) $
+              weightBoostOfPointReference pt =:= weightBoostOfPoint snap pt
+          | pt <- tsPoints
+          ]
+      , conjoin
+          [ counterexample ("Incorrect weight for " <> condense frag) $
+              weightBoostOfFragmentReference frag =:= weightBoostOfFragment snap frag
+          | frag <- tsFragments
+          ]
+      , conjoin
+          [ conjoin
+              [ counterexample ("Incorrect volatile suffix for " <> condense frag) $
+                  takeVolatileSuffixReference frag =:= volSuffix
+              , counterexample ("Volatile suffix must be a suffix of" <> condense frag) $
+                  AF.headPoint frag =:= AF.headPoint volSuffix
+                    .&&. AF.withinFragmentBounds (AF.anchorPoint volSuffix) frag
+              , counterexample ("Volatile suffix of " <> condense frag <> " must contain at most k blocks") $
+                  AF.length volSuffix `le` fromIntegral (unNonZero (maxRollbacks tsSecParam))
+              ]
+          | frag <- tsFragments
+          , let volSuffix = takeVolatileSuffix snap tsSecParam frag
+          ]
+      ]
+ where
+  TestSetup
+    { tsWeights
+    , tsPoints
+    , tsFragments
+    , tsSecParam
+    } = testSetup
+
+  snap = mkPerasWeightSnapshot $ Map.toList tsWeights
+
+  weightBoostOfPointReference :: Point TestBlock -> PerasWeight
+  weightBoostOfPointReference pt = Map.findWithDefault mempty pt tsWeights
+
+  weightBoostOfFragmentReference :: AnchoredFragment TestBlock -> PerasWeight
+  weightBoostOfFragmentReference frag =
+    foldMap
+      (weightBoostOfPointReference . blockPoint)
+      (AF.toOldestFirst frag)
+
+  takeVolatileSuffixReference ::
+    AnchoredFragment TestBlock -> AnchoredFragment TestBlock
+  takeVolatileSuffixReference frag =
+    head
+      [ suffix
+      | len <- reverse [0 .. AF.length frag]
+      , -- Consider suffixes of @frag@, longest first
+      let suffix = AF.anchorNewest (fromIntegral len) frag
+          weightBoost = weightBoostOfFragmentReference suffix
+          lengthWeight = PerasWeight (fromIntegral (AF.length suffix))
+          totalWeight = lengthWeight <> weightBoost
+      , totalWeight <= maxRollbackWeight tsSecParam
+      ]
+
+data TestSetup = TestSetup
+  { tsWeights :: Map (Point TestBlock) PerasWeight
+  , tsPoints :: [Point TestBlock]
+  -- ^ Check the weight of these points.
+  , tsFragments :: [AnchoredFragment TestBlock]
+  -- ^ Check the weight of these fragments.
+  , tsSecParam :: SecurityParam
+  }
+  deriving stock Show
+
+instance Arbitrary TestSetup where
+  arbitrary = do
+    tree :: BlockTree <- arbitrary
+    let tsPoints = nubOrd $ GenesisPoint : (blockPoint <$> treeToBlocks tree)
+        treeChains = treeToChains tree
+    tsWeights <- do
+      boostedChain <- elements treeChains
+      let boostablePts =
+            GenesisPoint : (blockPoint <$> Chain.toOldestFirst boostedChain)
+      Map.fromList . catMaybes <$> for boostablePts \pt -> do
+        weight <-
+          frequency
+            [ (3, pure Nothing)
+            , (1, Just . PerasWeight <$> choose (1, 10))
+            ]
+        pure $ (pt,) <$> weight
+    tsFragments <- for treeChains \chain -> do
+      let lenChain = Chain.length chain
+          fullFrag = Chain.toAnchoredFragment chain
+      nTakeNewest <- choose (0, lenChain)
+      nDropNewest <- choose (0, nTakeNewest)
+      pure $
+        AF.dropNewest nDropNewest $
+          AF.anchorNewest (fromIntegral nTakeNewest) fullFrag
+    tsSecParam <- arbitrary
+    pure
+      TestSetup
+        { tsWeights
+        , tsPoints
+        , tsFragments
+        , tsSecParam
+        }
+
+  shrink ts =
+    concat
+      [ [ ts{tsWeights = Map.fromList tsWeights'}
+        | tsWeights' <-
+            shrinkList
+              -- Shrink boosted points to have weight 1.
+              (\(pt, w) -> [(pt, w1) | w1 /= w])
+              $ Map.toList tsWeights
+        ]
+      , [ ts{tsPoints = tsPoints'}
+        | tsPoints' <- shrinkList (\_pt -> []) tsPoints
+        ]
+      , [ ts{tsFragments = tsFragments'}
+        | tsFragments' <- shrinkList (\_frag -> []) tsFragments
+        ]
+      , [ ts{tsSecParam = tsSecParam'}
+        | tsSecParam' <- shrink tsSecParam
+        ]
+      ]
+   where
+    w1 = PerasWeight 1
+
+    TestSetup
+      { tsWeights
+      , tsPoints
+      , tsFragments
+      , tsSecParam
+      } = ts

From 3fbf549cabb2d5b4dbc7f2006a0bec999728a592 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Wed, 30 Jul 2025 18:33:51 +0200
Subject: [PATCH 30/42] ChainDB.StateMachine: check immutable tip monotonicity

---
 .../Ouroboros/Storage/ChainDB/StateMachine.hs | 21 +++++++++++++++++--
 1 file changed, 19 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
index 69b40e4f92..ac125c07f9 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
@@ -1234,16 +1234,33 @@ invariant cfg Model{..} =
 
 postcondition ::
   TestConstraints blk =>
+  TopLevelConfig blk ->
   Model blk m Concrete ->
   At Cmd blk m Concrete ->
   At Resp blk m Concrete ->
   Logic
-postcondition model cmd resp =
+postcondition cfg model cmd resp =
   (toMock (eventAfter ev) resp .== eventMockResp ev)
     .// "real response didn't match model response"
+    .&& immutableTipMonotonicity
  where
   ev = lockstep model cmd resp
 
+  immutableTipMonotonicity = case unAt cmd of
+    -- When we wipe the VolatileDB (and haven't persisted all immutable blocks),
+    -- the immutable tip can recede.
+    WipeVolatileDB -> Top
+    _ ->
+      Annotate ("Immutable tip non-monotonicity: " <> show before <> " > " <> show after) $
+        Boolean (before <= after)
+   where
+    before = immTipBlockNo $ eventBefore ev
+    after = immTipBlockNo $ eventAfter ev
+    immTipBlockNo =
+      Chain.headBlockNo
+        . Model.immutableChain (configSecurityParam cfg)
+        . dbModel
+
 semantics ::
   forall blk.
   TestConstraints blk =>
@@ -1273,7 +1290,7 @@ sm loe env genBlock cfg initLedger =
     { initModel = initModel loe cfg initLedger
     , transition = transition
     , precondition = precondition
-    , postcondition = postcondition
+    , postcondition = postcondition cfg
     , generator = Just . generator loe genBlock
     , shrinker = shrinker
     , semantics = semantics cfg env

From 2e865cd720d58b8e967dbea17e7a75a3927a903c Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 15:30:09 +0200
Subject: [PATCH 31/42] ChainDB: define `getCurrentChain` in terms of weight

---
 .../Consensus/Storage/ChainDB/Impl/Query.hs   | 36 ++++++++++++++-----
 1 file changed, 27 insertions(+), 9 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
index 37838d7c44..ac6fc0be81 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
 
 -- | Queries
 module Ouroboros.Consensus.Storage.ChainDB.Impl.Query
@@ -32,7 +33,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query
   , getChainSelStarvation
   ) where
 
-import Cardano.Ledger.BaseTypes (unNonZero)
 import Control.ResourceRegistry (ResourceRegistry)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -44,7 +44,10 @@ import Ouroboros.Consensus.HeaderStateHistory
 import Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
 import Ouroboros.Consensus.Ledger.Abstract (EmptyMK)
 import Ouroboros.Consensus.Ledger.Extended
-import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
+import Ouroboros.Consensus.Peras.Weight
+  ( PerasWeightSnapshot
+  , takeVolatileSuffix
+  )
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( BlockComponent (..)
@@ -86,29 +89,44 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type
 getCurrentChain ::
   forall m blk.
   ( IOLike m
+  , StandardHash blk
   , HasHeader (Header blk)
   , ConsensusProtocol (BlockProtocol blk)
   ) =>
   ChainDbEnv m blk ->
   STM m (AnchoredFragment (Header blk))
-getCurrentChain CDB{..} =
-  AF.anchorNewest (unNonZero k) . icWithoutTime <$> readTVar cdbChain
- where
-  SecurityParam k = configSecurityParam cdbTopLevelConfig
+getCurrentChain cdb@CDB{..} =
+  getCurrentChainLike cdb $ icWithoutTime <$> readTVar cdbChain
 
 -- | Same as 'getCurrentChain', /mutatis mutandi/.
 getCurrentChainWithTime ::
   forall m blk.
   ( IOLike m
+  , StandardHash blk
   , HasHeader (HeaderWithTime blk)
   , ConsensusProtocol (BlockProtocol blk)
   ) =>
   ChainDbEnv m blk ->
   STM m (AnchoredFragment (HeaderWithTime blk))
-getCurrentChainWithTime CDB{..} =
-  AF.anchorNewest (unNonZero k) . icWithTime <$> readTVar cdbChain
+getCurrentChainWithTime cdb@CDB{..} =
+  getCurrentChainLike cdb $ icWithTime <$> readTVar cdbChain
+
+getCurrentChainLike ::
+  forall m blk h.
+  ( IOLike m
+  , StandardHash blk
+  , HasHeader h
+  , HeaderHash blk ~ HeaderHash h
+  , ConsensusProtocol (BlockProtocol blk)
+  ) =>
+  ChainDbEnv m blk ->
+  STM m (AnchoredFragment h) ->
+  STM m (AnchoredFragment h)
+getCurrentChainLike cdb@CDB{..} getCurChain = do
+  weights <- forgetFingerprint <$> getPerasWeightSnapshot cdb
+  takeVolatileSuffix weights k <$> getCurChain
  where
-  SecurityParam k = configSecurityParam cdbTopLevelConfig
+  k = configSecurityParam cdbTopLevelConfig
 
 -- | Get a 'HeaderStateHistory' populated with the 'HeaderState's of the
 -- last @k@ blocks of the current chain.

From f8a0c06ed7703a2fcd9b5c7cf4293b92bbba9513 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 17 Jul 2025 14:36:47 +0200
Subject: [PATCH 32/42] GSM: allow `candidateOverSelection` to be stateful

This is in preparation for weighted chain comparisons.
---
 .../Ouroboros/Consensus/Node/GSM.hs             | 17 ++++++++++++-----
 .../Ouroboros/Consensus/NodeKernel.hs           |  2 +-
 .../test/consensus-test/Test/Consensus/GSM.hs   |  3 ++-
 .../Consensus/Genesis/Tests/LoE/CaughtUp.hs     |  2 +-
 4 files changed, 16 insertions(+), 8 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs
index aa9733d360..780602118b 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs
@@ -104,10 +104,16 @@ data GsmView m upstreamPeer selection chainSyncState = GsmView
   -- thundering herd phenomenon.
   --
   -- 'Nothing' should only be used for testing.
-  , candidateOverSelection ::
-      selection ->
-      chainSyncState ->
-      CandidateVersusSelection
+  , getCandidateOverSelection ::
+      STM
+        m
+        ( selection ->
+          chainSyncState ->
+          CandidateVersusSelection
+        )
+  -- ^ Whether the candidate from the @chainSyncState@ is preferable to the
+  -- selection. This can depend on external state (Peras certificates boosting
+  -- blocks).
   , peerIsIdle :: chainSyncState -> Bool
   , durationUntilTooOld :: Maybe (selection -> m DurationFromNow)
   -- ^ How long from now until the selection will be so old that the node
@@ -234,7 +240,7 @@ realGsmEntryPoints tracerArgs gsmView =
 
   GsmView
     { antiThunderingHerd
-    , candidateOverSelection
+    , getCandidateOverSelection
     , peerIsIdle
     , durationUntilTooOld
     , equivalent
@@ -383,6 +389,7 @@ realGsmEntryPoints tracerArgs gsmView =
     -- long.
     selection <- getCurrentSelection
     candidates <- traverse StrictSTM.readTVar varsState
+    candidateOverSelection <- getCandidateOverSelection
     let ok candidate =
           WhetherCandidateIsBetter False
             == candidateOverSelection selection candidate
diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index b9c53da498..d56dbf42c5 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -271,7 +271,7 @@ initNodeKernel
               gsmTracerArgs
               GSM.GsmView
                 { GSM.antiThunderingHerd = Just gsmAntiThunderingHerd
-                , GSM.candidateOverSelection = \(headers, _lst) state ->
+                , GSM.getCandidateOverSelection = pure $ \(headers, _lst) state ->
                     case AF.intersectionPoint headers (csCandidate state) of
                       Nothing -> GSM.CandidateDoesNotIntersect
                       Just{} ->
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs
index 4f223c42e1..44a57f4c32 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs
@@ -137,7 +137,8 @@ setupGsm isHaaSatisfied vars = do
     (id, tracer)
     GSM.GsmView
       { GSM.antiThunderingHerd = Nothing
-      , GSM.candidateOverSelection = \s (PeerState c _) -> candidateOverSelection s c
+      , GSM.getCandidateOverSelection = pure $ \s (PeerState c _) ->
+          candidateOverSelection s c
       , GSM.peerIsIdle = isIdling
       , GSM.durationUntilTooOld = Just durationUntilTooOld
       , GSM.equivalent = (==) -- unsound, but harmless in this test
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs
index fe7383c0f4..63f5e8bea7 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs
@@ -279,7 +279,7 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState =
   GSM.realGsmEntryPoints
     (id, nullTracer)
     GSM.GsmView
-      { GSM.candidateOverSelection
+      { GSM.getCandidateOverSelection = pure candidateOverSelection
       , GSM.peerIsIdle = csIdling
       , GSM.equivalent = (==) `on` AF.headPoint
       , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles

From 25512c215d948bda5e28feed617f3c0b6c301a0a Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 28 Jul 2025 15:32:15 +0200
Subject: [PATCH 33/42] Add `WeightedSelectView`

---
 ouroboros-consensus/ouroboros-consensus.cabal |   1 +
 .../Ouroboros/Consensus/Peras/SelectView.hs   | 137 ++++++++++++++++++
 2 files changed, 138 insertions(+)
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs

diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index 0b9ae03ab2..9d383b210d 100644
--- a/ouroboros-consensus/ouroboros-consensus.cabal
+++ b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -190,6 +190,7 @@ library
     Ouroboros.Consensus.Node.Run
     Ouroboros.Consensus.Node.Serialisation
     Ouroboros.Consensus.NodeId
+    Ouroboros.Consensus.Peras.SelectView
     Ouroboros.Consensus.Peras.Weight
     Ouroboros.Consensus.Protocol.Abstract
     Ouroboros.Consensus.Protocol.BFT
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs
new file mode 100644
index 0000000000..9e125ee7dd
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Ouroboros.Consensus.Peras.SelectView
+  ( -- * 'WeightedSelectView'
+    WeightedSelectView (..)
+  , wsvTotalWeight
+  , weightedSelectView
+
+    -- * Utility: 'WithEmptyFragment'
+  , WithEmptyFragment (..)
+  , withEmptyFragmentFromMaybe
+  , withEmptyFragmentToMaybe
+  ) where
+
+import Data.Function (on)
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.Weight
+import Ouroboros.Consensus.Protocol.Abstract
+import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+
+{-------------------------------------------------------------------------------
+  Weighted select views
+-------------------------------------------------------------------------------}
+
+-- | Information from a non-empty chain fragment for a weighted chain comparison
+-- against other fragments with the same anchor.
+data WeightedSelectView proto = WeightedSelectView
+  { wsvBlockNo :: !BlockNo
+  -- ^ The 'BlockNo' at the tip of a fragment.
+  , wsvWeightBoost :: !PerasWeight
+  -- ^ The weight boost of a fragment (w.r.t. a particular anchor).
+  , wsvTiebreaker :: TiebreakerView proto
+  -- ^ Lazy because it is only needed when 'wsvTotalWeight' is inconclusive.
+  }
+
+deriving stock instance Show (TiebreakerView proto) => Show (WeightedSelectView proto)
+deriving stock instance Eq (TiebreakerView proto) => Eq (WeightedSelectView proto)
+
+-- TODO: More type safety to prevent people from accidentally comparing
+-- 'WeightedSelectView's obtained from fragments with different anchors?
+-- Something ST-trick like?
+
+-- | The total weight, ie the sum of 'wsvBlockNo' and 'wsvBoostedWeight'.
+wsvTotalWeight :: WeightedSelectView proto -> PerasWeight
+-- could be cached, but then we need to be careful to maintain the invariant
+wsvTotalWeight wsv =
+  PerasWeight (unBlockNo (wsvBlockNo wsv)) <> wsvWeightBoost wsv
+
+instance Ord (TiebreakerView proto) => Ord (WeightedSelectView proto) where
+  compare =
+    mconcat
+      [ compare `on` wsvTotalWeight
+      , compare `on` wsvTiebreaker
+      ]
+
+instance ChainOrder (TiebreakerView proto) => ChainOrder (WeightedSelectView proto) where
+  type ChainOrderConfig (WeightedSelectView proto) = ChainOrderConfig (TiebreakerView proto)
+
+  preferCandidate cfg ours cand =
+    case compare (wsvTotalWeight ours) (wsvTotalWeight cand) of
+      LT -> True
+      EQ -> preferCandidate cfg (wsvTiebreaker ours) (wsvTiebreaker cand)
+      GT -> False
+
+-- | Get the 'WeightedSelectView' for a fragment using the given
+-- 'PerasWeightSnapshot'. Note that this is only meanigful for comparisons
+-- against other fragments /with the same anchor/.
+--
+-- Returns 'EmptyFragment' iff the input fragment is empty.
+weightedSelectView ::
+  ( GetHeader1 h
+  , HasHeader (h blk)
+  , HeaderHash blk ~ HeaderHash (h blk)
+  , BlockSupportsProtocol blk
+  ) =>
+  BlockConfig blk ->
+  PerasWeightSnapshot blk ->
+  AnchoredFragment (h blk) ->
+  WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
+weightedSelectView bcfg weights = \case
+  AF.Empty{} -> EmptyFragment
+  frag@(_ AF.:> (getHeader1 -> hdr)) ->
+    NonEmptyFragment
+      WeightedSelectView
+        { wsvBlockNo = blockNo hdr
+        , wsvWeightBoost = weightBoostOfFragment weights frag
+        , wsvTiebreaker = tiebreakerView bcfg hdr
+        }
+
+{-------------------------------------------------------------------------------
+  WithEmptyFragment
+-------------------------------------------------------------------------------}
+
+-- | Attach the possibility of an empty fragment to a type.
+data WithEmptyFragment a = EmptyFragment | NonEmptyFragment !a
+  deriving stock (Show, Eq)
+
+withEmptyFragmentToMaybe :: WithEmptyFragment a -> Maybe a
+withEmptyFragmentToMaybe = \case
+  EmptyFragment -> Nothing
+  NonEmptyFragment a -> Just a
+
+withEmptyFragmentFromMaybe :: Maybe a -> WithEmptyFragment a
+withEmptyFragmentFromMaybe = \case
+  Nothing -> EmptyFragment
+  Just a -> NonEmptyFragment a
+
+-- | Prefer non-empty fragments to empty ones.
+instance Ord a => Ord (WithEmptyFragment a) where
+  compare = \cases
+    EmptyFragment EmptyFragment -> EQ
+    EmptyFragment NonEmptyFragment{} -> LT
+    NonEmptyFragment{} EmptyFragment -> GT
+    (NonEmptyFragment a) (NonEmptyFragment b) -> compare a b
+
+-- | Prefer non-empty fragments to empty ones. This instance assumes that the
+-- underlying fragments all have the same anchor.
+instance ChainOrder a => ChainOrder (WithEmptyFragment a) where
+  type ChainOrderConfig (WithEmptyFragment a) = ChainOrderConfig a
+
+  preferCandidate cfg = \cases
+    -- We prefer any non-empty fragment to the empty fragment.
+    EmptyFragment NonEmptyFragment{} -> True
+    -- We never prefer the empty fragment to our selection (even if it is also
+    -- empty).
+    _ EmptyFragment -> False
+    -- Otherwise, defer to @'ChainOrder' a@.
+    (NonEmptyFragment ours) (NonEmptyFragment cand) ->
+      preferCandidate cfg ours cand

From f4f27b6e968ba4e88a62645117dd08ee8a621f8c Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Wed, 23 Jul 2025 19:26:54 +0200
Subject: [PATCH 34/42] ChainSel: make `rollbackExceedsSuffix` weight-aware

Also remove the version for `ValidatedChainDiff` as it is unused.
---
 .../Ouroboros/Consensus/Fragment/Diff.hs      | 32 +++++++++++++++----
 .../Consensus/Fragment/ValidatedDiff.hs       |  4 ---
 .../Storage/ChainDB/Impl/ChainSel.hs          | 11 ++++---
 3 files changed, 33 insertions(+), 14 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs
index 1521969d44..1cd42db9de 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs
@@ -35,6 +35,7 @@ module Ouroboros.Consensus.Fragment.Diff
 import Data.Word (Word64)
 import GHC.Stack (HasCallStack)
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Network.AnchoredFragment
   ( AnchoredFragment
   , AnchoredSeq (..)
@@ -73,12 +74,31 @@ getTip = castPoint . AF.headPoint . getSuffix
 getAnchorPoint :: ChainDiff b -> Point b
 getAnchorPoint = castPoint . AF.anchorPoint . getSuffix
 
--- | Return 'True' iff applying the 'ChainDiff' to a chain @C@ will result in
--- a chain shorter than @C@, i.e., the number of blocks to roll back is
--- greater than the length of the new elements in the suffix to add.
-rollbackExceedsSuffix :: HasHeader b => ChainDiff b -> Bool
-rollbackExceedsSuffix (ChainDiff nbRollback suffix) =
-  nbRollback > fromIntegral (AF.length suffix)
+-- | Return 'True' iff applying the 'ChainDiff' to the given chain @C@ will
+-- result in a chain with less weight than @C@, i.e., the suffix of @C@ to roll
+-- back has more weight than suffix is adding.
+rollbackExceedsSuffix ::
+  forall b0 b1 b2.
+  ( HasHeader b0
+  , HasHeader b1
+  , HasHeader b2
+  , HeaderHash b0 ~ HeaderHash b1
+  , HeaderHash b0 ~ HeaderHash b2
+  ) =>
+  PerasWeightSnapshot b0 ->
+  -- | The chain @C@ the diff is applied to.
+  AnchoredFragment b1 ->
+  ChainDiff b2 ->
+  Bool
+rollbackExceedsSuffix weights curChain (ChainDiff nbRollback suffix) =
+  weightOf suffixToRollBack > weightOf suffix
+ where
+  suffixToRollBack = AF.anchorNewest nbRollback curChain
+
+  weightOf ::
+    (HasHeader b, HeaderHash b ~ HeaderHash b0) =>
+    AnchoredFragment b -> PerasWeight
+  weightOf = totalWeightOfFragment weights
 
 {-------------------------------------------------------------------------------
   Constructors
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs
index 0d31d8f3fe..0a18a54308 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs
@@ -13,7 +13,6 @@ module Ouroboros.Consensus.Fragment.ValidatedDiff
   , getChainDiff
   , getLedger
   , new
-  , rollbackExceedsSuffix
   , toValidatedFragment
 
     -- * Monadic
@@ -96,9 +95,6 @@ toValidatedFragment ::
 toValidatedFragment (UnsafeValidatedChainDiff cs l) =
   VF.ValidatedFragment (Diff.getSuffix cs) l
 
-rollbackExceedsSuffix :: HasHeader b => ValidatedChainDiff b l -> Bool
-rollbackExceedsSuffix = Diff.rollbackExceedsSuffix . getChainDiff
-
 {-------------------------------------------------------------------------------
   Monadic
 -------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
index af3c9b35da..51b4d7fe12 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -63,6 +63,7 @@ import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.Extended
 import Ouroboros.Consensus.Ledger.Inspect
 import Ouroboros.Consensus.Ledger.SupportsProtocol
+import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( AddBlockPromise (..)
   , AddBlockResult (..)
@@ -809,10 +810,10 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
         -- headers from disk.
         . flip evalStateT initCache
         . mapM translateToHeaders
-        -- 2. Filter out candidates that are shorter than the current
-        -- chain. We don't want to needlessly read the headers from disk
-        -- for those candidates.
-        . NE.filter (not . Diff.rollbackExceedsSuffix)
+        -- 2. Filter out candidates that have less weight than the current
+        -- chain. We don't want to needlessly read the headers from disk for
+        -- those candidates.
+        . NE.filter (not . Diff.rollbackExceedsSuffix weights curChain)
         -- 1. Extend the diff with candidates fitting on @B@
         . Paths.extendWithSuccessors succsOf lookupBlockInfo
         $ diff
@@ -832,6 +833,8 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
    where
     chainSelEnv = mkChainSelEnv curChainAndLedger
     curChain = VF.validatedFragment curChainAndLedger
+    -- TODO use actual weights
+    weights = emptyPerasWeightSnapshot :: PerasWeightSnapshot blk
 
   mkSelectionChangedInfo ::
     AnchoredFragment (Header blk) ->

From f95a48510781265335080d5da13a328ee22c0922 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 17 Jul 2025 14:49:11 +0200
Subject: [PATCH 35/42] Introduce weighted chain comparisons

---
 .../Ouroboros/Consensus/NodeKernel.hs         |  21 +--
 .../Consensus/Genesis/Tests/LoE/CaughtUp.hs   |   6 +-
 .../BlockFetch/ClientInterface.hs             |  50 +++----
 .../MiniProtocol/ChainSync/Client.hs          |   8 +-
 .../Consensus/Storage/ChainDB/Impl.hs         |   2 +
 .../Storage/ChainDB/Impl/ChainSel.hs          | 122 ++++++++++++------
 .../Consensus/Storage/ChainDB/Impl/Types.hs   |  21 +--
 .../Consensus/Util/AnchoredFragment.hs        | 101 ++++-----------
 .../Test/Ouroboros/Storage/ChainDB/Model.hs   |   6 +-
 .../Ouroboros/Storage/ChainDB/Model/Test.hs   |   7 +-
 10 files changed, 172 insertions(+), 172 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index d56dbf42c5..d7c460ba11 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -271,15 +271,18 @@ initNodeKernel
               gsmTracerArgs
               GSM.GsmView
                 { GSM.antiThunderingHerd = Just gsmAntiThunderingHerd
-                , GSM.getCandidateOverSelection = pure $ \(headers, _lst) state ->
-                    case AF.intersectionPoint headers (csCandidate state) of
-                      Nothing -> GSM.CandidateDoesNotIntersect
-                      Just{} ->
-                        GSM.WhetherCandidateIsBetter $ -- precondition requires intersection
-                          preferAnchoredCandidate
-                            (configBlock cfg)
-                            headers
-                            (csCandidate state)
+                , GSM.getCandidateOverSelection = do
+                    weights <- ChainDB.getPerasWeightSnapshot chainDB
+                    pure $ \(headers, _lst) state ->
+                      case AF.intersectionPoint headers (csCandidate state) of
+                        Nothing -> GSM.CandidateDoesNotIntersect
+                        Just{} ->
+                          GSM.WhetherCandidateIsBetter $ -- precondition requires intersection
+                            preferAnchoredCandidate
+                              (configBlock cfg)
+                              (forgetFingerprint weights)
+                              headers
+                              (csCandidate state)
                 , GSM.peerIsIdle = csIdling
                 , GSM.durationUntilTooOld =
                     gsmDurationUntilTooOld
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs
index 63f5e8bea7..a58923bd60 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs
@@ -58,6 +58,7 @@ import qualified Ouroboros.Consensus.Node.GSM as GSM
 import Ouroboros.Consensus.Node.Genesis (setGetLoEFragment)
 import Ouroboros.Consensus.Node.GsmState
 import Ouroboros.Consensus.NodeId
+import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot)
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
 import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment
@@ -301,10 +302,13 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState =
       Just{} ->
         -- precondition requires intersection
         GSM.WhetherCandidateIsBetter $
-          preferAnchoredCandidate (configBlock cfg) selection candFrag
+          preferAnchoredCandidate (configBlock cfg) weights selection candFrag
    where
     candFrag = csCandidate candidateState
 
+    -- TODO https://github.com/tweag/cardano-peras/issues/67
+    weights = emptyPerasWeightSnapshot
+
 forkGDD ::
   forall m.
   IOLike m =>
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs
index bdf45723e0..89e9f102af 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs
@@ -33,6 +33,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol
   )
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping
+import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot)
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( AddBlockPromise
   , ChainDB
@@ -244,7 +245,7 @@ mkBlockFetchConsensusInterface
       AnchoredFragment (HeaderWithTime blk) ->
       AnchoredFragment (HeaderWithTime blk) ->
       Bool
-    plausibleCandidateChain ours cand
+    plausibleCandidateChain ours cand =
       -- 1. The ChainDB maintains the invariant that the anchor of our fragment
       --    corresponds to the immutable tip.
       --
@@ -258,45 +259,24 @@ mkBlockFetchConsensusInterface
       --    point. This means that we are no longer guaranteed that the
       --    precondition holds.
       --
-      -- 4. Our chain's anchor can only move forward. We can detect this by
-      --    looking at the block/slot numbers of the anchors: When the anchor
-      --    advances, either the block number increases (usual case), or the
-      --    block number stays the same, but the slot number increases (EBB
-      --    case).
-      --
-      | anchorBlockNoAndSlot cand < anchorBlockNoAndSlot ours -- (4)
-        =
-          case (AF.null ours, AF.null cand) of
-            -- Both are non-empty, the precondition trivially holds.
-            (False, False) -> preferAnchoredCandidate bcfg ours cand
-            -- The candidate is shorter than our chain and, worse, we'd have to
-            -- roll back past our immutable tip (the anchor of @cand@).
-            (_, True) -> False
-            -- As argued above we can only reach this case when our chain's anchor
-            -- has changed (4).
-            --
-            -- It is impossible for our chain to change /and/ still be empty: the
-            -- anchor of our chain only changes when a new block becomes
-            -- immutable. For a new block to become immutable, we must have
-            -- extended our chain with at least @k + 1@ blocks. Which means our
-            -- fragment can't be empty.
-            (True, _) -> error "impossible"
-      | otherwise =
-          preferAnchoredCandidate bcfg ours cand
-     where
-      anchorBlockNoAndSlot ::
-        AnchoredFragment (HeaderWithTime blk) ->
-        (WithOrigin BlockNo, WithOrigin SlotNo)
-      anchorBlockNoAndSlot frag =
-        (AF.anchorToBlockNo a, AF.anchorToSlotNo a)
-       where
-        a = AF.anchor frag
+      -- 4. Therefore, we check whether the candidate fragments still intersects
+      --    with our fragment; if not, then it is only a matter of time until the
+      --    ChainSync client disconnects from that peer.
+      case AF.intersectionPoint ours cand of
+        -- REVIEW: Hmm, maybe we want to change 'preferAnchoredCandidates' to
+        -- also just return 'False' in this case (and we remove the
+        -- precondition).
+        Nothing -> False
+        Just _ -> preferAnchoredCandidate bcfg weights ours cand
 
     compareCandidateChains ::
       AnchoredFragment (HeaderWithTime blk) ->
       AnchoredFragment (HeaderWithTime blk) ->
       Ordering
-    compareCandidateChains = compareAnchoredFragments bcfg
+    compareCandidateChains = compareAnchoredFragments bcfg weights
+
+    -- TODO requires https://github.com/IntersectMBO/ouroboros-network/pull/5161
+    weights = emptyPerasWeightSnapshot
 
     headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime
     headerForgeUTCTime =
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
index a3de6a4d73..50d063cef7 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
@@ -125,6 +125,7 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Ju
 import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State
 import Ouroboros.Consensus.Node.GsmState (GsmState (..))
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
+import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot)
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Storage.ChainDB (ChainDB)
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
@@ -1834,7 +1835,12 @@ checkTime cfgEnv dynEnv intEnv =
   checkPreferTheirsOverOurs kis
     | -- Precondition is fulfilled as ourFrag and theirFrag intersect by
       -- construction.
-      preferAnchoredCandidate (configBlock cfg) ourFrag theirFrag =
+      preferAnchoredCandidate
+        (configBlock cfg)
+        -- TODO: remove this entire check, see https://github.com/tweag/cardano-peras/issues/64
+        emptyPerasWeightSnapshot
+        ourFrag
+        theirFrag =
         pure ()
     | otherwise =
         throwSTM $
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index 94575db258..36be9d59cd 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -182,6 +182,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
 
     traceWith initChainSelTracer StartedInitChainSelection
     initialLoE <- Args.cdbsLoE cdbSpecificArgs
+    initialWeights <- atomically $ PerasCertDB.getWeightSnapshot perasCertDB
     chain <- withRegistry $ \rr -> do
       chainAndLedger <-
         ChainSel.initialChainSelection
@@ -193,6 +194,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
           (Args.cdbsTopLevelConfig cdbSpecificArgs)
           varInvalid
           (void initialLoE)
+          (forgetFingerprint initialWeights)
       traceWith initChainSelTracer InitialChainSelected
 
       let chain = VF.validatedFragment chainAndLedger
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
index 51b4d7fe12..75d09de266 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -38,7 +38,7 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NE
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromJust, isJust)
+import Data.Maybe (fromJust, fromMaybe, isJust)
 import Data.Maybe.Strict (StrictMaybe (..), strictMaybeToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -63,6 +63,7 @@ import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.Extended
 import Ouroboros.Consensus.Ledger.Inspect
 import Ouroboros.Consensus.Ledger.SupportsProtocol
+import Ouroboros.Consensus.Peras.SelectView
 import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( AddBlockPromise (..)
@@ -123,6 +124,7 @@ initialChainSelection ::
   TopLevelConfig blk ->
   StrictTVar m (WithFingerprint (InvalidBlocks blk)) ->
   LoE () ->
+  PerasWeightSnapshot blk ->
   m (ChainAndLedger m blk)
 initialChainSelection
   immutableDB
@@ -132,7 +134,8 @@ initialChainSelection
   tracer
   cfg
   varInvalid
-  loE = do
+  loE
+  weights = do
     -- TODO: Improve the user experience by trimming any potential
     -- blocks from the future from the VolatileDB.
     --
@@ -177,7 +180,7 @@ initialChainSelection
     let curChain = Empty (AF.castAnchor i)
     curChainAndLedger <- VF.newM curChain curForker
 
-    case NE.nonEmpty (filter (preferAnchoredCandidate bcfg curChain) chains) of
+    case NE.nonEmpty (filter (preferAnchoredCandidate bcfg weights curChain) chains) of
       -- If there are no candidates, no chain selection is needed
       Nothing -> return curChainAndLedger
       Just chains' ->
@@ -259,7 +262,7 @@ initialChainSelection
     chainSelection' curChainAndLedger candidates =
       atomically (forkerCurrentPoint ledger) >>= \curpt ->
         assert (all ((curpt ==) . castPoint . AF.anchorPoint) candidates) $
-          assert (all (preferAnchoredCandidate bcfg curChain) candidates) $ do
+          assert (all (preferAnchoredCandidate bcfg weights curChain) candidates) $ do
             cse <- chainSelEnv
             chainSelection cse rr (Diff.extend <$> candidates)
      where
@@ -274,6 +277,7 @@ initialChainSelection
             , bcfg
             , varInvalid
             , blockCache = BlockCache.empty
+            , weights
             , curChainAndLedger
             , validationTracer = InitChainSelValidation >$< tracer
             , -- initial chain selection is not concerned about pipelining
@@ -538,14 +542,15 @@ chainSelectionForBlock ::
   InvalidBlockPunishment m ->
   Electric m ()
 chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegistry $ \rr -> do
-  (invalid, succsOf, lookupBlockInfo, curChain, tipPoint) <-
+  (invalid, succsOf, lookupBlockInfo, curChain, tipPoint, weights) <-
     atomically $
-      (,,,,)
+      (,,,,,)
         <$> (forgetFingerprint <$> readTVar cdbInvalid)
         <*> VolatileDB.filterByPredecessor cdbVolatileDB
         <*> VolatileDB.getBlockInfo cdbVolatileDB
         <*> Query.getCurrentChain cdb
         <*> Query.getTipPoint cdb
+        <*> (forgetFingerprint <$> Query.getPerasWeightSnapshot cdb)
   -- This is safe: the LedgerDB tip doesn't change in between the previous
   -- atomically block and this call to 'withTipForker'.
   LedgerDB.withTipForker cdbLedgerDB rr $ \curForker -> do
@@ -610,14 +615,14 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
       | pointHash tipPoint == headerPrevHash hdr -> do
           -- ### Add to current chain
           traceWith addBlockTracer (TryAddToCurrentChain p)
-          addToCurrentChain rr succsOf' curChainAndLedger loeFrag
+          addToCurrentChain rr succsOf' weights curChainAndLedger loeFrag
 
       -- The block is reachable from the current selection
       -- and it doesn't fit after the current selection
       | Just diff <- Paths.isReachable lookupBlockInfo' curChain p -> do
           -- ### Switch to a fork
           traceWith addBlockTracer (TrySwitchToAFork p diff)
-          switchToAFork rr succsOf' lookupBlockInfo' curChainAndLedger loeFrag diff
+          switchToAFork rr succsOf' lookupBlockInfo' weights curChainAndLedger loeFrag diff
 
       -- We cannot reach the block from the current selection
       | otherwise -> do
@@ -637,8 +642,8 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
   addBlockTracer :: Tracer m (TraceAddBlockEvent blk)
   addBlockTracer = TraceAddBlockEvent >$< cdbTracer
 
-  mkChainSelEnv :: ChainAndLedger m blk -> ChainSelEnv m blk
-  mkChainSelEnv curChainAndLedger =
+  mkChainSelEnv :: PerasWeightSnapshot blk -> ChainAndLedger m blk -> ChainSelEnv m blk
+  mkChainSelEnv weights curChainAndLedger =
     ChainSelEnv
       { lgrDB = cdbLedgerDB
       , bcfg = configBlock cdbTopLevelConfig
@@ -649,6 +654,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
           filter ((TentativeChain ==) . fhChainType) . Map.elems
             <$> readTVar cdbFollowers
       , blockCache = blockCache
+      , weights
       , curChainAndLedger = curChainAndLedger
       , validationTracer =
           TraceAddBlockEvent . AddBlockValidation >$< cdbTracer
@@ -663,12 +669,13 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
     HasCallStack =>
     ResourceRegistry m ->
     (ChainHash blk -> Set (HeaderHash blk)) ->
+    PerasWeightSnapshot blk ->
     ChainAndLedger m blk ->
     -- \^ The current chain and ledger
     LoE (AnchoredFragment (HeaderWithTime blk)) ->
     -- \^ LoE fragment
     m ()
-  addToCurrentChain rr succsOf curChainAndLedger loeFrag = do
+  addToCurrentChain rr succsOf weights curChainAndLedger loeFrag = do
     -- Extensions of @B@ that do not exceed the LoE
     let suffixesAfterB = Paths.maximalCandidates succsOf Nothing (realPointToPoint p)
 
@@ -691,7 +698,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
 
     let chainDiffs =
           NE.nonEmpty $
-            filter (preferAnchoredCandidate (bcfg chainSelEnv) curChain . Diff.getSuffix) $
+            filter (preferAnchoredCandidate (bcfg chainSelEnv) weights curChain . Diff.getSuffix) $
               fmap (trimToLoE loeFrag curChainAndLedger) $
                 fmap Diff.extend $
                   NE.toList candidates
@@ -716,11 +723,12 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
             return ()
           Just validatedChainDiff ->
             switchTo
+              weights
               validatedChainDiff
               (varTentativeHeader chainSelEnv)
               AddingBlocks
    where
-    chainSelEnv = mkChainSelEnv curChainAndLedger
+    chainSelEnv = mkChainSelEnv weights curChainAndLedger
     curChain = VF.validatedFragment curChainAndLedger
     curHead = AF.headAnchor curChain
 
@@ -780,6 +788,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
     ResourceRegistry m ->
     (ChainHash blk -> Set (HeaderHash blk)) ->
     LookupBlockInfo blk ->
+    PerasWeightSnapshot blk ->
     ChainAndLedger m blk ->
     -- \^ The current chain (anchored at @i@) and ledger
     LoE (AnchoredFragment (HeaderWithTime blk)) ->
@@ -787,7 +796,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
     ChainDiff (HeaderFields blk) ->
     -- \^ Header fields for @(x,b]@
     m ()
-  switchToAFork rr succsOf lookupBlockInfo curChainAndLedger loeFrag diff = do
+  switchToAFork rr succsOf lookupBlockInfo weights curChainAndLedger loeFrag diff = do
     -- We use a cache to avoid reading the headers from disk multiple
     -- times in case they're part of multiple forks that go through @b@.
     let initCache = Map.singleton (headerHash hdr) hdr
@@ -799,7 +808,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
       -- blocks, so it satisfies the precondition of 'preferCandidate'.
       fmap
         ( filter
-            ( preferAnchoredCandidate (bcfg chainSelEnv) curChain
+            ( preferAnchoredCandidate (bcfg chainSelEnv) weights curChain
                 . Diff.getSuffix
             )
         )
@@ -827,38 +836,39 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
             return ()
           Just validatedChainDiff ->
             switchTo
+              weights
               validatedChainDiff
               (varTentativeHeader chainSelEnv)
               SwitchingToAFork
    where
-    chainSelEnv = mkChainSelEnv curChainAndLedger
+    chainSelEnv = mkChainSelEnv weights curChainAndLedger
     curChain = VF.validatedFragment curChainAndLedger
-    -- TODO use actual weights
-    weights = emptyPerasWeightSnapshot :: PerasWeightSnapshot blk
 
   mkSelectionChangedInfo ::
-    AnchoredFragment (Header blk) ->
-    -- \^ old chain
-    AnchoredFragment (Header blk) ->
-    -- \^ new chain
-    ExtLedgerState blk EmptyMK ->
-    -- \^ new tip
+    PerasWeightSnapshot blk ->
+    AnchoredFragment (Header blk) -> -- old selection
+    ChainDiff (Header blk) -> -- diff we are adopting
+    ExtLedgerState blk EmptyMK -> -- new tip
     SelectionChangedInfo blk
-  mkSelectionChangedInfo oldChain newChain newTip =
+  mkSelectionChangedInfo weights oldChain diff newTip =
     SelectionChangedInfo
       { newTipPoint = castRealPoint tipPoint
       , newTipEpoch = tipEpoch
       , newTipSlotInEpoch = tipSlotInEpoch
       , newTipTrigger = p
-      , newTipSelectView
-      , oldTipSelectView =
-          selectView (configBlock cfg)
-            <$> eitherToMaybe (AF.head oldChain)
+      , newSuffixSelectView
+      , oldSuffixSelectView =
+          withEmptyFragmentToMaybe $
+            weightedSelectView (configBlock cfg) weights oldSuffix
       }
    where
     cfg :: TopLevelConfig blk
     cfg = cdbTopLevelConfig
 
+    oldSuffix, newSuffix :: AnchoredFragment (Header blk)
+    oldSuffix = AF.anchorNewest (getRollback diff) oldChain
+    newSuffix = getSuffix diff
+
     ledger :: LedgerState blk EmptyMK
     ledger = ledgerState newTip
 
@@ -868,14 +878,13 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
         (configLedger cfg)
         ledger
 
-    (tipPoint, (tipEpoch, tipSlotInEpoch), newTipSelectView) =
-      case AF.head newChain of
-        Left _anchor -> error "cannot have switched to an empty chain"
-        Right tipHdr ->
+    (tipPoint, (tipEpoch, tipSlotInEpoch), newSuffixSelectView) =
+      case (AF.head newSuffix, weightedSelectView (configBlock cfg) weights newSuffix) of
+        (Right tipHdr, NonEmptyFragment wsv) ->
           let query = History.slotToEpoch' (blockSlot tipHdr)
               tipEpochData = History.runQueryPure query summary
-              sv = selectView (configBlock cfg) tipHdr
-           in (blockRealPoint tipHdr, tipEpochData, sv)
+           in (blockRealPoint tipHdr, tipEpochData, wsv)
+        _ -> error "cannot have switched via a diff with an empty suffix"
 
   -- \| Try to apply the given 'ChainDiff' on the current chain fragment. The
   -- 'LedgerDB' is updated in the same transaction.
@@ -890,13 +899,14 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
   -- us, as we cannot roll back more than @k@ headers anyway.
   switchTo ::
     HasCallStack =>
+    PerasWeightSnapshot blk ->
     ValidatedChainDiff (Header blk) (Forker' m blk) ->
     -- \^ Chain and ledger to switch to
     StrictTVar m (StrictMaybe (Header blk)) ->
     -- \^ Tentative header
     ChainSwitchType ->
     m ()
-  switchTo vChainDiff varTentativeHeader chainSwitchType = do
+  switchTo weights vChainDiff varTentativeHeader chainSwitchType = do
     traceWith addBlockTracer $
       ChangingSelection $
         castPoint $
@@ -960,7 +970,12 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist
     let mkTraceEvent = case chainSwitchType of
           AddingBlocks -> AddedToCurrentChain
           SwitchingToAFork -> SwitchedToAFork
-        selChangedInfo = mkSelectionChangedInfo curChain newChain newLedger
+        selChangedInfo =
+          mkSelectionChangedInfo
+            weights
+            curChain
+            (getChainDiff vChainDiff)
+            newLedger
     traceWith addBlockTracer $
       mkTraceEvent events selChangedInfo curChain newChain
     whenJust (strictMaybeToMaybe prevTentativeHeader) $
@@ -1020,6 +1035,7 @@ data ChainSelEnv m blk = ChainSelEnv
   , varTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
   , getTentativeFollowers :: STM m [FollowerHandle m blk]
   , blockCache :: BlockCache blk
+  , weights :: PerasWeightSnapshot blk
   , curChainAndLedger :: ChainAndLedger m blk
   , punish :: Maybe (RealPoint blk, InvalidBlockPunishment m)
   -- ^ The block that this chain selection invocation is processing, and the
@@ -1065,7 +1081,7 @@ chainSelection ::
 chainSelection chainSelEnv rr chainDiffs =
   assert
     ( all
-        (preferAnchoredCandidate bcfg curChain . Diff.getSuffix)
+        (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix)
         chainDiffs
     )
     $ assert
@@ -1080,8 +1096,7 @@ chainSelection chainSelEnv rr chainDiffs =
   curChain = VF.validatedFragment curChainAndLedger
 
   sortCandidates :: [ChainDiff (Header blk)] -> [ChainDiff (Header blk)]
-  sortCandidates =
-    sortBy (flip (compareAnchoredFragments bcfg) `on` Diff.getSuffix)
+  sortCandidates = sortBy (flip $ compareChainDiffs bcfg weights curChain)
 
   -- 1. Take the first candidate from the list of sorted candidates
   -- 2. Validate it
@@ -1117,7 +1132,7 @@ chainSelection chainSelEnv rr chainDiffs =
         -- it will be dropped here, as it will not be preferred over the
         -- current chain.
         let candidates2
-              | preferAnchoredCandidate bcfg curChain (Diff.getSuffix candidate') =
+              | preferAnchoredCandidate bcfg weights curChain (Diff.getSuffix candidate') =
                   candidate' : candidates1
               | otherwise =
                   candidates1
@@ -1175,7 +1190,7 @@ chainSelection chainSelEnv rr chainDiffs =
     let isRejected hdr =
           Map.member (headerHash hdr) (forgetFingerprint invalid)
     return $
-      filter (preferAnchoredCandidate bcfg curChain . Diff.getSuffix) $
+      filter (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix) $
         map (Diff.takeWhileOldest (not . isRejected)) cands
 
 -- [Ouroboros]
@@ -1383,3 +1398,26 @@ ignoreInvalidSuc ::
   (ChainHash blk -> Set (HeaderHash blk))
 ignoreInvalidSuc _ invalid succsOf =
   Set.filter (`Map.notMember` invalid) . succsOf
+
+-- | Compare two 'ChainDiff's w.r.t. the chain order.
+--
+-- PRECONDITION: Both 'ChainDiff's fit onto the given current chain.
+compareChainDiffs ::
+  forall blk.
+  BlockSupportsProtocol blk =>
+  BlockConfig blk ->
+  PerasWeightSnapshot blk ->
+  -- | Current chain.
+  AnchoredFragment (Header blk) ->
+  ChainDiff (Header blk) ->
+  ChainDiff (Header blk) ->
+  Ordering
+compareChainDiffs bcfg weights curChain =
+  -- The precondition of 'compareAnchoredFragment's is satisfied as the result
+  -- of @mkCand@ has the same anchor as @curChain@, and so any two fragments
+  -- returned by @mkCand@ do intersect.
+  compareAnchoredFragments bcfg weights `on` mkCand
+ where
+  mkCand =
+    fromMaybe (error "compareChainDiffs: precondition violated")
+      . Diff.apply curChain
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
index fb35b09651..cc5c33343e 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
@@ -99,6 +99,7 @@ import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import Ouroboros.Consensus.Ledger.Extended (ExtValidationError)
 import Ouroboros.Consensus.Ledger.Inspect
 import Ouroboros.Consensus.Ledger.SupportsProtocol
+import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView)
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( AddBlockPromise (..)
@@ -797,21 +798,23 @@ data SelectionChangedInfo blk = SelectionChangedInfo
   -- chain being A and having a disconnected C lying around, adding B will
   -- result in A -> B -> C as the new chain. The trigger B /= the new tip
   -- C.
-  , newTipSelectView :: SelectView (BlockProtocol blk)
-  -- ^ The 'SelectView' of the new tip. It is guaranteed that
+  , newSuffixSelectView :: WeightedSelectView (BlockProtocol blk)
+  -- ^ The 'WeightedSelectView' of the suffix of our new selection that was not
+  -- already present in the old selection. It is guaranteed that
   --
-  -- > Just newTipSelectView > oldTipSelectView
-  -- True
-  , oldTipSelectView :: Maybe (SelectView (BlockProtocol blk))
-  -- ^ The 'SelectView' of the old, previous tip. This can be 'Nothing' when
-  -- the previous chain/tip was Genesis.
+  -- > preferCandidate cfg
+  -- >   (withEmptyFragmentFromMaybe oldSuffixSelectView)
+  -- >   newSuffixSelectView
+  , oldSuffixSelectView :: Maybe (WeightedSelectView (BlockProtocol blk))
+  -- ^ The 'WeightedSelectView' of the orphaned suffix of our old selection.
+  -- This is 'Nothing' when we extended our selection.
   }
   deriving Generic
 
 deriving stock instance
-  (Show (SelectView (BlockProtocol blk)), StandardHash blk) => Show (SelectionChangedInfo blk)
+  (Show (TiebreakerView (BlockProtocol blk)), StandardHash blk) => Show (SelectionChangedInfo blk)
 deriving stock instance
-  (Eq (SelectView (BlockProtocol blk)), StandardHash blk) => Eq (SelectionChangedInfo blk)
+  (Eq (TiebreakerView (BlockProtocol blk)), StandardHash blk) => Eq (SelectionChangedInfo blk)
 
 -- | Trace type for the various events that occur when adding a block.
 data TraceAddBlockEvent blk
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs
index cfcb5c3050..a3020f767f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs
@@ -15,21 +15,17 @@ module Ouroboros.Consensus.Util.AnchoredFragment
   , stripCommonPrefix
   ) where
 
-import Control.Monad.Except (throwError)
 import Data.Foldable (toList)
 import qualified Data.Foldable1 as F1
 import Data.Function (on)
 import qualified Data.List.NonEmpty as NE
-import Data.Maybe (isJust)
 import Data.Word (Word64)
 import GHC.Stack
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.SelectView
+import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Protocol.Abstract
-import Ouroboros.Consensus.Util.Assert
-import Ouroboros.Network.AnchoredFragment
-  ( AnchoredFragment
-  , AnchoredSeq (Empty, (:>))
-  )
+import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 
 {-------------------------------------------------------------------------------
@@ -76,59 +72,38 @@ forksAtMostKBlocks k ours theirs = case ours `AF.intersect` theirs of
 
 -- | Compare two (potentially empty!) 'AnchoredFragment's.
 --
--- PRECONDITION: Either both fragments are non-empty or they intersect.
---
--- For a detailed discussion of this precondition, and a justification for the
--- definition of this function, please refer to the Consensus Report.
+-- PRECONDITION: The fragments must intersect.
 --
 -- Usage note: the primary user of this function is the chain database when
 -- sorting fragments that are preferred over our selection. It establishes the
 -- precondition in the following way: It will only compare candidate fragments
--- that it has previously verified are preferable to our current chain.
--- Therefore, they are non-empty, as an empty fragment anchored in our chain can
--- never be preferable to our chain.
+-- that it has previously verified are preferable to our current chain. Since
+-- these fragments intersect with our current chain, we can enlarge them to all
+-- be anchored in the immutable tip. Therefore, they intersect pairwise.
 compareAnchoredFragments ::
   forall blk h.
   ( BlockSupportsProtocol blk
   , HasCallStack
   , GetHeader1 h
   , HasHeader (h blk)
+  , HeaderHash (h blk) ~ HeaderHash blk
   ) =>
   BlockConfig blk ->
+  PerasWeightSnapshot blk ->
   AnchoredFragment (h blk) ->
   AnchoredFragment (h blk) ->
   Ordering
-compareAnchoredFragments cfg frag1 frag2 =
-  assertWithMsg (precondition frag1 frag2) $
-    case (frag1, frag2) of
-      (Empty _, Empty _) ->
-        -- The fragments intersect but are equal: their anchors must be equal,
-        -- and hence the fragments represent the same chain. They are therefore
-        -- equally preferable.
-        EQ
-      (Empty anchor, _ :> tip') ->
-        -- Since the fragments intersect, but the first one is empty, its anchor
-        -- must lie somewhere along the the second. If it is the tip, the two
-        -- fragments represent the same chain and are equally preferable. If
-        -- not, the second chain is a strict extension of the first and is
-        -- therefore strictly preferable.
-        if blockPoint tip' == AF.castPoint (AF.anchorToPoint anchor)
-          then EQ
-          else LT
-      (_ :> tip, Empty anchor') ->
-        -- This case is symmetric to the previous
-        if blockPoint tip == AF.castPoint (AF.anchorToPoint anchor')
-          then EQ
-          else GT
-      (_ :> tip, _ :> tip') ->
-        -- Case 4
-        compare
-          (selectView cfg (getHeader1 tip))
-          (selectView cfg (getHeader1 tip'))
+compareAnchoredFragments cfg weights frag1 frag2 =
+  case AF.intersect frag1 frag2 of
+    Nothing -> error "precondition violated: fragments must intersect"
+    Just (_oursPrefix, _candPrefix, oursSuffix, candSuffix) ->
+      compare
+        (weightedSelectView cfg weights oursSuffix)
+        (weightedSelectView cfg weights candSuffix)
 
 -- | Lift 'preferCandidate' to 'AnchoredFragment'
 --
--- PRECONDITION: Either both fragments are non-empty or they intersect.
+-- PRECONDITION: The fragments must intersect.
 --
 -- Usage note: the primary user of this function is the chain database. It
 -- establishes the precondition when comparing a candidate fragment to our
@@ -142,47 +117,27 @@ preferAnchoredCandidate ::
   , HasCallStack
   , GetHeader1 h
   , GetHeader1 h'
+  , HeaderHash (h blk) ~ HeaderHash blk
   , HeaderHash (h blk) ~ HeaderHash (h' blk)
   , HasHeader (h blk)
   , HasHeader (h' blk)
   ) =>
   BlockConfig blk ->
+  -- | Peras weights used to judge this chain.
+  PerasWeightSnapshot blk ->
   -- | Our chain
   AnchoredFragment (h blk) ->
   -- | Candidate
   AnchoredFragment (h' blk) ->
   Bool
-preferAnchoredCandidate cfg ours cand =
-  assertWithMsg (precondition ours cand) $
-    case (ours, cand) of
-      (_, Empty _) -> False
-      (Empty ourAnchor, _ :> theirTip) ->
-        blockPoint theirTip /= castPoint (AF.anchorToPoint ourAnchor)
-      (_ :> ourTip, _ :> theirTip) ->
-        preferCandidate
-          (projectChainOrderConfig cfg)
-          (selectView cfg (getHeader1 ourTip))
-          (selectView cfg (getHeader1 theirTip))
-
--- For 'compareAnchoredFragment' and 'preferAnchoredCandidate'.
-precondition ::
-  ( HeaderHash (h blk) ~ HeaderHash (h' blk)
-  , HasHeader (h blk)
-  , HasHeader (h' blk)
-  ) =>
-  AnchoredFragment (h blk) ->
-  AnchoredFragment (h' blk) ->
-  Either String ()
-precondition frag1 frag2
-  | not (AF.null frag1)
-  , not (AF.null frag2) =
-      return ()
-  | isJust (AF.intersectionPoint frag1 frag2) =
-      return ()
-  | otherwise =
-      throwError
-        "precondition violated: fragments should both be non-empty or they \
-        \should intersect"
+preferAnchoredCandidate cfg weights ours cand =
+  case AF.intersect ours cand of
+    Nothing -> error "precondition violated: fragments must intersect"
+    Just (_oursPrefix, _candPrefix, oursSuffix, candSuffix) ->
+      preferCandidate
+        (projectChainOrderConfig cfg)
+        (weightedSelectView cfg weights oursSuffix)
+        (weightedSelectView cfg weights candSuffix)
 
 -- | If the two fragments `c1` and `c2` intersect, return the intersection
 -- point and join the prefix of `c1` before the intersection with the suffix
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
index d8cbf1acb0..2ee8a755a3 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
@@ -108,6 +108,7 @@ import Ouroboros.Consensus.HeaderValidation
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.Extended
 import Ouroboros.Consensus.Ledger.SupportsProtocol
+import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Protocol.MockChainSel
 import Ouroboros.Consensus.Storage.ChainDB.API
@@ -863,9 +864,12 @@ validChains cfg m bs =
   sortChains =
     sortBy $
       flip
-        ( Fragment.compareAnchoredFragments (configBlock cfg)
+        ( Fragment.compareAnchoredFragments (configBlock cfg) weights
             `on` (Chain.toAnchoredFragment . fmap getHeader)
         )
+   where
+    -- TODO enrich with Peras weights/certs
+    weights = emptyPerasWeightSnapshot
 
   classify ::
     ValidatedChain blk ->
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs
index 6293e11968..bcb76e088d 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs
@@ -27,6 +27,7 @@ import GHC.Stack
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.Ledger.Tables
+import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( LoE (..)
   , StreamFrom (..)
@@ -101,11 +102,15 @@ prop_alwaysPickPreferredChain bt p =
   bcfg = configBlock singleNodeTestConfig
 
   preferCandidate' candidate =
-    AF.preferAnchoredCandidate bcfg curFragment candFragment
+    AF.preferAnchoredCandidate bcfg weights curFragment candFragment
       && AF.forksAtMostKBlocks (unNonZero k) curFragment candFragment
    where
     candFragment = Chain.toAnchoredFragment (getHeader <$> candidate)
 
+    -- TODO test with non-trivial weights
+    weights :: PerasWeightSnapshot TestBlock
+    weights = emptyPerasWeightSnapshot
+
 -- TODO add properties about forks too
 prop_between_currentChain :: LoE () -> BlockTree -> Property
 prop_between_currentChain loe bt =

From 6c4caed0b0dc4c609e176cf9e2cfd12603c14907 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 21 Jul 2025 11:58:14 +0200
Subject: [PATCH 36/42] Integrate weighted BlockFetch decision logic

---
 cabal.project                                 |  9 ++++++
 .../BlockFetch/ClientInterface.hs             | 32 ++++++++++++-------
 .../Ouroboros/Consensus/Util/STM.hs           | 24 +++-----------
 .../MiniProtocol/BlockFetch/Client.hs         |  1 +
 4 files changed, 35 insertions(+), 31 deletions(-)

diff --git a/cabal.project b/cabal.project
index e2c18aa305..cbc5548f14 100644
--- a/cabal.project
+++ b/cabal.project
@@ -56,6 +56,15 @@ allow-newer:
     , fin:QuickCheck
     , bin:QuickCheck
 
+source-repository-package
+   type: git
+   location: https://github.com/IntersectMBO/ouroboros-network
+   tag: b07a86ed853b63881b5a83e57508902f1562ac01
+   --sha256: sha256-n/XX0+cQegq2a1cAfmGx30T64eix4oEXzpVEFCKqmg0=
+   subdir:
+     ouroboros-network-api
+     ouroboros-network
+
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/cardano-ledger
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs
index 89e9f102af..a630e3d104 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs
@@ -33,7 +33,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol
   )
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping
-import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot)
+import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( AddBlockPromise
   , ChainDB
@@ -46,14 +46,15 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunis
 import Ouroboros.Consensus.Util.AnchoredFragment
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.Orphans ()
+import Ouroboros.Consensus.Util.STM
 import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import Ouroboros.Network.Block (MaxSlotNo)
 import Ouroboros.Network.BlockFetch.ConsensusInterface
   ( BlockFetchConsensusInterface (..)
+  , ChainComparison (..)
   , ChainSelStarvation
   , FetchMode (..)
-  , FromConsensus (..)
   , PraosFetchMode (..)
   , mkReadFetchMode
   )
@@ -67,6 +68,7 @@ data ChainDbView m blk = ChainDbView
   , getMaxSlotNo :: STM m MaxSlotNo
   , addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
   , getChainSelStarvation :: STM m ChainSelStarvation
+  , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
   }
 
 defaultChainDbView :: ChainDB m blk -> ChainDbView m blk
@@ -78,6 +80,7 @@ defaultChainDbView chainDB =
     , getMaxSlotNo = ChainDB.getMaxSlotNo chainDB
     , addBlockAsync = ChainDB.addBlockAsync chainDB
     , getChainSelStarvation = ChainDB.getChainSelStarvation chainDB
+    , getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB
     }
 
 readFetchModeDefault ::
@@ -227,6 +230,16 @@ mkBlockFetchConsensusInterface
     readFetchedMaxSlotNo :: STM m MaxSlotNo
     readFetchedMaxSlotNo = getMaxSlotNo chainDB
 
+    readChainComparison :: STM m (WithFingerprint (ChainComparison (HeaderWithTime blk)))
+    readChainComparison =
+      fmap mkChainComparison <$> getPerasWeightSnapshot chainDB
+     where
+      mkChainComparison weights =
+        ChainComparison
+          { plausibleCandidateChain = plausibleCandidateChain weights
+          , compareCandidateChains = compareCandidateChains weights
+          }
+
     -- Note that @ours@ comes from the ChainDB and @cand@ from the ChainSync
     -- client.
     --
@@ -242,10 +255,11 @@ mkBlockFetchConsensusInterface
     -- fragment, our current chain might have changed.
     plausibleCandidateChain ::
       HasCallStack =>
+      PerasWeightSnapshot blk ->
       AnchoredFragment (HeaderWithTime blk) ->
       AnchoredFragment (HeaderWithTime blk) ->
       Bool
-    plausibleCandidateChain ours cand =
+    plausibleCandidateChain weights ours cand =
       -- 1. The ChainDB maintains the invariant that the anchor of our fragment
       --    corresponds to the immutable tip.
       --
@@ -270,20 +284,16 @@ mkBlockFetchConsensusInterface
         Just _ -> preferAnchoredCandidate bcfg weights ours cand
 
     compareCandidateChains ::
+      PerasWeightSnapshot blk ->
       AnchoredFragment (HeaderWithTime blk) ->
       AnchoredFragment (HeaderWithTime blk) ->
       Ordering
-    compareCandidateChains = compareAnchoredFragments bcfg weights
-
-    -- TODO requires https://github.com/IntersectMBO/ouroboros-network/pull/5161
-    weights = emptyPerasWeightSnapshot
+    compareCandidateChains = compareAnchoredFragments bcfg
 
-    headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime
+    headerForgeUTCTime :: HeaderWithTime blk -> UTCTime
     headerForgeUTCTime =
-      pure
-        . fromRelativeTime (SupportsNode.getSystemStart bcfg)
+      fromRelativeTime (SupportsNode.getSystemStart bcfg)
         . hwtSlotRelativeTime
-        . unFromConsensus
 
     readChainSelStarvation = getChainSelStarvation chainDB
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs
index 9130e3bee1..86687227c7 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs
@@ -1,9 +1,5 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -36,10 +32,12 @@ import Control.Monad (void)
 import Control.Monad.State (StateT (..))
 import Control.ResourceRegistry
 import Data.Void
-import Data.Word (Word64)
-import GHC.Generics (Generic)
 import GHC.Stack
 import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Network.BlockFetch.ConsensusInterface
+  ( Fingerprint (..)
+  , WithFingerprint (..)
+  )
 
 {-------------------------------------------------------------------------------
   Misc
@@ -83,20 +81,6 @@ blockUntilJust getMaybeA = do
 blockUntilAllJust :: MonadSTM m => [STM m (Maybe a)] -> STM m [a]
 blockUntilAllJust = mapM blockUntilJust
 
--- | Simple type that can be used to indicate something in a @TVar@ is
--- changed.
-newtype Fingerprint = Fingerprint Word64
-  deriving stock (Show, Eq, Generic)
-  deriving newtype Enum
-  deriving anyclass NoThunks
-
--- | Store a value together with its fingerprint.
-data WithFingerprint a = WithFingerprint
-  { forgetFingerprint :: !a
-  , getFingerprint :: !Fingerprint
-  }
-  deriving (Show, Eq, Functor, Generic, NoThunks)
-
 {-------------------------------------------------------------------------------
   Simulate monad stacks
 -------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs
index e45c89ab65..1a440370e7 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs
@@ -306,6 +306,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do
       getMaxSlotNo = ChainDB.getMaxSlotNo chainDB
       addBlockAsync = ChainDB.addBlockAsync chainDB
       getChainSelStarvation = ChainDB.getChainSelStarvation chainDB
+      getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB
     pure BlockFetchClientInterface.ChainDbView{..}
    where
     cdbTracer = Tracer \case

From 7b76810669ca35c8741636bdf5815d1b1622169b Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Mon, 21 Jul 2025 11:58:18 +0200
Subject: [PATCH 37/42] ChainDB: implement chain selection for certificates

---
 .../Consensus/Storage/ChainDB/API.hs          | 23 +++++-
 .../Consensus/Storage/ChainDB/Impl.hs         |  6 +-
 .../Storage/ChainDB/Impl/Background.hs        |  6 ++
 .../Storage/ChainDB/Impl/ChainSel.hs          | 72 +++++++++++++++++
 .../Consensus/Storage/ChainDB/Impl/Types.hs   | 77 ++++++++++++++++---
 .../Ouroboros/Storage/ChainDB/StateMachine.hs |  3 +
 6 files changed, 170 insertions(+), 17 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
index e76fa7069c..91b13c2502 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
@@ -25,6 +25,10 @@ module Ouroboros.Consensus.Storage.ChainDB.API
   , addBlockWaitWrittenToDisk
   , addBlock_
 
+    -- * Adding a Peras certificate
+  , AddPerasCertPromise (..)
+  , addPerasCertSync
+
     -- * Trigger chain selection
   , ChainSelectionPromise (..)
   , triggerChainSelection
@@ -387,7 +391,7 @@ data ChainDB m blk = ChainDB
   , getStatistics :: m (Maybe Statistics)
   -- ^ Get statistics from the LedgerDB, in particular the number of entries
   -- in the tables.
-  , addPerasCert :: PerasCert blk -> m ()
+  , addPerasCertAsync :: PerasCert blk -> m (AddPerasCertPromise m)
   -- ^ TODO
   , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
   -- ^ TODO
@@ -510,6 +514,23 @@ triggerChainSelection :: IOLike m => ChainDB m blk -> m ()
 triggerChainSelection chainDB =
   waitChainSelectionPromise =<< chainSelAsync chainDB
 
+{-------------------------------------------------------------------------------
+  Adding a Peras certificate
+-------------------------------------------------------------------------------}
+
+newtype AddPerasCertPromise m = AddPerasCertPromise
+  { waitPerasCertProcessed :: m ()
+  -- ^ Wait until the Peras certificate has been processed (which potentially
+  -- includes switching to a different chain). If the PerasCertDB did already
+  -- contain a certificate for this round, the certificate is ignored (as the
+  -- two certificates must be identical because certificate equivocation is
+  -- impossible).
+  }
+
+addPerasCertSync :: IOLike m => ChainDB m blk -> PerasCert blk -> m ()
+addPerasCertSync chainDB cert =
+  waitPerasCertProcessed =<< addPerasCertAsync chainDB cert
+
 {-------------------------------------------------------------------------------
   Serialised block/header with its point
 -------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index 36be9d59cd..037f1189ed 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -16,6 +16,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl
     -- * Trace types
   , SelectionChangedInfo (..)
   , TraceAddBlockEvent (..)
+  , TraceAddPerasCertEvent (..)
   , TraceChainSelStarvationEvent (..)
   , TraceCopyToImmutableDBEvent (..)
   , TraceEvent (..)
@@ -286,10 +287,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , getHeaderStateHistory = getEnvSTM h Query.getHeaderStateHistory
             , getReadOnlyForkerAtPoint = getEnv2 h Query.getReadOnlyForkerAtPoint
             , getStatistics = getEnv h Query.getStatistics
-            , addPerasCert = getEnv1 h $ \cdb@CDB{..} cert -> do
-                _ <- PerasCertDB.addCert cdbPerasCertDB cert
-                -- TODO trigger chain selection in a more efficient way
-                waitChainSelectionPromise =<< ChainSel.triggerChainSelectionAsync cdb
+            , addPerasCertAsync = getEnv1 h ChainSel.addPerasCertAsync
             , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot
             }
     addBlockTestFuse <- newFuse "test chain selection"
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
index 4c0e9229cf..43ee891bbd 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
@@ -634,6 +634,8 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do
                   varBlockProcessed
                   (FailedToAddBlock "Failed to add block synchronously")
               pure ()
+            ChainSelAddPerasCert _cert varProcessed ->
+              void $ tryPutTMVar varProcessed ()
           closeChainSelQueue cdbChainSelQueue
       )
       ( \message -> do
@@ -642,6 +644,10 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do
               trace PoppedReprocessLoEBlocksFromQueue
             ChainSelAddBlock BlockToAdd{blockToAdd} ->
               trace $ PoppedBlockFromQueue $ blockRealPoint blockToAdd
+            ChainSelAddPerasCert cert _varProcessed ->
+              traceWith cdbTracer $
+                TraceAddPerasCertEvent $
+                  PoppedPerasCertFromQueue (perasCertRound cert) (perasCertBoostedBlock cert)
           chainSelSync cdb message
           lift $ atomically $ processedChainSelMessage cdbChainSelQueue message
       )
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
index 75d09de266..7661b487ae 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -13,6 +13,7 @@
 -- adding a block.
 module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel
   ( addBlockAsync
+  , addPerasCertAsync
   , chainSelSync
   , chainSelectionForBlock
   , initialChainSelection
@@ -68,6 +69,7 @@ import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( AddBlockPromise (..)
   , AddBlockResult (..)
+  , AddPerasCertPromise
   , BlockComponent (..)
   , ChainType (..)
   , LoE (..)
@@ -91,10 +93,12 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import Ouroboros.Consensus.Storage.LedgerDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
+import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB
 import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB)
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.AnchoredFragment
+import Ouroboros.Consensus.Util.EarlyExit (exitEarly, withEarlyExit_)
 import Ouroboros.Consensus.Util.Enclose (encloseWith)
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.STM (WithFingerprint (..))
@@ -323,6 +327,15 @@ addBlockAsync ::
 addBlockAsync CDB{cdbTracer, cdbChainSelQueue} =
   addBlockToAdd (TraceAddBlockEvent >$< cdbTracer) cdbChainSelQueue
 
+addPerasCertAsync ::
+  forall m blk.
+  (IOLike m, HasHeader blk) =>
+  ChainDbEnv m blk ->
+  PerasCert blk ->
+  m (AddPerasCertPromise m)
+addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} =
+  addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue
+
 -- | Schedule reprocessing of blocks postponed by the LoE.
 triggerChainSelectionAsync ::
   forall m blk.
@@ -461,6 +474,65 @@ chainSelSync cdb@CDB{..} (ChainSelAddBlock BlockToAdd{blockToAdd = b, ..}) = do
   deliverProcessed tip =
     atomically $
       putTMVar varBlockProcessed (SuccesfullyAddedBlock tip)
+-- Process a Peras certificate by adding it to the PerasCertDB and potentially
+-- performing chain selection if a candidate is now better than our selection.
+chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do
+  curChain <- lift $ atomically $ Query.getCurrentChain cdb
+  let immTip = castPoint $ AF.anchorPoint curChain
+
+  withEarlyExit_ $ do
+    -- Ignore the certificate if it boosts a block that is so old that it can't
+    -- influence our selection.
+    when (pointSlot boostedBlock < pointSlot immTip) $ do
+      lift $ lift $ traceWith tracer $ IgnorePerasCertTooOld certRound boostedBlock immTip
+      exitEarly
+
+    -- Add the certificate to the PerasCertDB.
+    lift (lift $ PerasCertDB.addCert cdbPerasCertDB cert) >>= \case
+      PerasCertDB.AddedPerasCertToDB -> pure ()
+      -- If it already is in the PerasCertDB, we are done.
+      PerasCertDB.PerasCertAlreadyInDB -> exitEarly
+
+    -- If the certificate boosts a block on our current chain (including the
+    -- anchor), then it just makes our selection even stronger.
+    when (AF.withinFragmentBounds (castPoint boostedBlock) curChain) $ do
+      lift $ lift $ traceWith tracer $ PerasCertBoostsCurrentChain certRound boostedBlock
+      exitEarly
+
+    boostedHash <- case pointHash boostedBlock of
+      -- If the certificate boosts the Genesis point, then it can not influence
+      -- chain selection as all chains contain it.
+      GenesisHash -> do
+        lift $ lift $ traceWith tracer $ PerasCertBoostsGenesis certRound
+        exitEarly
+      -- Otherwise, the certificate boosts a block potentially on a (future)
+      -- candidate.
+      BlockHash boostedHash -> pure boostedHash
+    boostedHdr <-
+      lift (lift $ VolatileDB.getBlockComponent cdbVolatileDB GetHeader boostedHash) >>= \case
+        -- If we have not (yet) received the boosted block, we don't need to do
+        -- anything further for now regarding chain selection. Once we receive
+        -- it, the additional weight of the certificate is taken into account.
+        Nothing -> do
+          lift $ lift $ traceWith tracer $ PerasCertBoostsBlockNotYetReceived certRound boostedBlock
+          exitEarly
+        Just boostedHdr -> pure boostedHdr
+
+    -- Trigger chain selection for the boosted block.
+    lift $ lift $ traceWith tracer $ ChainSelectionForBoostedBlock certRound boostedBlock
+    lift $ chainSelectionForBlock cdb BlockCache.empty boostedHdr noPunishment
+
+  -- Deliver promise indicating that we processed the cert.
+  lift $ atomically $ putTMVar varProcessed ()
+ where
+  tracer :: Tracer m (TraceAddPerasCertEvent blk)
+  tracer = TraceAddPerasCertEvent >$< cdbTracer
+
+  certRound :: PerasRoundNo
+  certRound = perasCertRound cert
+
+  boostedBlock :: Point blk
+  boostedBlock = perasCertBoostedBlock cert
 
 -- | Return 'True' when the given header should be ignored when adding it
 -- because it is too old, i.e., we wouldn't be able to switch to a chain
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
index cc5c33343e..559f01a116 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
@@ -55,6 +55,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types
   , ChainSelMessage (..)
   , ChainSelQueue -- opaque
   , addBlockToAdd
+  , addPerasCertToQueue
   , addReprocessLoEBlocks
   , closeChainSelQueue
   , getChainSelMessage
@@ -66,6 +67,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types
     -- * Trace types
   , SelectionChangedInfo (..)
   , TraceAddBlockEvent (..)
+  , TraceAddPerasCertEvent (..)
   , TraceChainSelStarvationEvent (..)
   , TraceCopyToImmutableDBEvent (..)
   , TraceEvent (..)
@@ -83,7 +85,6 @@ import Control.ResourceRegistry
 import Control.Tracer
 import Data.Foldable (traverse_)
 import Data.Map.Strict (Map)
-import Data.Maybe (mapMaybe)
 import Data.Maybe.Strict (StrictMaybe (..))
 import Data.MultiSet (MultiSet)
 import qualified Data.MultiSet as MultiSet
@@ -104,6 +105,7 @@ import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( AddBlockPromise (..)
   , AddBlockResult (..)
+  , AddPerasCertPromise (..)
   , ChainDbError (..)
   , ChainSelectionPromise (..)
   , ChainType
@@ -549,6 +551,11 @@ data BlockToAdd m blk = BlockToAdd
 data ChainSelMessage m blk
   = -- | Add a new block
     ChainSelAddBlock !(BlockToAdd m blk)
+  | -- | Add a Peras certificate
+    ChainSelAddPerasCert
+      !(PerasCert blk)
+      -- | Used for 'AddPerasCertPromise'.
+      !(StrictTMVar m ())
   | -- | Reprocess blocks that have been postponed by the LoE.
     ChainSelReprocessLoEBlocks
       -- | Used for 'ChainSelectionPromise'.
@@ -597,6 +604,28 @@ addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish
       , blockProcessed = readTMVar varBlockProcessed
       }
 
+-- | Add a Peras certificate to the background queue.
+addPerasCertToQueue ::
+  (IOLike m, StandardHash blk) =>
+  Tracer m (TraceAddPerasCertEvent blk) ->
+  ChainSelQueue m blk ->
+  PerasCert blk ->
+  m (AddPerasCertPromise m)
+addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do
+  varProcessed <- newEmptyTMVarIO
+  traceWith tracer $ addedToQueue RisingEdge
+  queueSize <- atomically $ do
+    writeTBQueue varChainSelQueue $ ChainSelAddPerasCert cert varProcessed
+    lengthTBQueue varChainSelQueue
+  traceWith tracer $ addedToQueue $ FallingEdgeWith $ fromIntegral queueSize
+  pure
+    AddPerasCertPromise
+      { waitPerasCertProcessed = atomically $ takeTMVar varProcessed
+      }
+ where
+  addedToQueue =
+    AddedPerasCertToQueue (perasCertRound cert) (perasCertBoostedBlock cert)
+
 -- | Try to add blocks again that were postponed due to the LoE.
 addReprocessLoEBlocks ::
   IOLike m =>
@@ -651,23 +680,21 @@ getChainSelMessage starvationTracer starvationVar chainSelQueue =
       let pt = blockRealPoint block
       traceWith starvationTracer $ ChainSelStarvation (FallingEdgeWith pt)
       atomically . writeTVar starvationVar . ChainSelStarvationEndedAt =<< getMonotonicTime
+    ChainSelAddPerasCert{} -> pure ()
     ChainSelReprocessLoEBlocks{} -> pure ()
 
 -- | Flush the 'ChainSelQueue' queue and notify the waiting threads.
 closeChainSelQueue :: IOLike m => ChainSelQueue m blk -> STM m ()
 closeChainSelQueue ChainSelQueue{varChainSelQueue = queue} = do
-  as <- mapMaybe blockAdd <$> flushTBQueue queue
-  traverse_
-    ( \a ->
-        tryPutTMVar
-          (varBlockProcessed a)
-          (FailedToAddBlock "Queue flushed")
-    )
-    as
+  traverse_ deliverPromise =<< flushTBQueue queue
  where
-  blockAdd = \case
-    ChainSelAddBlock ab -> Just ab
-    ChainSelReprocessLoEBlocks _ -> Nothing
+  deliverPromise = \case
+    ChainSelAddBlock ab ->
+      tryPutTMVar (varBlockProcessed ab) (FailedToAddBlock "Queue flushed")
+    ChainSelAddPerasCert _cert varProcessed ->
+      tryPutTMVar varProcessed ()
+    ChainSelReprocessLoEBlocks varProcessed ->
+      tryPutTMVar varProcessed ()
 
 -- | To invoke when the given 'ChainSelMessage' has been processed by ChainSel.
 -- This is used to remove the respective point from the multiset of points in
@@ -680,6 +707,8 @@ processedChainSelMessage ::
 processedChainSelMessage ChainSelQueue{varChainSelPoints} = \case
   ChainSelAddBlock BlockToAdd{blockToAdd = blk} ->
     modifyTVar varChainSelPoints $ MultiSet.delete (blockRealPoint blk)
+  ChainSelAddPerasCert{} ->
+    pure ()
   ChainSelReprocessLoEBlocks{} ->
     pure ()
 
@@ -724,6 +753,7 @@ data TraceEvent blk
   | TracePerasCertDbEvent (PerasCertDB.TraceEvent blk)
   | TraceLastShutdownUnclean
   | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk)
+  | TraceAddPerasCertEvent (TraceAddPerasCertEvent blk)
   deriving Generic
 
 deriving instance
@@ -1030,3 +1060,26 @@ data TraceIteratorEvent blk
 newtype TraceChainSelStarvationEvent blk
   = ChainSelStarvation (Enclosing' (RealPoint blk))
   deriving (Generic, Eq, Show)
+
+data TraceAddPerasCertEvent blk
+  = -- | The Peras certificate from the given round boosting the given block was
+    -- added to the queue. The size of the queue is included.
+    AddedPerasCertToQueue PerasRoundNo (Point blk) (Enclosing' Word)
+  | -- | The Peras certificate from the given round boosting the given block was
+    -- popped from the queue.
+    PoppedPerasCertFromQueue PerasRoundNo (Point blk)
+  | -- | The Peras certificate from the given round boosting the given block was
+    -- too old, ie its slot was older than the current immutable slot (the third
+    -- argument).
+    IgnorePerasCertTooOld PerasRoundNo (Point blk) (Point blk)
+  | -- | The Peras certificate from the given round boosts a block on the
+    -- current selection.
+    PerasCertBoostsCurrentChain PerasRoundNo (Point blk)
+  | -- | The Peras certificate from the given round boosts the Genesis point.
+    PerasCertBoostsGenesis PerasRoundNo
+  | -- | The Peras certificate from the given round boosts a block that we have
+    -- not (yet) received.
+    PerasCertBoostsBlockNotYetReceived PerasRoundNo (Point blk)
+  | -- | Perform chain selection for a block boosted by a Peras certificate.
+    ChainSelectionForBoostedBlock PerasRoundNo (Point blk)
+  deriving (Generic, Eq, Show)
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
index ac125c07f9..562eb80337 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
@@ -1352,6 +1352,8 @@ deriving instance SOP.Generic (PerasCertDB.TraceEvent blk)
 deriving instance SOP.HasDatatypeInfo (PerasCertDB.TraceEvent blk)
 deriving anyclass instance SOP.Generic (TraceChainSelStarvationEvent blk)
 deriving anyclass instance SOP.HasDatatypeInfo (TraceChainSelStarvationEvent blk)
+deriving anyclass instance SOP.Generic (TraceAddPerasCertEvent blk)
+deriving anyclass instance SOP.HasDatatypeInfo (TraceAddPerasCertEvent blk)
 
 data Tag
   = TagGetIsValidJust
@@ -1779,6 +1781,7 @@ traceEventName = \case
   TracePerasCertDbEvent ev -> "PerasCertDB." <> constrName ev
   TraceLastShutdownUnclean -> "LastShutdownUnclean"
   TraceChainSelStarvationEvent ev -> "ChainSelStarvation." <> constrName ev
+  TraceAddPerasCertEvent ev -> "AddPerasCert." <> constrName ev
 
 mkArgs ::
   IOLike m =>

From 7df2c922862acae4df8e52d2c956215ba8771b26 Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 24 Jul 2025 14:39:00 +0200
Subject: [PATCH 38/42] MockChainSel: switch to weighted chain selection

---
 .../Consensus/Protocol/MockChainSel.hs        | 28 ++++++++-----------
 .../Test/Util/TestBlock.hs                    | 14 ++++++++--
 .../MiniProtocol/LocalStateQuery/Server.hs    |  3 +-
 .../Test/Ouroboros/Storage/ChainDB/Model.hs   | 15 ++++++++--
 4 files changed, 38 insertions(+), 22 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs
index 341a916495..676f01f023 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs
@@ -9,9 +9,9 @@ module Ouroboros.Consensus.Protocol.MockChainSel
 import Data.List (sortOn)
 import Data.Maybe (listToMaybe, mapMaybe)
 import Data.Ord (Down (..))
+import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView (..), WithEmptyFragment (..))
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Network.Mock.Chain (Chain)
-import qualified Ouroboros.Network.Mock.Chain as Chain
 
 {-------------------------------------------------------------------------------
   Chain selection
@@ -33,8 +33,9 @@ selectChain ::
   forall proxy p hdr l.
   ConsensusProtocol p =>
   proxy p ->
-  ChainOrderConfig (SelectView p) ->
-  (hdr -> SelectView p) ->
+  ChainOrderConfig (WeightedSelectView p) ->
+  -- | Compute the 'WeightedSelectView' of a chain.
+  (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) ->
   -- | Our chain
   Chain hdr ->
   -- | Upstream chains
@@ -51,24 +52,19 @@ selectChain _ cfg view ours =
   -- extract the 'SelectView' of the tip of the candidate.
   selectPreferredCandidate ::
     (Chain hdr, l) ->
-    Maybe (SelectView p, (Chain hdr, l))
-  selectPreferredCandidate x@(cand, _) =
-    case (Chain.head ours, Chain.head cand) of
-      (Nothing, Just candTip) ->
-        Just (view candTip, x)
-      (Just ourTip, Just candTip)
-        | let candView = view candTip
-        , preferCandidate cfg (view ourTip) candView ->
-            Just (candView, x)
-      _otherwise ->
-        Nothing
+    Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
+  selectPreferredCandidate x@(cand, _)
+    | let candView = view cand
+    , preferCandidate cfg (view ours) candView =
+        Just (candView, x)
+    | otherwise = Nothing
 
 -- | Chain selection on unvalidated chains
 selectUnvalidatedChain ::
   ConsensusProtocol p =>
   proxy p ->
-  ChainOrderConfig (SelectView p) ->
-  (hdr -> SelectView p) ->
+  ChainOrderConfig (WeightedSelectView p) ->
+  (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) ->
   Chain hdr ->
   [Chain hdr] ->
   Maybe (Chain hdr)
diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs
index f1f397011b..27a8d0c641 100644
--- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs
+++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs
@@ -139,6 +139,8 @@ import Ouroboros.Consensus.Ledger.Tables.Utils
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Node.ProtocolInfo
 import Ouroboros.Consensus.NodeId
+import Ouroboros.Consensus.Peras.SelectView (weightedSelectView)
+import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Protocol.BFT
 import Ouroboros.Consensus.Protocol.MockChainSel
@@ -859,15 +861,21 @@ treeToBlocks = Tree.flatten . blockTree
 treeToChains :: BlockTree -> [Chain TestBlock]
 treeToChains = map Chain.fromOldestFirst . allPaths . blockTree
 
-treePreferredChain :: BlockTree -> Chain TestBlock
-treePreferredChain =
+treePreferredChain ::
+  PerasWeightSnapshot TestBlock ->
+  BlockTree ->
+  Chain TestBlock
+treePreferredChain weights =
   fromMaybe Genesis
     . selectUnvalidatedChain
       (Proxy @(BlockProtocol TestBlock))
       (() :: ChainOrderConfig (SelectView (BlockProtocol TestBlock)))
-      (\hdr -> SelectView (blockNo hdr) NoTiebreaker)
+      (weightedSelectView bcfg weights . Chain.toAnchoredFragment . fmap getHeader)
       Genesis
     . treeToChains
+ where
+  -- inconsequential for this function
+  bcfg = TestBlockConfig (NumCoreNodes 0)
 
 instance Show BlockTree where
   show (BlockTree t) = Tree.drawTree (fmap show t)
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
index efafdc18aa..d0c8b4adbc 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
@@ -37,6 +37,7 @@ import Ouroboros.Consensus.Ledger.Query (Query (..))
 import Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server
 import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
 import Ouroboros.Consensus.NodeId
+import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot)
 import Ouroboros.Consensus.Protocol.BFT
 import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache
 import Ouroboros.Consensus.Storage.ImmutableDB.Stream hiding
@@ -100,7 +101,7 @@ prop_localStateQueryServer ::
 prop_localStateQueryServer k bt p (Positive (Small n)) = checkOutcome k chain actualOutcome
  where
   chain :: Chain TestBlock
-  chain = treePreferredChain bt
+  chain = treePreferredChain emptyPerasWeightSnapshot bt
 
   points :: [Target (Point TestBlock)]
   points =
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
index 2ee8a755a3..76c0df6992 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
@@ -108,6 +108,7 @@ import Ouroboros.Consensus.HeaderValidation
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.Extended
 import Ouroboros.Consensus.Ledger.SupportsProtocol
+import Ouroboros.Consensus.Peras.SelectView
 import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Protocol.MockChainSel
@@ -532,9 +533,15 @@ chainSelection cfg m =
       . selectChain
         (Proxy @(BlockProtocol blk))
         (projectChainOrderConfig (configBlock cfg))
-        (selectView (configBlock cfg) . getHeader)
+        ( weightedSelectView (configBlock cfg) weights
+            . Chain.toAnchoredFragment
+            . fmap getHeader
+        )
         (currentChain m)
       $ consideredCandidates
+   where
+    -- TODO enrich with Peras weights/certs
+    weights = emptyPerasWeightSnapshot
 
   -- We update the set of valid blocks with all valid blocks on all candidate
   -- chains that are considered by the modeled chain selection. This ensures
@@ -1112,7 +1119,11 @@ wipeVolatileDB cfg m =
       $ selectChain
         (Proxy @(BlockProtocol blk))
         (projectChainOrderConfig (configBlock cfg))
-        (selectView (configBlock cfg) . getHeader)
+        -- Weight is inconsequential as there is only a single candidate.
+        ( weightedSelectView (configBlock cfg) emptyPerasWeightSnapshot
+            . Chain.toAnchoredFragment
+            . fmap getHeader
+        )
         Chain.genesis
       $ snd
       $ validChains cfg m (immutableDbBlocks m)

From 8a299a956945ce4b687ea9f8847d1c89b19f604e Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Thu, 24 Jul 2025 15:52:56 +0200
Subject: [PATCH 39/42] ChainDB q-s-m: test weighted chain selection

---
 .../Consensus/Util/AnchoredFragment.hs        |  37 ++++--
 .../Test/Util/Orphans/ToExpr.hs               |   6 +
 .../Test/Ouroboros/Storage/ChainDB/Model.hs   | 121 ++++++++++++------
 .../Ouroboros/Storage/ChainDB/Model/Test.hs   |   5 +-
 .../Ouroboros/Storage/ChainDB/StateMachine.hs |  41 +++++-
 5 files changed, 155 insertions(+), 55 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs
index a3020f767f..0eca5b8e03 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs
@@ -10,7 +10,7 @@ module Ouroboros.Consensus.Util.AnchoredFragment
   ( compareAnchoredFragments
   , compareHeadBlockNo
   , cross
-  , forksAtMostKBlocks
+  , forksAtMostKWeight
   , preferAnchoredCandidate
   , stripCommonPrefix
   ) where
@@ -19,7 +19,6 @@ import Data.Foldable (toList)
 import qualified Data.Foldable1 as F1
 import Data.Function (on)
 import qualified Data.List.NonEmpty as NE
-import Data.Word (Word64)
 import GHC.Stack
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Peras.SelectView
@@ -55,20 +54,32 @@ compareHeadBlockNo ::
   Ordering
 compareHeadBlockNo = compare `on` AF.headBlockNo
 
-forksAtMostKBlocks ::
-  HasHeader b =>
-  -- | How many blocks can it fork?
-  Word64 ->
-  -- | Our chain.
+-- | Check that we can switch from @ours@ to @theirs@ by rolling back our chain
+-- by at most @k@ weight.
+--
+-- If @ours@ and @cand@ do not intersect, this returns 'False'. If they do
+-- intersect, then we check that the suffix of @ours@ after the intersection has
+-- total weight at most @k@.
+forksAtMostKWeight ::
+  ( StandardHash blk
+  , HasHeader b
+  , HeaderHash blk ~ HeaderHash b
+  ) =>
+  PerasWeightSnapshot blk ->
+  -- | By how much weight can we roll back our chain at most?
+  PerasWeight ->
+  -- | Our chain @ours@.
   AnchoredFragment b ->
-  -- | Their chain
+  -- | Their chain @theirs@.
   AnchoredFragment b ->
-  -- | Indicates whether their chain forks at most the
-  -- specified number of blocks.
+  -- | Indicates whether their chain forks at most the given the amount of
+  -- weight. Returns 'False' if the two fragments do not intersect.
   Bool
-forksAtMostKBlocks k ours theirs = case ours `AF.intersect` theirs of
-  Nothing -> False
-  Just (_, _, ourSuffix, _) -> fromIntegral (AF.length ourSuffix) <= k
+forksAtMostKWeight weights maxWeight ours theirs =
+  case ours `AF.intersect` theirs of
+    Nothing -> False
+    Just (_, _, ourSuffix, _) ->
+      totalWeightOfFragment weights ourSuffix <= maxWeight
 
 -- | Compare two (potentially empty!) 'AnchoredFragment's.
 --
diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs
index 6830141290..f883c7abdd 100644
--- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs
+++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs
@@ -119,6 +119,12 @@ instance ToExpr FsError where
 
 deriving instance ToExpr a => ToExpr (LoE a)
 
+deriving anyclass instance ToExpr PerasRoundNo
+
+deriving anyclass instance ToExpr PerasWeight
+
+deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk)
+
 {-------------------------------------------------------------------------------
   si-timers
 --------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
index 76c0df6992..37bfa49085 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs
@@ -25,6 +25,7 @@ module Test.Ouroboros.Storage.ChainDB.Model
   , addBlock
   , addBlockPromise
   , addBlocks
+  , addPerasCert
   , empty
 
     -- * Queries
@@ -44,7 +45,7 @@ module Test.Ouroboros.Storage.ChainDB.Model
   , invalid
   , isOpen
   , isValid
-  , lastK
+  , maxPerasRoundNo
   , tipBlock
   , tipPoint
   , volatileChain
@@ -90,6 +91,7 @@ import Control.Monad.Except (runExcept)
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Containers.ListUtils (nubOrdOn)
+import Data.Foldable (foldMap')
 import Data.Function (on, (&))
 import Data.Functor (($>), (<&>))
 import Data.List (isInfixOf, isPrefixOf, sortBy)
@@ -100,7 +102,6 @@ import Data.Proxy
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.TreeDiff
-import Data.Word (Word64)
 import GHC.Generics (Generic)
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
@@ -147,6 +148,7 @@ data Model blk = Model
   -- ^ The VolatileDB
   , immutableDbChain :: Chain blk
   -- ^ The ImmutableDB
+  , perasCerts :: Map PerasRoundNo (PerasCert blk)
   , cps :: CPS.ChainProducerState blk
   , currentLedger :: ExtLedgerState blk EmptyMK
   , initLedger :: ExtLedgerState blk EmptyMK
@@ -233,72 +235,78 @@ tipPoint = maybe GenesisPoint blockPoint . tipBlock
 getMaxSlotNo :: HasHeader blk => Model blk -> MaxSlotNo
 getMaxSlotNo = foldMap (MaxSlotNo . blockSlot) . blocks
 
-lastK ::
-  HasHeader a =>
-  SecurityParam ->
-  -- | Provided since `AnchoredFragment` is not a functor
-  (blk -> a) ->
-  Model blk ->
-  AnchoredFragment a
-lastK (SecurityParam k) f =
-  Fragment.anchorNewest (unNonZero k)
-    . Chain.toAnchoredFragment
-    . fmap f
-    . currentChain
-
--- | Actual number of blocks that can be rolled back. Equal to @k@, except
--- when:
+-- | Actual amount of weight that can be rolled back. This can non-trivially
+-- smaller than @k@ in the following cases:
 --
--- * Near genesis, the chain might not be @k@ blocks long yet.
--- * After VolatileDB corruption, the whole chain might be >= @k@ blocks, but
---   the tip of the ImmutableDB might be closer than @k@ blocks away from the
---   current chain's tip.
-maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> Word64
+-- * Near genesis, the chain might not have grown sufficiently yet.
+-- * After VolatileDB corruption, the whole chain might have more than weight
+--   @k@, but the tip of the ImmutableDB might be buried under significantly
+--   less than weight @k@ worth of blocks.
+maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> PerasWeight
 maxActualRollback k m =
-  fromIntegral
-    . length
+  foldMap' (weightBoostOfPoint weights)
     . takeWhile (/= immutableTipPoint)
     . map blockPoint
     . Chain.toNewestFirst
     . currentChain
     $ m
  where
+  weights = perasWeights m
+
   immutableTipPoint = Chain.headPoint (immutableChain k m)
 
 -- | Return the immutable prefix of the current chain.
 --
 -- This is the longest of the given two chains:
 --
--- 1. The current chain with the last @k@ blocks dropped.
+-- 1. The current chain with the longest suffix of weight at most @k@ dropped.
 -- 2. The chain formed by the blocks in 'immutableDbChain', i.e., the
 --    \"ImmutableDB\". We need to take this case in consideration because the
 --    VolatileDB might have been wiped.
 --
--- We need this because we do not allow rolling back more than @k@ blocks, but
+-- We need this because we do not allow rolling back more than weight @k@, but
 -- the background thread copying blocks from the VolatileDB to the ImmutableDB
 -- might not have caught up yet. This means we cannot use the tip of the
 -- ImmutableDB to know the most recent \"immutable\" block.
 immutableChain ::
+  forall blk.
+  HasHeader blk =>
   SecurityParam ->
   Model blk ->
   Chain blk
-immutableChain (SecurityParam k) m =
+immutableChain k m =
   maxBy
+    -- As one of the two chains is a prefix of the other, Peras weight doesn't
+    -- matter here.
     Chain.length
-    (Chain.drop (fromIntegral $ unNonZero k) (currentChain m))
+    (dropAtMostWeight (maxRollbackWeight k) (currentChain m))
     (immutableDbChain m)
  where
   maxBy f a b
     | f a >= f b = a
     | otherwise = b
 
+  weights = perasWeights m
+
+  -- Drop the longest suffix with at most the given weight.
+  dropAtMostWeight :: PerasWeight -> Chain blk -> Chain blk
+  dropAtMostWeight budget = go mempty
+   where
+    go w = \case
+      Genesis -> Genesis
+      c@(c' :> b)
+        | w' <= budget -> go w' c'
+        | otherwise -> c
+       where
+        w' = w <> PerasWeight 1 <> weightBoostOfPoint weights (blockPoint b)
+
 -- | Return the volatile suffix of the current chain.
 --
 -- The opposite of 'immutableChain'.
 --
 -- This is the shortest of the given two chain fragments:
 --
--- 1. The last @k@ blocks of the current chain.
+-- 1. The longest suffix of the current chain with weight at most @k@.
 -- 2. The suffix of the current chain not part of the 'immutableDbChain', i.e.,
 --    the \"ImmutableDB\".
 volatileChain ::
@@ -370,6 +378,17 @@ isValid = flip getIsValid
 getLoEFragment :: Model blk -> LoE (AnchoredFragment blk)
 getLoEFragment = loeFragment
 
+perasWeights :: StandardHash blk => Model blk -> PerasWeightSnapshot blk
+perasWeights =
+  mkPerasWeightSnapshot
+    -- TODO make boost per cert configurable
+    . fmap (\c -> (perasCertBoostedBlock c, boostPerCert))
+    . Map.elems
+    . perasCerts
+
+maxPerasRoundNo :: Model blk -> Maybe PerasRoundNo
+maxPerasRoundNo m = fst <$> Map.lookupMax (perasCerts m)
+
 {-------------------------------------------------------------------------------
   Construction
 -------------------------------------------------------------------------------}
@@ -383,6 +402,7 @@ empty loe initLedger =
   Model
     { volatileDbBlocks = Map.empty
     , immutableDbChain = Chain.Genesis
+    , perasCerts = Map.empty
     , cps = CPS.initChainProducerState Chain.Genesis
     , currentLedger = initLedger
     , initLedger = initLedger
@@ -422,6 +442,23 @@ addBlock cfg blk m
       -- If it's an invalid block we've seen before, ignore it.
       Map.member (blockHash blk) (invalid m)
 
+addPerasCert ::
+  forall blk.
+  (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) =>
+  TopLevelConfig blk ->
+  PerasCert blk ->
+  Model blk ->
+  Model blk
+addPerasCert cfg cert m
+  -- Do not alter the model when a certificate for that round already exists.
+  | Map.member certRound (perasCerts m) = m
+  | otherwise =
+      chainSelection
+        cfg
+        m{perasCerts = Map.insert certRound cert (perasCerts m)}
+ where
+  certRound = perasCertRound cert
+
 chainSelection ::
   forall blk.
   ( LedgerTablesAreTrivial (ExtLedgerState blk)
@@ -434,6 +471,7 @@ chainSelection cfg m =
   Model
     { volatileDbBlocks = volatileDbBlocks m
     , immutableDbChain = immutableDbChain m
+    , perasCerts = perasCerts m
     , cps = CPS.switchFork newChain (cps m)
     , currentLedger = newLedger
     , initLedger = initLedger m
@@ -533,15 +571,12 @@ chainSelection cfg m =
       . selectChain
         (Proxy @(BlockProtocol blk))
         (projectChainOrderConfig (configBlock cfg))
-        ( weightedSelectView (configBlock cfg) weights
+        ( weightedSelectView (configBlock cfg) (perasWeights m)
             . Chain.toAnchoredFragment
             . fmap getHeader
         )
         (currentChain m)
       $ consideredCandidates
-   where
-    -- TODO enrich with Peras weights/certs
-    weights = emptyPerasWeightSnapshot
 
   -- We update the set of valid blocks with all valid blocks on all candidate
   -- chains that are considered by the modeled chain selection. This ensures
@@ -871,12 +906,9 @@ validChains cfg m bs =
   sortChains =
     sortBy $
       flip
-        ( Fragment.compareAnchoredFragments (configBlock cfg) weights
+        ( Fragment.compareAnchoredFragments (configBlock cfg) (perasWeights m)
             `on` (Chain.toAnchoredFragment . fmap getHeader)
         )
-   where
-    -- TODO enrich with Peras weights/certs
-    weights = emptyPerasWeightSnapshot
 
   classify ::
     ValidatedChain blk ->
@@ -910,7 +942,11 @@ between k from to m = do
   fork <- errFork
   -- See #871.
   if partOfCurrentChain fork
-    || Fragment.forksAtMostKBlocks (maxActualRollback k m) currentFrag fork
+    || Fragment.forksAtMostKWeight
+      (perasWeights m)
+      (maxActualRollback k m)
+      currentFrag
+      fork
     then return $ Fragment.toOldestFirst fork
     -- We cannot stream from an old fork
     else Left $ ForkTooOld from
@@ -1050,6 +1086,7 @@ garbageCollect ::
 garbageCollect secParam m@Model{..} =
   m
     { volatileDbBlocks = Map.filter (not . collectable) volatileDbBlocks
+    -- TODO garbage collection Peras certs?
     }
  where
   -- TODO what about iterators that will stream garbage collected blocks?
@@ -1101,6 +1138,14 @@ wipeVolatileDB cfg m =
   m' =
     (closeDB m)
       { volatileDbBlocks = Map.empty
+      , -- TODO: Currently, the SUT has no persistence of Peras certs across
+        -- restarts, but this will change. There are at least two options:
+        --
+        --  * Change this command to mean "wipe volatile state" (including
+        --    volatile certificates)
+        --
+        --  * Add a separate "Wipe volatile certs".
+        perasCerts = Map.empty
       , cps = CPS.switchFork newChain (cps m)
       , currentLedger = newLedger
       , invalid = Map.empty
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs
index bcb76e088d..0b2410f68f 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs
@@ -22,7 +22,6 @@
 -- chain DB, we always pick the most preferred chain.
 module Test.Ouroboros.Storage.ChainDB.Model.Test (tests) where
 
-import Cardano.Ledger.BaseTypes (unNonZero)
 import GHC.Stack
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
@@ -97,13 +96,13 @@ prop_alwaysPickPreferredChain bt p =
 
   curFragment = Chain.toAnchoredFragment (getHeader <$> current)
 
-  SecurityParam k = configSecurityParam singleNodeTestConfig
+  k = configSecurityParam singleNodeTestConfig
 
   bcfg = configBlock singleNodeTestConfig
 
   preferCandidate' candidate =
     AF.preferAnchoredCandidate bcfg weights curFragment candFragment
-      && AF.forksAtMostKBlocks (unNonZero k) curFragment candFragment
+      && AF.forksAtMostKWeight weights (maxRollbackWeight k) curFragment candFragment
    where
     candFragment = Chain.toAnchoredFragment (getHeader <$> candidate)
 
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
index 562eb80337..2dbfe28e7f 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
@@ -179,6 +179,7 @@ import Test.Util.WithEq
 -- | Commands
 data Cmd blk it flr
   = AddBlock blk
+  | AddPerasCert (PerasCert blk)
   | GetCurrentChain
   | GetTipBlock
   | GetTipHeader
@@ -403,8 +404,9 @@ run ::
   Cmd blk (TestIterator m blk) (TestFollower m blk) ->
   m (Success blk (TestIterator m blk) (TestFollower m blk))
 run cfg env@ChainDBEnv{varDB, ..} cmd =
-  readTVarIO varDB >>= \st@ChainDBState{chainDB = ChainDB{..}, internal} -> case cmd of
+  readTVarIO varDB >>= \st@ChainDBState{chainDB = chainDB@ChainDB{..}, internal} -> case cmd of
     AddBlock blk -> Point <$> advanceAndAdd st blk
+    AddPerasCert cert -> Unit <$> addPerasCertSync chainDB cert
     GetCurrentChain -> Chain <$> atomically getCurrentChain
     GetTipBlock -> MbBlock <$> getTipBlock
     GetTipHeader -> MbHeader <$> getTipHeader
@@ -640,6 +642,7 @@ runPure ::
   (Resp blk IteratorId FollowerId, DBModel blk)
 runPure cfg = \case
   AddBlock blk -> ok Point $ update (add blk)
+  AddPerasCert cert -> ok Unit $ ((),) . update (Model.addPerasCert cfg cert)
   GetCurrentChain -> ok Chain $ query (Model.volatileChain k getHeader)
   GetTipBlock -> ok MbBlock $ query Model.tipBlock
   GetTipHeader -> ok MbHeader $ query (fmap getHeader . Model.tipBlock)
@@ -911,6 +914,11 @@ generator loe genBlock m@Model{..} =
   At
     <$> frequency
       [ (30, genAddBlock)
+      , let freq = case loe of
+              LoEDisabled -> 10
+              -- The LoE does not yet support Peras.
+              LoEEnabled () -> 0
+         in (freq, AddPerasCert <$> genAddPerasCert)
       , (if empty then 1 else 10, return GetCurrentChain)
       , --    , (if empty then 1 else 10, return GetLedgerDB)
         (if empty then 1 else 10, return GetTipBlock)
@@ -1036,6 +1044,20 @@ generator loe genBlock m@Model{..} =
 
   genAddBlock = AddBlock <$> genBlock m
 
+  genAddPerasCert :: Gen (PerasCert blk)
+  genAddPerasCert = do
+    -- TODO chain condition?
+    blk <- genBlock m
+    let pcCertRound = case Model.maxPerasRoundNo dbModel of
+          Nothing -> PerasRoundNo 0
+          Just (PerasRoundNo r) -> PerasRoundNo (r + 1)
+        cert =
+          PerasCert
+            { pcCertRound
+            , pcCertBoostedBlock = blockPoint blk
+            }
+    pure cert
+
   genBounds :: Gen (StreamFrom blk, StreamTo blk)
   genBounds =
     frequency
@@ -1360,6 +1382,7 @@ data Tag
   | TagGetIsValidNothing
   | TagChainSelReprocessChangedSelection
   | TagChainSelReprocessKeptSelection
+  | TagSwitchedToShorterChain
   deriving (Show, Eq)
 
 -- | Predicate on events
@@ -1386,6 +1409,7 @@ tag =
     , tagGetIsValidNothing
     , tagChainSelReprocess TagChainSelReprocessChangedSelection (/=)
     , tagChainSelReprocess TagChainSelReprocessKeptSelection (==)
+    , tagSwitchedToShorterChain
     ]
  where
   tagGetIsValidJust :: EventPred m
@@ -1410,6 +1434,21 @@ tag =
           Left t
     _ -> Right $ tagChainSelReprocess t test
 
+  -- Tag this test case if we ever switch from a longer to a shorter chain in a
+  -- non-degenerate case.
+  tagSwitchedToShorterChain :: EventPred m
+  tagSwitchedToShorterChain = C.predicate $ \case
+    ev
+      | case unAt $ eventCmd ev of
+          -- Wiping the VolatileDB is not interesting here.
+          WipeVolatileDB{} -> False
+          _ -> True
+      , ((>) `on` curChainLength) (eventBefore ev) (eventAfter ev) ->
+          Left TagSwitchedToShorterChain
+      | otherwise -> Right tagSwitchedToShorterChain
+   where
+    curChainLength = Chain.length . Model.currentChain . dbModel
+
 -- | Step the model using a 'QSM.Command' (i.e., a command associated with
 -- an explicit set of variables)
 execCmd ::

From c971d39719d05a81bc95e9c608da1c5b60cf5bba Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Wed, 13 Aug 2025 18:53:09 +0200
Subject: [PATCH 40/42] Fix cabal-docspec

---
 .../Ouroboros/Consensus/Peras/Weight.hs            | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
index fed6d63844..783c3b6a04 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -71,7 +71,7 @@ emptyPerasWeightSnapshot = PerasWeightSnapshot Map.empty
 --
 -- >>> snap = mkPerasWeightSnapshot weights
 -- >>> snap
--- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
+-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
 mkPerasWeightSnapshot ::
   StandardHash blk =>
   [(Point blk, PerasWeight)] ->
@@ -96,7 +96,7 @@ mkPerasWeightSnapshot =
 --
 -- >>> snap = mkPerasWeightSnapshot weights
 -- >>> perasWeightSnapshotToList snap
--- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
+-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
 perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)]
 perasWeightSnapshotToList = Map.toAscList . getPerasWeightSnapshot
 
@@ -113,15 +113,15 @@ perasWeightSnapshotToList = Map.toAscList . getPerasWeightSnapshot
 --
 -- >>> snap0 = mkPerasWeightSnapshot weights
 -- >>> snap0
--- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 2)]
+-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 2)]
 --
 -- >>> snap1 = addToPerasWeightSnapshot (BlockPoint 3 "bar") (PerasWeight 2) snap0
 -- >>> snap1
--- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 2),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
+-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 2),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
 --
 -- >>> snap2 = addToPerasWeightSnapshot (BlockPoint 2 "foo") (PerasWeight 2) snap1
 -- >>> snap2
--- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
+-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
 addToPerasWeightSnapshot ::
   StandardHash blk =>
   Point blk ->
@@ -150,10 +150,10 @@ addToPerasWeightSnapshot pt weight =
 -- >>> snap = mkPerasWeightSnapshot weights
 --
 -- >>> prunePerasWeightSnapshot (SlotNo 2) snap
--- [(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
+-- [(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
 --
 -- >>> prunePerasWeightSnapshot (SlotNo 3) snap
--- [(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)]
+-- [(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
 prunePerasWeightSnapshot ::
   SlotNo ->
   PerasWeightSnapshot blk ->

From 3244b1994d82ebde0b1f920c5dbfe0e001ecc81a Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Tue, 29 Jul 2025 23:27:58 +0200
Subject: [PATCH 41/42] PerasCertDB.StateMachine: generate chain-like boosted
 points

---
 .../Storage/PerasCertDB/StateMachine.hs       | 19 +++++++++++++++++--
 1 file changed, 17 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
index 917c96eef6..49684ea00d 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -94,12 +94,27 @@ instance StateModel Model where
     action ->
       model.open && case action of
         CloseDB -> True
-        -- Do not add equivocating certificates.
         AddCert cert -> all p model.certs
          where
-          p cert' = perasCertRound cert /= perasCertRound cert' || cert == cert'
+          p cert' = roundNoDeterminesCert && uniqueSlotNos
+           where
+            -- Do not add an equivocating certificate.
+            roundNoDeterminesCert =
+              perasCertRound cert == perasCertRound cert' =>> cert == cert'
+            -- Do not add a certificate boosting a block in a slot in which we
+            -- have already boosted another block.
+            uniqueSlotNos =
+              pointSlot boostPt == pointSlot boostPt' =>> boostPt == boostPt'
+             where
+              boostPt = perasCertBoostedBlock cert
+              boostPt' = perasCertBoostedBlock cert'
         GetWeightSnapshot -> True
         GarbageCollect _slot -> True
+   where
+    -- Logical implication
+    (=>>) :: Bool -> Bool -> Bool
+    a =>> b = not a || b
+    infixr 1 =>>
 
 deriving stock instance Show (Action Model a)
 deriving stock instance Eq (Action Model a)

From 18c93d4c62e08ee3920d09c4d2cec1b6639c97cc Mon Sep 17 00:00:00 2001
From: Alexander Esgen <alexander.esgen@iohk.io>
Date: Tue, 29 Jul 2025 19:49:35 +0200
Subject: [PATCH 42/42] Optimize `PerasWeightSnapshot`

---
 .../Ouroboros/Consensus/Peras/Weight.hs       | 159 +++++++++++++++---
 1 file changed, 139 insertions(+), 20 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
index 783c3b6a04..3896e3965c 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -1,9 +1,16 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoFieldSelectors #-}
 
 -- | Data structure for tracking the weight of blocks due to Peras boosts.
 module Ouroboros.Consensus.Peras.Weight
@@ -30,9 +37,9 @@ module Ouroboros.Consensus.Peras.Weight
   , takeVolatileSuffix
   ) where
 
-import Data.Foldable as Foldable (foldl')
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
+import Data.FingerTree.Strict (Measured (..), StrictFingerTree)
+import qualified Data.FingerTree.Strict as SFT
+import Data.Foldable as Foldable (foldl', toList)
 import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class
@@ -42,8 +49,20 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 
 -- | Data structure for tracking the weight of blocks due to Peras boosts.
+--
+-- PRECONDITION: All boosted points tracked by this data structure must reside
+-- on a single linear chain, and no boosted point may be an EBB. Otherwise,
+-- queries on this data structure may return incorrect results.
+--
+-- TODO: This isn't true across cooldowns.
+--
+-- For Peras (assuming an honest majority), this is guaranteed by the voting
+-- rules, together with the fact that Peras is not to be used with blocks where
+-- EBBs (if they can even exist) may receive boosts.
 newtype PerasWeightSnapshot blk = PerasWeightSnapshot
-  { getPerasWeightSnapshot :: Map (Point blk) PerasWeight
+  { getPerasWeightSnapshot :: StrictFingerTree PWSMeasure (BoostedPoint blk)
+  -- ^ INVARIANT: The slots of the boosted points are strictly monotonically
+  -- increasing.
   }
   deriving stock Eq
   deriving Generic
@@ -52,13 +71,56 @@ newtype PerasWeightSnapshot blk = PerasWeightSnapshot
 instance StandardHash blk => Show (PerasWeightSnapshot blk) where
   show = show . perasWeightSnapshotToList
 
+data PWSMeasure = PWSMeasure
+  { slot :: !(WithOrigin SlotNo)
+  -- ^ The maximum slot of all boosted points.
+  , weight :: !PerasWeight
+  -- ^ The sum of all weight boosts.
+  , size :: !Int
+  -- ^ The number of boosted points.
+  }
+  deriving stock Show
+
+instance Semigroup PWSMeasure where
+  m0 <> m1 =
+    PWSMeasure
+      { slot = m0.slot `max` m1.slot
+      , weight = m0.weight <> m1.weight
+      , size = m0.size + m1.size
+      }
+
+instance Monoid PWSMeasure where
+  mempty =
+    PWSMeasure
+      { slot = Origin
+      , weight = mempty
+      , size = 0
+      }
+
+data BoostedPoint blk = BoostedPoint
+  { pt :: !(Point blk)
+  , weight :: !PerasWeight
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass NoThunks
+
+instance Measured PWSMeasure (BoostedPoint blk) where
+  measure bp =
+    PWSMeasure
+      { slot = pointSlot bp.pt
+      , weight = bp.weight
+      , size = 1
+      }
+
 -- | An empty 'PerasWeightSnapshot' not containing any boosted blocks.
 emptyPerasWeightSnapshot :: PerasWeightSnapshot blk
-emptyPerasWeightSnapshot = PerasWeightSnapshot Map.empty
+emptyPerasWeightSnapshot = PerasWeightSnapshot SFT.empty
 
 -- | Create a weight snapshot from a list of boosted points with an associated
 -- weight. In case of duplicate points, their weights are combined.
 --
+-- PRECONDITION: The points lie on a singular linear chain.
+--
 -- >>> :{
 -- weights :: [(Point Blk, PerasWeight)]
 -- weights =
@@ -98,11 +160,15 @@ mkPerasWeightSnapshot =
 -- >>> perasWeightSnapshotToList snap
 -- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
 perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)]
-perasWeightSnapshotToList = Map.toAscList . getPerasWeightSnapshot
+perasWeightSnapshotToList (PerasWeightSnapshot ft) =
+  (\(BoostedPoint pt w) -> (pt, w)) <$> toList ft
 
 -- | Add weight for the given point to the 'PerasWeightSnapshot'. If the point
 -- already has some weight, it is added on top.
 --
+-- PRECONDITION: The point must lie on the same linear chain as the points
+-- already part of the 'PerasWeightSnapshot'.
+--
 -- >>> :{
 -- weights :: [(Point Blk, PerasWeight)]
 -- weights =
@@ -129,7 +195,17 @@ addToPerasWeightSnapshot ::
   PerasWeightSnapshot blk ->
   PerasWeightSnapshot blk
 addToPerasWeightSnapshot pt weight =
-  PerasWeightSnapshot . Map.insertWith (<>) pt weight . getPerasWeightSnapshot
+  \(PerasWeightSnapshot ft) ->
+    let (l, r) = SFT.split (\m -> m.slot > pointSlot pt) ft
+     in PerasWeightSnapshot $ insert l <> r
+ where
+  insert l = case SFT.viewr l of
+    SFT.EmptyR -> SFT.singleton $ BoostedPoint pt weight
+    l' SFT.:> BoostedPoint pt' weight'
+      -- We already track some weight of @pt@.
+      | pt == pt' -> l' SFT.|> BoostedPoint pt' (weight <> weight')
+      -- Otherwise, insert @pt@ as a new boosted point.
+      | otherwise -> l SFT.|> BoostedPoint pt weight
 
 -- | Prune the given 'PerasWeightSnapshot' by removing the weight of all blocks
 -- strictly older than the given slot.
@@ -158,11 +234,8 @@ prunePerasWeightSnapshot ::
   SlotNo ->
   PerasWeightSnapshot blk ->
   PerasWeightSnapshot blk
-prunePerasWeightSnapshot slot =
-  PerasWeightSnapshot . Map.dropWhileAntitone isTooOld . getPerasWeightSnapshot
- where
-  isTooOld :: Point blk -> Bool
-  isTooOld pt = pointSlot pt < NotOrigin slot
+prunePerasWeightSnapshot slot (PerasWeightSnapshot ft) =
+  PerasWeightSnapshot $ SFT.dropUntil (\m -> m.slot >= NotOrigin slot) ft
 
 -- | Get the weight boost for a point, or @'mempty' :: 'PerasWeight'@ otherwise.
 --
@@ -187,8 +260,12 @@ weightBoostOfPoint ::
   forall blk.
   StandardHash blk =>
   PerasWeightSnapshot blk -> Point blk -> PerasWeight
-weightBoostOfPoint (PerasWeightSnapshot weightByPoint) pt =
-  Map.findWithDefault mempty pt weightByPoint
+weightBoostOfPoint (PerasWeightSnapshot ft) pt =
+  case SFT.viewr $ SFT.takeUntil (\m -> m.slot > pointSlot pt) ft of
+    SFT.EmptyR -> mempty
+    _ SFT.:> BoostedPoint pt' weight'
+      | pt == pt' -> weight'
+      | otherwise -> mempty
 
 -- | Get the weight boost for a fragment, ie the sum of all
 -- 'weightBoostOfPoint' for all points on the fragment (excluding the anchor).
@@ -234,11 +311,53 @@ weightBoostOfFragment ::
   PerasWeightSnapshot blk ->
   AnchoredFragment h ->
   PerasWeight
-weightBoostOfFragment weightSnap frag =
-  -- TODO think about whether this could be done in sublinear complexity
-  foldMap
-    (weightBoostOfPoint weightSnap . castPoint . blockPoint)
-    (AF.toOldestFirst frag)
+weightBoostOfFragment (PerasWeightSnapshot ft) = \case
+  AF.Empty{} -> mempty
+  frag@(oldestHdr AF.:< _) -> (measure boostingInfix).weight
+   where
+    -- /Not/ @'AF.lastSlot' frag@ as we want to ignore the anchor.
+    oldestSlot = NotOrigin $ blockSlot oldestHdr
+
+    -- The infix of @ft@ which only contains boosted points which are also on
+    -- @frag@ (via @isOnFrag@).
+    boostingInfix :: StrictFingerTree PWSMeasure (BoostedPoint blk)
+    boostingInfix = case SFT.viewr ft' of
+      SFT.EmptyR -> ft'
+      t SFT.:> bp
+        | isOnFrag bp.pt -> ft'
+        | otherwise -> go 0 (measure ft').size t
+     where
+      -- The suffix of @ft@ without boosted points which are too old to be on
+      -- @frag@.
+      ft' = SFT.dropUntil (\m -> m.slot >= oldestSlot) ft
+
+      -- Binary search on @ft'@ to find the longest prefix of @ft'@ where all
+      -- boosted points satisfy @isOnFrag@.
+      --
+      -- PRECONDITION: @0 <= lb < ub@.
+      go ::
+        -- @lb@: All boosted points of the size @lb@ prefix of @ft'@ satisfy
+        -- @isOnFrag@.
+        Int ->
+        -- @ub@: At least one boosted point of the size @ub@ prefix of @ft'@
+        -- does not satisfy @isOnFrag@.
+        Int ->
+        -- The size @ub - 1@ prefix of @ft'@.
+        StrictFingerTree PWSMeasure (BoostedPoint blk) ->
+        StrictFingerTree PWSMeasure (BoostedPoint blk)
+      go lb ub t
+        | lb == ub - 1 = t
+        | isOnFrag t'Pt = go mid ub t
+        | otherwise = go lb mid t'
+       where
+        mid = (lb + ub) `div` 2
+        (t', t'Pt) = case SFT.viewr $ SFT.takeUntil (\m -> m.size > mid) ft' of
+          t'' SFT.:> bp -> (t'', bp.pt)
+          -- @ft'@ is non-empty here, and we have @0 <= lb < mid@.
+          SFT.EmptyR -> error "unreachable"
+
+    isOnFrag :: Point blk -> Bool
+    isOnFrag pt = AF.pointOnFragment (castPoint pt) frag
 
 -- | Get the total weight for a fragment, ie the length plus the weight boost
 -- ('weightBoostOfFragment') of the fragment.
@@ -339,7 +458,7 @@ takeVolatileSuffix ::
   AnchoredFragment h ->
   AnchoredFragment h
 takeVolatileSuffix snap secParam frag
-  | Map.null $ getPerasWeightSnapshot snap =
+  | SFT.null snap.getPerasWeightSnapshot =
       -- Optimize the case where Peras is disabled.
       AF.anchorNewest (unPerasWeight k) frag
   | hasAtMostWeightK frag = frag