diff --git a/cabal.project b/cabal.project
index e2c18aa305..46cf592d4a 100644
--- a/cabal.project
+++ b/cabal.project
@@ -56,6 +56,17 @@ allow-newer:
     , fin:QuickCheck
     , bin:QuickCheck
 
+source-repository-package
+   type: git
+   location: https://github.com/IntersectMBO/ouroboros-network
+   tag: c2e936f454a0026b9a854e5f230714de81b9965c
+   --sha256: sha256-139VtT1VJkBqIcqf+vak7h4Fh+Z748dHoHwaCCpKOy4=
+   subdir:
+     ouroboros-network
+     ouroboros-network-protocols
+     ouroboros-network-api
+     ouroboros-network
+
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/cardano-ledger
diff --git a/docs/website/contents/for-developers/Benchmarks.md b/docs/website/contents/for-developers/Benchmarks.md
index 36190736a4..94ce7fc0c7 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,20 @@ 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
+```
+
+## 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/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.
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-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
index 85c4109a52..b0cdd043c5 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
@@ -68,6 +68,10 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
   )
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CsClient
 import Ouroboros.Consensus.MiniProtocol.ChainSync.Server
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound (objectDiffusionInbound)
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound)
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
 import Ouroboros.Consensus.Node.ExitPolicy
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Node.Run
@@ -81,10 +85,6 @@ import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.Orphans ()
 import Ouroboros.Network.Block
   ( Serialised (..)
-  , decodePoint
-  , decodeTip
-  , encodePoint
-  , encodeTip
   )
 import Ouroboros.Network.BlockFetch
 import Ouroboros.Network.BlockFetch.Client
@@ -124,6 +124,10 @@ import Ouroboros.Network.Protocol.KeepAlive.Client
 import Ouroboros.Network.Protocol.KeepAlive.Codec
 import Ouroboros.Network.Protocol.KeepAlive.Server
 import Ouroboros.Network.Protocol.KeepAlive.Type
+import Ouroboros.Network.Protocol.ObjectDiffusion.Codec
+  ( codecObjectDiffusion
+  , codecObjectDiffusionId
+  )
 import Ouroboros.Network.Protocol.PeerSharing.Client
   ( PeerSharingClient
   , peerSharingClientPeer
@@ -197,6 +201,19 @@ data Handlers m addr blk = Handlers
       NodeToNodeVersion ->
       ConnectionId addr ->
       TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
+  , hPerasCertDiffusionInbound ::
+      NodeToNodeVersion ->
+      ConnectionId addr ->
+      PerasCertDiffusionInboundPipelined blk m ()
+  -- ^ TODO: We should pass 'hPerasCertDiffusionInbound' to the network
+  -- layer, as per https://github.com/tweag/cardano-peras/issues/78
+  , hPerasCertDiffusionOutbound ::
+      NodeToNodeVersion ->
+      ControlMessageSTM m ->
+      ConnectionId addr ->
+      PerasCertDiffusionOutbound blk m ()
+  -- ^ TODO: We should pass 'hPerasCertDiffusionOutbound' to the network
+  -- layer, as per https://github.com/tweag/cardano-peras/issues/78
   , hKeepAliveClient ::
       NodeToNodeVersion ->
       ControlMessageSTM m ->
@@ -293,6 +310,22 @@ mkHandlers
             (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool)
             (getMempoolWriter getMempool)
             version
+      , hPerasCertDiffusionInbound = \version peer ->
+          objectDiffusionInbound
+            (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionInboundTracer tracers))
+            ( perasCertDiffusionMaxFifoLength miniProtocolParameters
+            , 10 -- TODO https://github.com/tweag/cardano-peras/issues/97
+            , 10 -- TODO https://github.com/tweag/cardano-peras/issues/97
+            )
+            (makePerasCertPoolWriterFromChainDB $ getChainDB)
+            version
+      , hPerasCertDiffusionOutbound = \version controlMessageSTM peer ->
+          objectDiffusionOutbound
+            (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers))
+            (perasCertDiffusionMaxFifoLength miniProtocolParameters)
+            (makePerasCertPoolReaderFromChainDB $ getChainDB)
+            version
+            controlMessageSTM
       , hKeepAliveClient = \_version -> keepAliveClient (Node.keepAliveClientTracer tracers) keepAliveRng
       , hKeepAliveServer = \_version _peer -> keepAliveServer
       , hPeerSharingClient = \_version controlMessageSTM _peer -> peerSharingClient controlMessageSTM
@@ -304,7 +337,7 @@ mkHandlers
 -------------------------------------------------------------------------------}
 
 -- | Node-to-node protocol codecs needed to run 'Handlers'.
-data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs
+data Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bKA bPS = Codecs
   { cChainSyncCodec :: Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
   , cChainSyncCodecSerialised ::
       Codec (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
@@ -312,6 +345,7 @@ data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs
   , cBlockFetchCodecSerialised ::
       Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF
   , cTxSubmission2Codec :: Codec (TxSubmission2 (GenTxId blk) (GenTx blk)) e m bTX
+  , cPerasCertDiffusionCodec :: Codec (PerasCertDiffusion blk) e m bPCD
   , cKeepAliveCodec :: Codec KeepAlive e m bKA
   , cPeerSharingCodec :: Codec (PeerSharing addr) e m bPS
   }
@@ -339,49 +373,53 @@ defaultCodecs ::
     ByteString
     ByteString
     ByteString
+    ByteString
 defaultCodecs ccfg version encAddr decAddr nodeToNodeVersion =
   Codecs
     { cChainSyncCodec =
         codecChainSync
           enc
           dec
-          (encodePoint (encodeRawHash p))
-          (decodePoint (decodeRawHash p))
-          (encodeTip (encodeRawHash p))
-          (decodeTip (decodeRawHash p))
+          enc
+          dec
+          enc
+          dec
     , cChainSyncCodecSerialised =
         codecChainSync
           enc
           dec
-          (encodePoint (encodeRawHash p))
-          (decodePoint (decodeRawHash p))
-          (encodeTip (encodeRawHash p))
-          (decodeTip (decodeRawHash p))
+          enc
+          dec
+          enc
+          dec
     , cBlockFetchCodec =
         codecBlockFetch
           enc
           dec
-          (encodePoint (encodeRawHash p))
-          (decodePoint (decodeRawHash p))
+          enc
+          dec
     , cBlockFetchCodecSerialised =
         codecBlockFetch
           enc
           dec
-          (encodePoint (encodeRawHash p))
-          (decodePoint (decodeRawHash p))
+          enc
+          dec
     , cTxSubmission2Codec =
         codecTxSubmission2
           enc
           dec
           enc
           dec
+    , cPerasCertDiffusionCodec =
+        codecObjectDiffusion
+          enc
+          dec
+          enc
+          dec
     , cKeepAliveCodec = codecKeepAlive_v2
     , cPeerSharingCodec = codecPeerSharing (encAddr nodeToNodeVersion) (decAddr nodeToNodeVersion)
     }
  where
-  p :: Proxy blk
-  p = Proxy
-
   enc :: SerialiseNodeToNode blk a => a -> Encoding
   enc = encodeNodeToNode ccfg version
 
@@ -401,6 +439,7 @@ identityCodecs ::
     (AnyMessage (BlockFetch blk (Point blk)))
     (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
     (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
+    (AnyMessage (PerasCertDiffusion blk))
     (AnyMessage KeepAlive)
     (AnyMessage (PeerSharing addr))
 identityCodecs =
@@ -410,6 +449,7 @@ identityCodecs =
     , cBlockFetchCodec = codecBlockFetchId
     , cBlockFetchCodecSerialised = codecBlockFetchId
     , cTxSubmission2Codec = codecTxSubmission2Id
+    , cPerasCertDiffusionCodec = codecObjectDiffusionId
     , cKeepAliveCodec = codecKeepAliveId
     , cPeerSharingCodec = codecPeerSharingId
     }
@@ -587,7 +627,7 @@ byteLimits =
 
 -- | Construct the 'NetworkApplication' for the node-to-node protocols
 mkApps ::
-  forall m addrNTN addrNTC blk e bCS bBF bTX bKA bPS.
+  forall m addrNTN addrNTC blk e bCS bBF bTX bPCD bKA bPS.
   ( IOLike m
   , MonadTimer m
   , Ord addrNTN
@@ -602,7 +642,7 @@ mkApps ::
   NodeKernel m addrNTN addrNTC blk ->
   StdGen ->
   Tracers m addrNTN blk e ->
-  (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS) ->
+  (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD bKA bPS) ->
   ByteLimits bCS bBF bTX bKA ->
   -- Chain-Sync timeouts for chain-sync client (using `Header blk`) as well as
   -- the server (`SerialisedHeader blk`).
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/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs
index 24b82c331d..7cee89fa52 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs
@@ -42,6 +42,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Server
 import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
   ( TraceLocalTxSubmissionServerEvent (..)
   )
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
 import Ouroboros.Consensus.Node.GSM (TraceGsmEvent)
 import Ouroboros.Network.Block (Tip)
 import Ouroboros.Network.BlockFetch
@@ -87,6 +88,10 @@ data Tracers' remotePeer localPeer blk f = Tracers
   , csjTracer ::
       f (TraceLabelPeer remotePeer (CSJumping.TraceEventCsj remotePeer blk))
   , dbfTracer :: f (CSJumping.TraceEventDbf remotePeer)
+  , perasCertDiffusionInboundTracer ::
+      f (TraceLabelPeer remotePeer (TracePerasCertDiffusionInbound blk))
+  , perasCertDiffusionOutboundTracer ::
+      f (TraceLabelPeer remotePeer (TracePerasCertDiffusionOutbound blk))
   }
 
 instance
@@ -115,6 +120,8 @@ instance
       , gddTracer = f gddTracer
       , csjTracer = f csjTracer
       , dbfTracer = f dbfTracer
+      , perasCertDiffusionInboundTracer = f perasCertDiffusionInboundTracer
+      , perasCertDiffusionOutboundTracer = f perasCertDiffusionOutboundTracer
       }
    where
     f ::
@@ -151,6 +158,8 @@ nullTracers =
     , gddTracer = nullTracer
     , csjTracer = nullTracer
     , dbfTracer = nullTracer
+    , perasCertDiffusionInboundTracer = nullTracer
+    , perasCertDiffusionOutboundTracer = nullTracer
     }
 
 showTracers ::
@@ -189,6 +198,8 @@ showTracers tr =
     , gddTracer = showTracing tr
     , csjTracer = showTracing tr
     , dbfTracer = showTracing tr
+    , perasCertDiffusionInboundTracer = showTracing tr
+    , perasCertDiffusionOutboundTracer = showTracing tr
     }
 
 {-------------------------------------------------------------------------------
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..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.candidateOverSelection = \(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/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
index 3b3d472a38..792a39210c 100644
--- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
+++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
@@ -83,6 +83,7 @@ import Ouroboros.Consensus.Mempool
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert (PerasCertDiffusion)
 import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
 import Ouroboros.Consensus.Node.ExitPolicy
 import qualified Ouroboros.Consensus.Node.GSM as GSM
@@ -123,8 +124,8 @@ import Ouroboros.Network.NodeToNode
   ( ConnectionId (..)
   , ExpandedInitiatorContext (..)
   , IsBigLedgerPeer (..)
-  , MiniProtocolParameters (..)
   , ResponderContext (..)
+  , defaultMiniProtocolParameters
   )
 import Ouroboros.Network.PeerSelection.Governor
   ( makePublicPeerSelectionStateVar
@@ -1056,13 +1057,7 @@ runThreadNetwork
               , mempoolCapacityOverride = NoMempoolCapacityBytesOverride
               , keepAliveRng = kaRng
               , peerSharingRng = psRng
-              , miniProtocolParameters =
-                  MiniProtocolParameters
-                    { chainSyncPipeliningHighMark = 4
-                    , chainSyncPipeliningLowMark = 2
-                    , blockFetchPipeliningMax = 10
-                    , txSubmissionMaxUnacked = 1000 -- TODO ?
-                    }
+              , miniProtocolParameters = defaultMiniProtocolParameters
               , blockFetchConfiguration =
                   BlockFetchConfiguration
                     { bfcMaxConcurrencyBulkSync = 1
@@ -1186,6 +1181,7 @@ runThreadNetwork
         Lazy.ByteString
         Lazy.ByteString
         (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
+        (AnyMessage (PerasCertDiffusion blk))
         (AnyMessage KeepAlive)
         (AnyMessage (PeerSharing NodeId))
     customNodeToNodeCodecs cfg ntnVersion =
@@ -1205,6 +1201,9 @@ runThreadNetwork
         , cTxSubmission2Codec =
             mapFailureCodec CodecIdFailure $
               NTN.cTxSubmission2Codec NTN.identityCodecs
+        , cPerasCertDiffusionCodec =
+            mapFailureCodec CodecIdFailure $
+              NTN.cPerasCertDiffusionCodec NTN.identityCodecs
         , cKeepAliveCodec =
             mapFailureCodec CodecIdFailure $
               NTN.cKeepAliveCodec NTN.identityCodecs
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..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
@@ -279,7 +280,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
@@ -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-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/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs
new file mode 100644
index 0000000000..40642021d4
--- /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.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
+--   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 Numeric.Natural (Natural)
+import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..))
+import Ouroboros.Consensus.Peras.Weight
+  ( PerasWeightSnapshot
+  , mkPerasWeightSnapshot
+  , weightBoostOfFragment
+  )
+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 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
+  --       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
+
+benchWeightBoostOfFragment ::
+  (Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock)) -> Benchmark
+benchWeightBoostOfFragment (i, (weightSnapshot, fragment)) =
+  bench ("weightBoostOfFragment of length " <> show i) $
+    whnf (weightBoostOfFragment 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 mkPerasWeightSnapshot $ pointsToBoost `zip` weights
+
+getEveryN :: Natural -> [(Natural, a)] -> [(Natural, a)]
+getEveryN n = filter (\(i, _) -> (i `mod` n) == 0)
diff --git a/ouroboros-consensus/changelog.d/20250626_193647_alexander.esgen_ledgerdb_garbage_collect_states.md b/ouroboros-consensus/changelog.d/20250626_193647_alexander.esgen_ledgerdb_garbage_collect_states.md
new file mode 100644
index 0000000000..9dfb07f311
--- /dev/null
+++ b/ouroboros-consensus/changelog.d/20250626_193647_alexander.esgen_ledgerdb_garbage_collect_states.md
@@ -0,0 +1,9 @@
+### Breaking
+
+- Changed pruning of immutable ledger states to happen on LedgerDB garbage
+  collection instead of directly on every block adoption. This is purely an
+  internal refactoring (with breaking API changes) supporting predictable ledger
+  snapshotting.
+
+- Avoid maintaining volatile ledger states during ledger replay, making it
+  slightly more efficient.
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/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/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
index e92be3db64..559b8a9d0b 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
@@ -182,6 +183,11 @@ library
     Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server
     Ouroboros.Consensus.MiniProtocol.LocalTxMonitor.Server
     Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
+    Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
+    Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+    Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
+    Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound
+    Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
     Ouroboros.Consensus.Node.GsmState
     Ouroboros.Consensus.Node.InitStorage
     Ouroboros.Consensus.Node.NetworkProtocolVersion
@@ -189,6 +195,8 @@ 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
     Ouroboros.Consensus.Protocol.LeaderSchedule
@@ -254,6 +262,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
@@ -587,6 +598,9 @@ test-suite consensus-test
     Test.Consensus.MiniProtocol.ChainSync.CSJ
     Test.Consensus.MiniProtocol.ChainSync.Client
     Test.Consensus.MiniProtocol.LocalStateQuery.Server
+    Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke
+    Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
+    Test.Consensus.Peras.WeightSnapshot
     Test.Consensus.Util.MonadSTM.NormalForm
     Test.Consensus.Util.Versioned
 
@@ -708,6 +722,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
@@ -817,6 +834,19 @@ 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,
+    ouroboros-consensus,
+    ouroboros-network-api,
+    tasty-bench,
+    unstable-consensus-testlib,
+
 test-suite doctest
   import: common-test
   main-is: doctest.hs
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..cb9f1c3939
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Ouroboros.Consensus.Block.SupportsPeras
+  ( PerasRoundNo (..)
+  , PerasWeight (..)
+  , boostPerCert
+  , BlockSupportsPeras (..)
+  , PerasCert (..)
+  ) where
+
+import Codec.Serialise (Serialise (..))
+import Codec.Serialise.Decoding (decodeListLenOf)
+import Codec.Serialise.Encoding (encodeListLen)
+import Data.Monoid (Sum (..))
+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}
+  deriving Show via Quiet PerasRoundNo
+  deriving stock Generic
+  deriving newtype (Eq, Ord, NoThunks, Serialise)
+
+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
+
+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, Eq, Ord, Show)
+    deriving anyclass NoThunks
+
+  perasCertRound = pcCertRound
+  perasCertBoostedBlock = pcCertBoostedBlock
+
+instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
+  encode PerasCert{pcCertRound, pcCertBoostedBlock} =
+    encodeListLen 2
+      <> encode pcCertRound
+      <> encode pcCertBoostedBlock
+  decode = do
+    decodeListLenOf 2
+    pcCertRound <- decode
+    pcCertBoostedBlock <- decode
+    pure $ PerasCert{pcCertRound, pcCertBoostedBlock}
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
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/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs
index bdf45723e0..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,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 (PerasWeightSnapshot)
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( AddBlockPromise
   , ChainDB
@@ -45,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
   )
@@ -66,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
@@ -77,6 +80,7 @@ defaultChainDbView chainDB =
     , getMaxSlotNo = ChainDB.getMaxSlotNo chainDB
     , addBlockAsync = ChainDB.addBlockAsync chainDB
     , getChainSelStarvation = ChainDB.getChainSelStarvation chainDB
+    , getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB
     }
 
 readFetchModeDefault ::
@@ -226,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.
     --
@@ -241,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.
       --
@@ -258,52 +273,27 @@ 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 ::
+      PerasWeightSnapshot blk ->
       AnchoredFragment (HeaderWithTime blk) ->
       AnchoredFragment (HeaderWithTime blk) ->
       Ordering
     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/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
index c7c30ba1be..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
@@ -691,12 +692,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 +722,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 +747,6 @@ checkKnownIntersectionInvariants cfg kis
   | otherwise =
       return ()
  where
-  SecurityParam k = protocolSecurityParam cfg
-
   KnownIntersectionState
     { mostRecentIntersection
     , ourFrag
@@ -774,14 +758,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 +874,7 @@ chainSyncClient cfgEnv dynEnv =
             (ForkTooDeep GenesisPoint)
  where
   ConfigEnv
-    { cfg
-    , chainDbView
+    { chainDbView
     , tracer
     } = cfgEnv
 
@@ -995,7 +976,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 +1139,7 @@ findIntersectionTop cfgEnv dynEnv intEnv =
                 (ourTipFromChain ourFrag)
                 theirTip
       let kis =
-            assertKnownIntersectionInvariants (configConsensus cfg) $
+            assertKnownIntersectionInvariants $
               KnownIntersectionState
                 { mostRecentIntersection = intersection
                 , ourFrag
@@ -1234,7 +1215,6 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv =
   ConfigEnv
     { mkPipelineDecision0
     , tracer
-    , cfg
     , historicityCheck
     } = cfgEnv
 
@@ -1622,9 +1602,8 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv =
                         else mostRecentIntersection
 
                     kis' =
-                      assertKnownIntersectionInvariants
-                        (configConsensus cfg)
-                        $ KnownIntersectionState
+                      assertKnownIntersectionInvariants $
+                        KnownIntersectionState
                           { mostRecentIntersection = mostRecentIntersection'
                           , ourFrag = ourFrag
                           , theirFrag = theirFrag'
@@ -1856,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 $
@@ -1961,7 +1945,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
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs
new file mode 100644
index 0000000000..587036d87d
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs
@@ -0,0 +1,461 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
+  ( objectDiffusionInbound
+  , TraceObjectDiffusionInbound (..)
+  , ObjectDiffusionInboundError (..)
+  , NumObjectsProcessed (..)
+  ) where
+
+import Cardano.Prelude (catMaybes)
+import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked
+import Control.Exception (assert)
+import Control.Monad (when)
+import Control.Monad.Class.MonadSTM
+import Control.Monad.Class.MonadThrow
+import Control.Tracer (Tracer, traceWith)
+import Data.Foldable as Foldable (foldl', toList)
+import Data.List qualified as List
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Sequence.Strict (StrictSeq)
+import Data.Sequence.Strict qualified as Seq
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Word (Word64)
+import GHC.Generics (Generic)
+import Network.TypedProtocol.Core (N (Z), Nat (..), natToInt)
+import NoThunks.Class (NoThunks (..), unsafeNoThunks)
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion)
+import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound
+import Ouroboros.Network.Protocol.ObjectDiffusion.Type
+
+-- Note: This module is inspired from TxSubmission inbound side.
+
+newtype NumObjectsProcessed
+  = NumObjectsProcessed
+  { getNumObjectsProcessed :: Word64
+  }
+  deriving (Eq, Show)
+
+data TraceObjectDiffusionInbound objectId object
+  = -- | Number of objects just about to be inserted.
+    TraceObjectDiffusionCollected Int
+  | -- | Just processed object pass/fail breakdown.
+    TraceObjectDiffusionProcessed NumObjectsProcessed
+  | -- | Inbound received 'MsgDone'
+    TraceObjectInboundTerminated
+  | TraceObjectInboundCanRequestMoreObjects Int
+  | TraceObjectInboundCannotRequestMoreObjects Int
+  deriving (Eq, Show)
+
+data ObjectDiffusionInboundError
+  = ProtocolErrorObjectNotRequested
+  | ProtocolErrorObjectIdsNotRequested
+  | ProtocolErrorObjectIdAlreadyKnown
+  | ProtocolErrorObjectIdsDuplicate
+  deriving Show
+
+instance Exception ObjectDiffusionInboundError where
+  displayException ProtocolErrorObjectNotRequested =
+    "The peer replied with a object we did not ask for."
+  displayException ProtocolErrorObjectIdsNotRequested =
+    "The peer replied with more objectIds than we asked for."
+  displayException ProtocolErrorObjectIdAlreadyKnown =
+    "The peer replied with an objectId that it has already sent us previously."
+  displayException ProtocolErrorObjectIdsDuplicate =
+    "The peer replied with a batch of objectIds containing a duplicate."
+
+-- | Information maintained internally in the 'objectDiffusionInbound'
+-- implementation.
+data InboundSt objectId object = InboundSt
+  { numIdsInFlight :: !NumObjectIdsReq
+  -- ^ The number of object identifiers that we have requested but
+  -- which have not yet been replied to. We need to track this to keep
+  -- our requests within the limit on the 'outstandingFifo' size.
+  , outstandingFifo :: !(StrictSeq objectId)
+  -- ^ This mirrors the queue of objects that the outbound peer has available
+  -- for us. Objects are kept in the order in which the outbound peer
+  -- advertised them to us. This is the same order in which we submit them to
+  -- the objectPool. It is also the order we acknowledge them.
+  , canRequestNext :: !(Set objectId)
+  -- ^ The objectIds that we can request. These are a subset of the
+  -- 'outstandingFifo' that we have not yet requested or not have in the pool
+  -- already. This is not ordered to illustrate the fact that we can
+  -- request objects out of order.
+  , pendingObjects :: !(Map objectId (Maybe object))
+  -- ^ Objects we have successfully downloaded (or decided intentionally to
+  -- skip download) but have not yet added to the objectPool or acknowledged.
+  --
+  -- Object IDs in this 'Map' are mapped to 'Nothing' if we notice that
+  -- they are already in the objectPool. That way we can skip requesting them
+  -- from the outbound peer, but still acknowledge them when the time comes.
+  , numToAckOnNextReq :: !NumObjectIdsAck
+  -- ^ The number of objects we can acknowledge on our next request
+  -- for more object IDs. Their corresponding IDs have already been removed
+  -- from 'outstandingFifo'.
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass NoThunks
+
+initialInboundSt :: InboundSt objectId object
+initialInboundSt = InboundSt 0 Seq.empty Set.empty Map.empty 0
+
+objectDiffusionInbound ::
+  forall objectId object m.
+  ( Ord objectId
+  , NoThunks objectId
+  , NoThunks object
+  , MonadSTM m
+  , MonadThrow m
+  ) =>
+  Tracer m (TraceObjectDiffusionInbound objectId object) ->
+  -- | Maximum values for outstanding FIFO length, number of IDs to request,
+  -- and number of objects to request
+  (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) ->
+  ObjectPoolWriter objectId object m ->
+  NodeToNodeVersion ->
+  ObjectDiffusionInboundPipelined objectId object m ()
+objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) ObjectPoolWriter{..} _version =
+  ObjectDiffusionInboundPipelined $ do
+    continueWithStateM (go Zero) initialInboundSt
+ where
+  canRequestMoreObjects :: InboundSt k object -> Bool
+  canRequestMoreObjects st =
+    not (Set.null (canRequestNext st))
+
+  -- Computes how many new IDs we can request so that receiving all of them
+  -- won't make 'outstandingFifo' exceed 'maxFifoLength'.
+  numIdsToReq :: InboundSt objectId object -> NumObjectIdsReq
+  numIdsToReq st =
+    maxNumIdsToReq
+      `min` ( fromIntegral maxFifoLength
+                - (fromIntegral $ Seq.length $ outstandingFifo st)
+                - numIdsInFlight st
+            )
+
+  -- Updates 'InboundSt' with new object IDs and return the updated 'InboundSt'.
+  --
+  -- Collected object IDs that are already in the objectPool are pre-emptively
+  -- acknowledged so that we don't need to bother requesting them from the
+  -- outbound peer.
+  preAcknowledge ::
+    InboundSt objectId object ->
+    (objectId -> Bool) ->
+    [objectId] ->
+    InboundSt objectId object
+  preAcknowledge st _ collectedIds | null collectedIds = st
+  preAcknowledge st poolHasObject collectedIds =
+    let
+      -- Divide the collected IDs in two parts: those that are already in the
+      -- objectPool and those that are not.
+      (alreadyObtained, notYetObtained) =
+        List.partition
+          (\objectId -> poolHasObject objectId)
+          collectedIds
+
+      -- The objects that we intentionally don't request, because they are
+      -- already in the objectPool, will need to be acknowledged.
+      -- So we extend 'pendingObjects' with those objects (so of course they
+      -- have no corresponding reply).
+      pendingObjects' =
+        pendingObjects st
+          <> Map.fromList [(objectId, Nothing) | objectId <- alreadyObtained]
+
+      -- We initially extend 'outstandingFifo' with the all the collected IDs
+      -- (to properly mirror the server state).
+      outstandingFifo' = outstandingFifo st <> Seq.fromList collectedIds
+
+      -- Now check if the update of 'pendingObjects' let us acknowledge a prefix
+      -- of the 'outstandingFifo', as we do in 'goCollect' -> 'CollectObjects'.
+      (objectIdsToAck, outstandingFifo'') =
+        Seq.spanl (`Map.member` pendingObjects') outstandingFifo'
+
+      -- If so we can remove them from the 'pendingObjects' structure.
+      --
+      -- Note that unlike in TX-Submission, we made sure the outstanding FIFO
+      -- couldn't have duplicate IDs, so we don't have to worry about re-adding
+      -- the duplicate IDs to 'pendingObjects' for future acknowledgment.
+      pendingObjects'' =
+        Foldable.foldl'
+          (flip Map.delete)
+          pendingObjects'
+          objectIdsToAck
+     in
+      st
+        { canRequestNext = canRequestNext st <> (Set.fromList notYetObtained)
+        , pendingObjects = pendingObjects''
+        , outstandingFifo = outstandingFifo''
+        , numToAckOnNextReq =
+            numToAckOnNextReq st
+              + fromIntegral (Seq.length objectIdsToAck)
+        }
+
+  go ::
+    forall (n :: N).
+    Nat n ->
+    StatefulM (InboundSt objectId object) n objectId object m
+  go n = StatefulM $ \st -> case n of
+    -- We didn't pipeline any requests, so there are no replies in flight
+    -- (nothing to collect)
+    Zero -> do
+      if canRequestMoreObjects st
+        then do
+          -- There are no replies in flight, but we do know some more objects
+          -- we can ask for, so lets ask for them and more objectIds in a
+          -- pipelined way.
+          traceWith tracer (TraceObjectInboundCanRequestMoreObjects (natToInt n))
+          pure $ continueWithState (goReqObjectsAndObjectIdsPipelined Zero) st
+        else do
+          -- There's no replies in flight, and we have no more objects we can
+          -- ask for so the only remaining thing to do is to ask for more
+          -- objectIds. Since this is the only thing to do now, we make this a
+          -- blocking call.
+          traceWith tracer (TraceObjectInboundCannotRequestMoreObjects (natToInt n))
+          pure $ continueWithState goReqObjectIdsBlocking st
+
+    -- We have pipelined some requests, so there are some replies in flight.
+    Succ n' ->
+      if canRequestMoreObjects st
+        then do
+          -- We have replies in flight and we should eagerly collect them if
+          -- available, but there are objects to request too so we
+          -- should *not* block waiting for replies.
+          -- So we ask for new objects and objectIds in a pipelined way.
+          traceWith tracer (TraceObjectInboundCanRequestMoreObjects (natToInt n))
+          pure $
+            CollectPipelined
+              (Just (continueWithState (goReqObjectsAndObjectIdsPipelined (Succ n')) st))
+              (collectAndContinueWithState (goCollect n') st)
+        else do
+          traceWith tracer (TraceObjectInboundCannotRequestMoreObjects (natToInt n))
+          -- In this case we can theoretically only collect replies or request
+          -- new object IDs.
+          --
+          -- But it's important not to pipeline more requests for objectIds now
+          -- because if we did, then immediately after sending the request (but
+          -- having not yet received a response to either this or the other
+          -- pipelined requests), we would directly re-enter this code path,
+          -- resulting us in filling the pipeline with an unbounded number of
+          -- requests.
+          --
+          -- So we instead block until we collect a reply.
+          pure $
+            CollectPipelined
+              Nothing
+              (collectAndContinueWithState (goCollect n') st)
+
+  goCollect ::
+    forall (n :: N).
+    Nat n ->
+    StatefulCollect (InboundSt objectId object) n objectId object m
+  goCollect n = StatefulCollect $ \st collect -> case collect of
+    CollectObjectIds numIdsRequested collectedIds -> do
+      let numCollectedIds = length collectedIds
+          collectedIdsSet = Set.fromList collectedIds
+
+      -- Check they didn't send more than we asked for. We don't need to
+      -- check for a minimum: the blocking case checks for non-zero
+      -- elsewhere, and for the non-blocking case it is quite normal for
+      -- them to send us none.
+      when (numCollectedIds > fromIntegral numIdsRequested) $
+        throwIO ProtocolErrorObjectIdsNotRequested
+
+      -- Check that the server didn't send IDs that were already in the
+      -- outstanding FIFO
+      when (any (`Set.member` collectedIdsSet) (outstandingFifo st)) $
+        throwIO ProtocolErrorObjectIdAlreadyKnown
+
+      -- Check that the server didn't send duplicate IDs in its response
+      when (Set.size collectedIdsSet /= numCollectedIds) $
+        throwIO ProtocolErrorObjectIdsDuplicate
+
+      -- We extend our outstanding FIFO with the newly received objectIds by
+      -- calling 'preAcknowledge' which will also pre-emptively acknowledge the
+      -- objectIds that we already have in the pool and thus don't need to
+      -- request.
+      let st' = st{numIdsInFlight = numIdsInFlight st - numIdsRequested}
+      poolHasObject <- atomically $ opwHasObject
+      continueWithStateM
+        (go n)
+        (preAcknowledge st' poolHasObject collectedIds)
+    CollectObjects requestedIds collectedObjects -> do
+      let requestedIdsSet = Set.fromList requestedIds
+          obtainedIdsSet = Set.fromList (opwObjectId <$> collectedObjects)
+
+      -- To start with we have to verify that the objects they have sent us are
+      -- exactly the objects we asked for, not more, not less.
+      when (requestedIdsSet /= obtainedIdsSet) $
+        throwIO ProtocolErrorObjectNotRequested
+
+      traceWith tracer $
+        TraceObjectDiffusionCollected (length collectedObjects)
+
+      -- We update 'pendingObjects' with the newly obtained objects
+      let newPendingObjects :: Map objectId (Maybe object)
+          newPendingObjects = Map.fromList [(opwObjectId obj, Just obj) | obj <- collectedObjects]
+          pendingObjects' = pendingObjects st <> newPendingObjects
+
+          -- We then find the longest prefix of 'outstandingFifo' for which we have
+          -- all the corresponding IDs in 'pendingObjects'.
+          -- We remove this prefix from 'outstandingFifo'.
+          (objectIdsToAck, outstandingFifo') =
+            Seq.spanl (`Map.member` pendingObjects') (outstandingFifo st)
+
+          -- And also remove these entries from 'pendingObjects'.
+          --
+          -- Note that unlike in TX-Submission, we made sure the outstanding FIFO
+          -- couldn't have duplicate IDs, so we don't have to worry about re-adding
+          -- the duplicate IDs to 'pendingObjects' for future acknowledgment.
+          pendingObjects'' =
+            Foldable.foldl'
+              (flip Map.delete)
+              pendingObjects'
+              objectIdsToAck
+
+          -- These are the objects we need to submit to the object pool
+          objectsToAck =
+            catMaybes $
+              (((Map.!) pendingObjects') <$> toList objectIdsToAck)
+
+      -- TODO: Certificate / Vote validation
+
+      opwAddObjects objectsToAck
+      traceWith tracer $
+        TraceObjectDiffusionProcessed
+          (NumObjectsProcessed (fromIntegral $ length objectsToAck))
+      continueWithStateM
+        (go n)
+        st
+          { pendingObjects = pendingObjects''
+          , outstandingFifo = outstandingFifo'
+          , numToAckOnNextReq =
+              numToAckOnNextReq st
+                + fromIntegral (Seq.length objectIdsToAck)
+          }
+
+  goReqObjectIdsBlocking :: Stateful (InboundSt objectId object) 'Z objectId object m
+  goReqObjectIdsBlocking = Stateful $ \st -> do
+    let numIdsToRequest = numIdsToReq st
+    -- We should only request new object IDs in a blocking way if we have
+    -- absolutely nothing else we can do.
+    assert
+      ( numIdsInFlight st == 0
+          && Seq.null (outstandingFifo st)
+          && Set.null (canRequestNext st)
+          && Map.null (pendingObjects st)
+      )
+      $ SendMsgRequestObjectIdsBlocking
+        (numToAckOnNextReq st)
+        numIdsToRequest
+        -- Our result if the outbound peer terminates the protocol
+        (traceWith tracer TraceObjectInboundTerminated)
+        ( \neCollectedIds ->
+            collectAndContinueWithState
+              (goCollect Zero)
+              st
+                { numToAckOnNextReq = 0
+                , numIdsInFlight = numIdsToRequest
+                }
+              (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds))
+        )
+
+  goReqObjectsAndObjectIdsPipelined ::
+    forall (n :: N).
+    Nat n ->
+    Stateful (InboundSt objectId object) n objectId object m
+  goReqObjectsAndObjectIdsPipelined n = Stateful $ \st -> do
+    -- TODO: This implementation is deliberately naive, we pick in an
+    -- arbitrary order. We may want to revisit this later.
+    let (toRequest, canRequestNext') =
+          Set.splitAt (fromIntegral maxNumObjectsToReq) (canRequestNext st)
+
+    SendMsgRequestObjectsPipelined
+      (toList toRequest)
+      ( continueWithStateM
+          (goReqObjectIdsPipelined (Succ n))
+          st{canRequestNext = canRequestNext'}
+      )
+
+  goReqObjectIdsPipelined ::
+    forall (n :: N).
+    Nat n ->
+    StatefulM (InboundSt objectId object) n objectId object m
+  goReqObjectIdsPipelined n = StatefulM $ \st -> do
+    let numIdsToRequest = numIdsToReq st
+
+    if numIdsToRequest <= 0
+      then continueWithStateM (go n) st
+      else
+        pure $
+          SendMsgRequestObjectIdsPipelined
+            (numToAckOnNextReq st)
+            numIdsToRequest
+            ( continueWithStateM
+                (go (Succ n))
+                st
+                  { numIdsInFlight =
+                      numIdsInFlight st
+                        + numIdsToRequest
+                  , numToAckOnNextReq = 0
+                  }
+            )
+
+-------------------------------------------------------------------------------
+-- Utilities to deal with stateful continuations (copied from TX-submission)
+-------------------------------------------------------------------------------
+
+newtype Stateful s n objectId object m = Stateful (s -> InboundStIdle n objectId object m ())
+
+newtype StatefulM s n objectId object m
+  = StatefulM (s -> m (InboundStIdle n objectId object m ()))
+
+newtype StatefulCollect s n objectId object m
+  = StatefulCollect (s -> Collect objectId object -> m (InboundStIdle n objectId object m ()))
+
+-- | After checking that there are no unexpected thunks in the provided state,
+-- pass it to the provided function.
+--
+-- See 'checkInvariant' and 'unsafeNoThunks'.
+continueWithState ::
+  NoThunks s =>
+  Stateful s n objectId object m ->
+  s ->
+  InboundStIdle n objectId object m ()
+continueWithState (Stateful f) !st =
+  checkInvariant (show <$> unsafeNoThunks st) (f st)
+
+-- | A variant of 'continueWithState' to be more easily utilized with
+-- 'inboundIdle' and 'inboundReqObjectIds'.
+continueWithStateM ::
+  NoThunks s =>
+  StatefulM s n objectId object m ->
+  s ->
+  m (InboundStIdle n objectId object m ())
+continueWithStateM (StatefulM f) !st =
+  checkInvariant (show <$> unsafeNoThunks st) (f st)
+{-# NOINLINE continueWithStateM #-}
+
+-- | A variant of 'continueWithState' to be more easily utilized with
+-- 'handleReply'.
+collectAndContinueWithState ::
+  NoThunks s =>
+  StatefulCollect s n objectId object m ->
+  s ->
+  Collect objectId object ->
+  m (InboundStIdle n objectId object m ())
+collectAndContinueWithState (StatefulCollect f) !st c =
+  checkInvariant (show <$> unsafeNoThunks st) (f st c)
+{-# NOINLINE collectAndContinueWithState #-}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs
new file mode 100644
index 0000000000..2f949d8b3b
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs
@@ -0,0 +1,59 @@
+-- | API for reading from and writing to object pools in the ObjectDiffusion
+-- miniprotocol.
+--
+-- The underlying object pool can be any database, such as a 'PerasCertDb' in
+-- Peras certificate diffusion.
+--
+-- 'ObjectPoolReader' is used on the outbound side of the protocol. Objects in
+-- the pool are ordered by a strictly increasing ticket number ('ticketNo'),
+-- which represents their time of arrival. Ticket numbers are local to each
+-- node, unlike object IDs, which are global. Object IDs are not used for
+-- ordering, since objects may arrive slightly out of order from peers.
+--
+-- To read from the pool, one requests objects with a ticket number strictly
+-- greater than the last known one. 'oprZeroTicketNo' provides an initial ticket
+-- number for the first request.
+--
+-- 'ObjectPoolWriter' is used on the inbound side of the protocol. It allows
+-- checking whether an object is already present (to avoid re-requesting it) and
+-- appending new objects. Ticket numbers are not part of the inbound interface,
+-- but are used internally: newly added objects always receive a ticket number
+-- strictly greater than those of older ones.
+--
+-- This API design is inspired by 'MempoolSnapshot' from the TX-submission
+-- miniprotocol, see:
+-- <https://ouroboros-consensus.cardano.intersectmbo.org/haddocks/ouroboros-consensus/Ouroboros-Consensus-Mempool-API.html#t:MempoolSnapshot>
+module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+  ( ObjectPoolReader (..)
+  , ObjectPoolWriter (..)
+  ) where
+
+import Control.Concurrent.Class.MonadSTM.Strict (STM)
+import Data.Word (Word64)
+
+-- | Interface used by the outbound side of object diffusion as its source of
+-- objects to give to the remote side.
+data ObjectPoolReader objectId object ticketNo m
+  = ObjectPoolReader
+  { oprObjectId :: object -> objectId
+  -- ^ Return the id of the specified object
+  , oprZeroTicketNo :: ticketNo
+  -- ^ Ticket number before the first item in the pool.
+  , oprObjectsAfter :: ticketNo -> Word64 -> STM m [(ticketNo, objectId, m object)]
+  -- ^ Get the list of objects available in the pool with a ticketNo greater
+  -- than the specified one. The number of returned objects is capped by the
+  -- given Word64. Only the IDs and ticketNos of the objects are directly
+  -- accessible; each actual object must be loaded through a monadic action.
+  }
+
+-- | Interface used by the inbound side of object diffusion when receiving
+-- objects.
+data ObjectPoolWriter objectId object m
+  = ObjectPoolWriter
+  { opwObjectId :: object -> objectId
+  -- ^ Return the id of the specified object
+  , opwAddObjects :: [object] -> m ()
+  -- ^ Add a batch of objects to the objectPool.
+  , opwHasObject :: STM m (objectId -> Bool)
+  -- ^ Check if the object pool contains an object with the given id
+  }
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs
new file mode 100644
index 0000000000..c28189a780
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs
@@ -0,0 +1,76 @@
+-- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras
+-- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the
+-- 'PerasCertDB').
+module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
+  ( makePerasCertPoolReaderFromCertDB
+  , makePerasCertPoolWriterFromCertDB
+  , makePerasCertPoolReaderFromChainDB
+  , makePerasCertPoolWriterFromChainDB
+  ) where
+
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
+import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
+import Ouroboros.Consensus.Storage.PerasCertDB.API
+  ( PerasCertDB
+  , PerasCertSnapshot
+  , PerasCertTicketNo
+  )
+import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB
+import Ouroboros.Consensus.Util.IOLike
+
+makePerasCertPoolReaderFromSnapshot ::
+  (IOLike m, StandardHash blk) =>
+  STM m (PerasCertSnapshot blk) ->
+  ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
+makePerasCertPoolReaderFromSnapshot getCertSnapshot =
+  ObjectPoolReader
+    { oprObjectId = perasCertRound
+    , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo
+    , oprObjectsAfter = \lastKnown limit -> do
+        certSnapshot <- getCertSnapshot
+        pure $
+          take (fromIntegral limit) $
+            [ (ticketNo, perasCertRound cert, pure cert)
+            | (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown
+            ]
+    }
+
+makePerasCertPoolReaderFromCertDB ::
+  (IOLike m, StandardHash blk) =>
+  PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
+makePerasCertPoolReaderFromCertDB perasCertDB =
+  makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB)
+
+makePerasCertPoolWriterFromCertDB ::
+  (StandardHash blk, MonadSTM m) =>
+  PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
+makePerasCertPoolWriterFromCertDB perasCertDB =
+  ObjectPoolWriter
+    { opwObjectId = perasCertRound
+    , opwAddObjects =
+        mapM_ $ PerasCertDB.addCert perasCertDB
+    , opwHasObject = do
+        certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB
+        pure $ PerasCertDB.containsCert certSnapshot
+    }
+
+makePerasCertPoolReaderFromChainDB ::
+  (IOLike m, StandardHash blk) =>
+  ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
+makePerasCertPoolReaderFromChainDB chainDB =
+  makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB)
+
+makePerasCertPoolWriterFromChainDB ::
+  (StandardHash blk, MonadSTM m) =>
+  ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
+makePerasCertPoolWriterFromChainDB chainDB =
+  ObjectPoolWriter
+    { opwObjectId = perasCertRound
+    , opwAddObjects =
+        mapM_ $ ChainDB.addPerasCertAsync chainDB
+    , opwHasObject = do
+        certSnapshot <- ChainDB.getPerasCertSnapshot chainDB
+        pure $ PerasCertDB.containsCert certSnapshot
+    }
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs
new file mode 100644
index 0000000000..37b7e66748
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs
@@ -0,0 +1,252 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound
+  ( objectDiffusionOutbound
+  , TraceObjectDiffusionOutbound (..)
+  , ObjectDiffusionOutboundError (..)
+  ) where
+
+import Control.Exception (assert)
+import Control.Monad (forM, unless, when)
+import Control.Monad.Class.MonadSTM
+import Control.Monad.Class.MonadThrow
+import Control.Tracer (Tracer, traceWith)
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Sequence.Strict (StrictSeq)
+import Data.Sequence.Strict qualified as Seq
+import Data.Set qualified as Set
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+import Ouroboros.Network.ControlMessage
+  ( ControlMessage
+  , ControlMessageSTM
+  , timeoutWithControlMessage
+  )
+import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion)
+import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound
+import Ouroboros.Network.Protocol.ObjectDiffusion.Type
+
+-- Note: This module is inspired from TxSubmission outbound side.
+
+data TraceObjectDiffusionOutbound objectId object
+  = TraceObjectDiffusionOutboundRecvMsgRequestObjectIds NumObjectIdsReq
+  | -- | The IDs to be sent in the response
+    TraceObjectDiffusionOutboundSendMsgReplyObjectIds [objectId]
+  | -- | The IDs of the objects requested.
+    TraceObjectDiffusionOutboundRecvMsgRequestObjects
+      [objectId]
+  | -- | The objects to be sent in the response.
+    TraceObjectDiffusionOutboundSendMsgReplyObjects
+      [object]
+  | TraceControlMessage ControlMessage
+  deriving Show
+
+data ObjectDiffusionOutboundError
+  = ProtocolErrorAckedTooManyObjectIds
+  | ProtocolErrorRequestedNothing
+  | ProtocolErrorRequestedTooManyObjectIds NumObjectIdsReq NumObjectsOutstanding
+  | ProtocolErrorRequestBlocking
+  | ProtocolErrorRequestNonBlocking
+  | ProtocolErrorRequestedUnavailableObject
+  | ProtocolErrorRequestedDuplicateObject
+  deriving Show
+
+instance Exception ObjectDiffusionOutboundError where
+  displayException ProtocolErrorAckedTooManyObjectIds =
+    "The peer tried to acknowledged more objectIds than are available to do so."
+  displayException (ProtocolErrorRequestedTooManyObjectIds reqNo maxUnacked) =
+    "The peer requested "
+      ++ show reqNo
+      ++ " objectIds which would put the "
+      ++ "total in flight over the limit of "
+      ++ show maxUnacked
+  displayException ProtocolErrorRequestedNothing =
+    "The peer requested zero objectIds."
+  displayException ProtocolErrorRequestBlocking =
+    "The peer made a blocking request for more objectIds when there are still "
+      ++ "unacknowledged objectIds. It should have used a non-blocking request."
+  displayException ProtocolErrorRequestNonBlocking =
+    "The peer made a non-blocking request for more objectIds when there are "
+      ++ "no unacknowledged objectIds. It should have used a blocking request."
+  displayException ProtocolErrorRequestedUnavailableObject =
+    "The peer requested an object which is not available, either "
+      ++ "because it was never available or because it was previously requested."
+  displayException ProtocolErrorRequestedDuplicateObject =
+    "The peer requested the same object twice."
+
+data OutboundSt objectId object ticketNo = OutboundSt
+  { outstandingFifo :: !(StrictSeq object)
+  , lastTicketNo :: !ticketNo
+  }
+
+objectDiffusionOutbound ::
+  forall objectId object ticketNo m.
+  (Ord objectId, Ord ticketNo, MonadSTM m, MonadThrow m) =>
+  Tracer m (TraceObjectDiffusionOutbound objectId object) ->
+  -- | Maximum number of unacknowledged objectIds allowed
+  NumObjectsOutstanding ->
+  ObjectPoolReader objectId object ticketNo m ->
+  NodeToNodeVersion ->
+  ControlMessageSTM m ->
+  ObjectDiffusionOutbound objectId object m ()
+objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version controlMessageSTM =
+  ObjectDiffusionOutbound (pure (makeBundle $ OutboundSt Seq.empty oprZeroTicketNo))
+ where
+  makeBundle :: OutboundSt objectId object ticketNo -> OutboundStIdle objectId object m ()
+  makeBundle !st =
+    OutboundStIdle
+      { recvMsgRequestObjectIds = recvMsgRequestObjectIds st
+      , recvMsgRequestObjects = recvMsgRequestObjects st
+      }
+
+  updateStNewObjects ::
+    OutboundSt objectId object ticketNo ->
+    [(object, ticketNo)] ->
+    OutboundSt objectId object ticketNo
+  updateStNewObjects !OutboundSt{..} newObjectsWithTicketNos =
+    -- These objects should all be fresh
+    assert (all (\(_, ticketNo) -> ticketNo > lastTicketNo) newObjectsWithTicketNos) $
+      let !outstandingFifo' =
+            outstandingFifo
+              <> (Seq.fromList $ fst <$> newObjectsWithTicketNos)
+          !lastTicketNo'
+            | null newObjectsWithTicketNos = lastTicketNo
+            | otherwise = snd $ last newObjectsWithTicketNos
+       in OutboundSt
+            { outstandingFifo = outstandingFifo'
+            , lastTicketNo = lastTicketNo'
+            }
+
+  recvMsgRequestObjectIds ::
+    forall blocking.
+    OutboundSt objectId object ticketNo ->
+    SingBlockingStyle blocking ->
+    NumObjectIdsAck ->
+    NumObjectIdsReq ->
+    m (OutboundStObjectIds blocking objectId object m ())
+  recvMsgRequestObjectIds !st@OutboundSt{..} blocking numIdsToAck numIdsToReq = do
+    traceWith tracer (TraceObjectDiffusionOutboundRecvMsgRequestObjectIds numIdsToReq)
+
+    when (numIdsToAck > fromIntegral (Seq.length outstandingFifo)) $
+      throwIO ProtocolErrorAckedTooManyObjectIds
+
+    when
+      ( Seq.length outstandingFifo
+          - fromIntegral numIdsToAck
+          + fromIntegral numIdsToReq
+          > fromIntegral maxFifoLength
+      )
+      $ throwIO (ProtocolErrorRequestedTooManyObjectIds numIdsToReq maxFifoLength)
+
+    -- First we update our FIFO to remove the number of objectIds that the
+    -- inbound peer has acknowledged.
+    let !outstandingFifo' = Seq.drop (fromIntegral numIdsToAck) outstandingFifo
+        -- must specify the type here otherwise GHC complains about mismatch objectId types
+        st' :: OutboundSt objectId object ticketNo
+        !st' = st{outstandingFifo = outstandingFifo'}
+
+    -- Grab info about any new objects after the last object ticketNo we've
+    -- seen, up to the number that the peer has requested.
+    case blocking of
+      -----------------------------------------------------------------------
+      SingBlocking -> do
+        when (numIdsToReq == 0) $
+          throwIO ProtocolErrorRequestedNothing
+        unless (Seq.null outstandingFifo') $
+          throwIO ProtocolErrorRequestBlocking
+
+        mbNewContent <- timeoutWithControlMessage controlMessageSTM $
+          do
+            newObjectsWithTicketNos <-
+              oprObjectsAfter
+                lastTicketNo
+                (fromIntegral numIdsToReq)
+            check (not $ null newObjectsWithTicketNos)
+            pure newObjectsWithTicketNos
+
+        case mbNewContent of
+          Nothing -> pure (SendMsgDone ())
+          Just newContent -> do
+            newObjectsWithTicketNos <- forM newContent $
+              \(ticketNo, _, getObject) -> do
+                object <- getObject
+                pure (object, ticketNo)
+
+            let !newIds = oprObjectId . fst <$> newObjectsWithTicketNos
+                st'' = updateStNewObjects st' newObjectsWithTicketNos
+
+            traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjectIds newIds)
+
+            -- Assert objects is non-empty: we blocked until objects was
+            -- non-null, and we know numIdsToReq > 0, hence
+            -- `take numIdsToReq objects` is non-null.
+            assert (not $ null newObjectsWithTicketNos) $
+              pure $
+                SendMsgReplyObjectIds
+                  (BlockingReply (NonEmpty.fromList $ newIds))
+                  (makeBundle st'')
+
+      -----------------------------------------------------------------------
+      SingNonBlocking -> do
+        when (numIdsToReq == 0 && numIdsToAck == 0) $
+          throwIO ProtocolErrorRequestedNothing
+        when (Seq.null outstandingFifo') $
+          throwIO ProtocolErrorRequestNonBlocking
+
+        newContent <-
+          atomically $
+            oprObjectsAfter lastTicketNo (fromIntegral numIdsToReq)
+        newObjectsWithTicketNos <- forM newContent $
+          \(ticketNo, _, getObject) -> do
+            object <- getObject
+            pure (object, ticketNo)
+
+        let !newIds = oprObjectId . fst <$> newObjectsWithTicketNos
+            st'' = updateStNewObjects st' newObjectsWithTicketNos
+
+        traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjectIds newIds)
+
+        pure (SendMsgReplyObjectIds (NonBlockingReply newIds) (makeBundle st''))
+
+  recvMsgRequestObjects ::
+    OutboundSt objectId object ticketNo ->
+    [objectId] ->
+    m (OutboundStObjects objectId object m ())
+  recvMsgRequestObjects !st@OutboundSt{..} requestedIds = do
+    traceWith tracer (TraceObjectDiffusionOutboundRecvMsgRequestObjects requestedIds)
+
+    -- All the objects correspond to advertised objectIds are already in the
+    -- outstandingFifo. So we don't need to read from the object pool here.
+
+    -- I've optimized the search to do only one traversal of 'outstandingFifo'.
+    -- When the 'requestedIds' is exactly the whole 'outstandingFifo', then this
+    -- should take O(n * log n) time.
+    --
+    -- TODO: We might need to revisit the underlying 'outstandingFifo' data
+    -- structure and the search if performance isn't sufficient when we'll use
+    -- ObjectDiffusion for votes diffusion (and not just cert diffusion).
+
+    let requestedIdsSet = Set.fromList requestedIds
+
+    when (Set.size requestedIdsSet /= length requestedIds) $
+      throwIO ProtocolErrorRequestedDuplicateObject
+
+    let requestedObjects =
+          foldr
+            ( \obj acc ->
+                if Set.member (oprObjectId obj) requestedIdsSet
+                  then obj : acc
+                  else acc
+            )
+            []
+            outstandingFifo
+
+    when (Set.size requestedIdsSet /= length requestedObjects) $
+      throwIO ProtocolErrorRequestedUnavailableObject
+
+    traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjects requestedObjects)
+
+    pure (SendMsgReplyObjects requestedObjects (makeBundle st))
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs
new file mode 100644
index 0000000000..f646fa27b4
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs
@@ -0,0 +1,41 @@
+-- | This module defines type aliases for the ObjectDiffusion protocol applied
+-- to PerasCert diffusion.
+module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
+  ( TracePerasCertDiffusionInbound
+  , TracePerasCertDiffusionOutbound
+  , PerasCertPoolReader
+  , PerasCertPoolWriter
+  , PerasCertDiffusionInboundPipelined
+  , PerasCertDiffusionOutbound
+  , PerasCertDiffusion
+  ) where
+
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound
+import Ouroboros.Consensus.Storage.PerasCertDB.API
+import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound (ObjectDiffusionInboundPipelined)
+import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (ObjectDiffusionOutbound)
+import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion, OutboundAgency)
+
+type TracePerasCertDiffusionInbound blk =
+  TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk)
+
+type TracePerasCertDiffusionOutbound blk =
+  TraceObjectDiffusionOutbound PerasRoundNo (PerasCert blk)
+
+type PerasCertPoolReader blk m =
+  ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
+
+type PerasCertPoolWriter blk m =
+  ObjectPoolWriter PerasRoundNo (PerasCert blk) m
+
+type PerasCertDiffusionInboundPipelined blk m a =
+  ObjectDiffusionInboundPipelined PerasRoundNo (PerasCert blk) m a
+
+type PerasCertDiffusionOutbound blk m a =
+  ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a
+
+type PerasCertDiffusion blk =
+  ObjectDiffusion OutboundAgency PerasRoundNo (PerasCert blk)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs
index 6520aae47c..6a4fc87229 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs
@@ -6,8 +6,11 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 -- | Serialisation for sending things across the network.
@@ -33,8 +36,8 @@ module Ouroboros.Consensus.Node.Serialisation
   , Some (..)
   ) where
 
-import Codec.CBOR.Decoding (Decoder)
-import Codec.CBOR.Encoding (Encoding)
+import Codec.CBOR.Decoding (Decoder, decodeListLenOf)
+import Codec.CBOR.Encoding (Encoding, encodeListLen)
 import Codec.Serialise (Serialise (decode, encode))
 import Data.Kind
 import Data.SOP.BasicFunctors
@@ -47,7 +50,15 @@ import Ouroboros.Consensus.Ledger.SupportsMempool
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.TypeFamilyWrappers
 import Ouroboros.Consensus.Util (Some (..))
-import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)
+import Ouroboros.Network.Block
+  ( Tip
+  , decodePoint
+  , decodeTip
+  , encodePoint
+  , encodeTip
+  , unwrapCBORinCBOR
+  , wrapCBORinCBOR
+  )
 
 {-------------------------------------------------------------------------------
   NodeToNode
@@ -173,6 +184,29 @@ deriving newtype instance
   SerialiseNodeToNode blk (GenTxId blk) =>
   SerialiseNodeToNode blk (WrapGenTxId blk)
 
+instance ConvertRawHash blk => SerialiseNodeToNode blk (Point blk) where
+  encodeNodeToNode _ccfg _version = encodePoint $ encodeRawHash (Proxy @blk)
+  decodeNodeToNode _ccfg _version = decodePoint $ decodeRawHash (Proxy @blk)
+
+instance ConvertRawHash blk => SerialiseNodeToNode blk (Tip blk) where
+  encodeNodeToNode _ccfg _version = encodeTip $ encodeRawHash (Proxy @blk)
+  decodeNodeToNode _ccfg _version = decodeTip $ decodeRawHash (Proxy @blk)
+
+instance SerialiseNodeToNode blk PerasRoundNo where
+  encodeNodeToNode _ccfg _version = encode
+  decodeNodeToNode _ccfg _version = decode
+instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where
+  -- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras
+  encodeNodeToNode ccfg version PerasCert{..} =
+    encodeListLen 2
+      <> encodeNodeToNode ccfg version pcCertRound
+      <> encodeNodeToNode ccfg version pcCertBoostedBlock
+  decodeNodeToNode ccfg version = do
+    decodeListLenOf 2
+    pcCertRound <- decodeNodeToNode ccfg version
+    pcCertBoostedBlock <- decodeNodeToNode ccfg version
+    pure $ PerasCert pcCertRound pcCertBoostedBlock
+
 deriving newtype instance
   SerialiseNodeToClient blk (GenTxId blk) =>
   SerialiseNodeToClient blk (WrapGenTxId blk)
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
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..783c3b6a04
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs
@@ -0,0 +1,379 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | Data structure for tracking the weight of blocks due to Peras boosts.
+module Ouroboros.Consensus.Peras.Weight
+  ( -- * 'PerasWeightSnapshot' type
+    PerasWeightSnapshot
+
+    -- * Construction
+  , emptyPerasWeightSnapshot
+  , mkPerasWeightSnapshot
+
+    -- * Conversion
+  , perasWeightSnapshotToList
+
+    -- * Insertion
+  , addToPerasWeightSnapshot
+
+    -- * Pruning
+  , prunePerasWeightSnapshot
+
+    -- * 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
+
+-- | Data structure for tracking the weight of blocks due to Peras boosts.
+newtype PerasWeightSnapshot blk = PerasWeightSnapshot
+  { getPerasWeightSnapshot :: Map (Point blk) PerasWeight
+  }
+  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
+-- [(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)] ->
+  PerasWeightSnapshot blk
+mkPerasWeightSnapshot =
+  Foldable.foldl'
+    (\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
+-- [(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
+
+-- | 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
+-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 2)]
+--
+-- >>> snap1 = addToPerasWeightSnapshot (BlockPoint 3 "bar") (PerasWeight 2) snap0
+-- >>> snap1
+-- [(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
+-- [(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 ->
+  PerasWeight ->
+  PerasWeightSnapshot blk ->
+  PerasWeightSnapshot blk
+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
+-- [(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
+--
+-- >>> prunePerasWeightSnapshot (SlotNo 3) snap
+-- [(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)]
+prunePerasWeightSnapshot ::
+  SlotNo ->
+  PerasWeightSnapshot blk ->
+  PerasWeightSnapshot blk
+prunePerasWeightSnapshot slot =
+  PerasWeightSnapshot . Map.dropWhileAntitone isTooOld . getPerasWeightSnapshot
+ where
+  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 =>
+  PerasWeightSnapshot blk -> Point blk -> PerasWeight
+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.
+  (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
+  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)
+
+-- | 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 -XDataKinds -XTypeApplications -XTypeFamilies
+-- >>> data Blk = Blk
+-- >>> type instance HeaderHash Blk = String
+-- >>> instance StandardHash Blk
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/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
index 303fbcf78e..582436e8a0 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
@@ -83,6 +87,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,6 +95,7 @@ import Ouroboros.Consensus.Storage.LedgerDB
   , ReadOnlyForker'
   , Statistics
   )
+import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertSnapshot)
 import Ouroboros.Consensus.Storage.Serialisation
 import Ouroboros.Consensus.Util.CallStack
 import Ouroboros.Consensus.Util.IOLike
@@ -386,6 +392,12 @@ data ChainDB m blk = ChainDB
   , getStatistics :: m (Maybe Statistics)
   -- ^ Get statistics from the LedgerDB, in particular the number of entries
   -- in the tables.
+  , addPerasCertAsync :: PerasCert blk -> m (AddPerasCertPromise m)
+  -- ^ TODO
+  , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
+  -- ^ TODO
+  , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk)
+  -- ^ TODO
   , closeDB :: m ()
   -- ^ Close the ChainDB
   --
@@ -505,6 +517,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 a33055b067..a49173a15a 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 (..)
@@ -53,6 +54,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
@@ -78,6 +80,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
@@ -86,6 +89,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,20 +164,26 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
   (chainDB, testing, env) <- lift $ do
     traceWith tracer $ TraceOpenEvent (OpenedVolatileDB maxSlot)
     traceWith tracer $ TraceOpenEvent StartedOpeningLgrDB
+    (ledgerDbGetVolatileSuffix, setGetCurrentChainForLedgerDB) <-
+      mkLedgerDbGetVolatileSuffix
     (lgrDB, replayed) <-
       LedgerDB.openDB
         argsLgrDb
         (ImmutableDB.streamAPI immutableDB)
         immutableDbTipPoint
         (Query.getAnyKnownBlock immutableDB volatileDB)
+        ledgerDbGetVolatileSuffix
     traceWith tracer $ TraceOpenEvent OpenedLgrDB
 
+    perasCertDB <- PerasCertDB.openDB argsPerasCertDB
+
     varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0))
 
     let initChainSelTracer = TraceInitChainSelEvent >$< tracer
 
     traceWith initChainSelTracer StartedInitChainSelection
     initialLoE <- Args.cdbsLoE cdbSpecificArgs
+    initialWeights <- atomically $ PerasCertDB.getWeightSnapshot perasCertDB
     chain <- withRegistry $ \rr -> do
       chainAndLedger <-
         ChainSel.initialChainSelection
@@ -185,6 +195,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
           (Args.cdbsTopLevelConfig cdbSpecificArgs)
           varInvalid
           (void initialLoE)
+          (forgetFingerprint initialWeights)
       traceWith initChainSelTracer InitialChainSelected
 
       let chain = VF.validatedFragment chainAndLedger
@@ -245,7 +256,11 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , cdbChainSelQueue = chainSelQueue
             , cdbLoE = Args.cdbsLoE cdbSpecificArgs
             , cdbChainSelStarvation = varChainSelStarvation
+            , cdbPerasCertDB = perasCertDB
             }
+
+    setGetCurrentChainForLedgerDB $ Query.getCurrentChain env
+
     h <- fmap CDBHandle $ newTVarIO $ ChainDbOpen env
     let chainDB =
           API.ChainDB
@@ -272,13 +287,18 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , getHeaderStateHistory = getEnvSTM h Query.getHeaderStateHistory
             , getReadOnlyForkerAtPoint = getEnv2 h Query.getReadOnlyForkerAtPoint
             , getStatistics = getEnv h Query.getStatistics
+            , addPerasCertAsync = getEnv1 h ChainSel.addPerasCertAsync
+            , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot
+            , getPerasCertSnapshot = getEnvSTM h Query.getPerasCertSnapshot
             }
     addBlockTestFuse <- newFuse "test chain selection"
     copyTestFuse <- newFuse "test copy to immutable db"
     let testing =
           Internal
             { intCopyToImmutableDB = getEnv h (withFuse copyTestFuse . Background.copyToImmutableDB)
-            , intGarbageCollect = getEnv1 h Background.garbageCollect
+            , intGarbageCollect = \slot -> getEnv h $ \e -> do
+                Background.garbageCollectBlocks e slot
+                LedgerDB.garbageCollect (cdbLedgerDB e) slot
             , intTryTakeSnapshot = getEnv h $ \env' ->
                 void $ LedgerDB.tryTakeSnapshot (cdbLedgerDB env') Nothing maxBound
             , intAddBlockRunner = getEnv h (Background.addBlockRunner addBlockTestFuse)
@@ -300,7 +320,44 @@ 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
+  -- 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 ::
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/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
index 71a4abcbbc..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
@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -19,11 +20,10 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Background
     launchBgTasks
 
     -- * Copying blocks from the VolatileDB to the ImmutableDB
-  , copyAndSnapshotRunner
   , copyToImmutableDB
 
     -- * Executing garbage collection
-  , garbageCollect
+  , garbageCollectBlocks
 
     -- * Scheduling garbage collections
   , GcParams (..)
@@ -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,13 +67,16 @@ 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
+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
 import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Consensus.Util.STM (Watcher (..), forkLinkedWatcher)
 import Ouroboros.Network.AnchoredFragment (AnchoredSeq (..))
 import qualified Ouroboros.Network.AnchoredFragment as AF
 
@@ -99,17 +100,30 @@ launchBgTasks cdb@CDB{..} replayed = do
   !addBlockThread <-
     launch "ChainDB.addBlockRunner" $
       addBlockRunner cdbChainSelFuse cdb
+
+  ledgerDbTasksTrigger <- newLedgerDbTasksTrigger replayed
+  !ledgerDbMaintenaceThread <-
+    forkLinkedWatcher cdbRegistry "ChainDB.ledgerDbTaskWatcher" $
+      ledgerDbTaskWatcher cdb ledgerDbTasksTrigger
+
   gcSchedule <- newGcSchedule
   !gcThread <-
-    launch "ChainDB.gcScheduleRunner" $
+    launch "ChainDB.gcBlocksScheduleRunner" $
       gcScheduleRunner gcSchedule $
-        garbageCollect cdb
-  !copyAndSnapshotThread <-
-    launch "ChainDB.copyAndSnapshotRunner" $
-      copyAndSnapshotRunner cdb gcSchedule replayed cdbCopyFuse
+        garbageCollectBlocks cdb
+
+  !copyToImmutableDBThread <-
+    launch "ChainDB.copyToImmutableDBRunner" $
+      copyToImmutableDBRunner cdb ledgerDbTasksTrigger gcSchedule cdbCopyFuse
+
   atomically $
     writeTVar cdbKillBgThreads $
-      sequence_ [addBlockThread, gcThread, copyAndSnapshotThread]
+      sequence_
+        [ addBlockThread
+        , cancelThread ledgerDbMaintenaceThread
+        , gcThread
+        , copyToImmutableDBThread
+        ]
  where
   launch :: String -> m Void -> m (m ())
   launch = fmap cancelThread .: forkLinkedThread cdbRegistry
@@ -118,10 +132,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'.
 --
@@ -139,10 +154,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 $
@@ -151,10 +167,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
@@ -179,7 +195,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
@@ -198,22 +213,20 @@ copyToImmutableDB CDB{..} = electric $ do
       _ -> error "header to remove not on the current chain"
 
 {-------------------------------------------------------------------------------
-  Snapshotting
+  Copy to ImmutableDB
 -------------------------------------------------------------------------------}
 
--- | Copy blocks from the VolatileDB to ImmutableDB and take snapshots of the
--- LedgerDB
+-- | 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,
 --
--- * We periodically take a snapshot of the LedgerDB (depending on its config).
---   When enough blocks (depending on its config) have been replayed during
---   startup, a snapshot of the replayed LedgerDB will be written to disk at the
---   start of this function. NOTE: After this initial snapshot we do not take a
---   snapshot of the LedgerDB until the chain has changed again, irrespective of
---   the LedgerDB policy.
+-- * Trigger LedgerDB maintenance tasks, namely flushing, taking snapshots and
+--   garbage collection.
 --
 -- * Schedule GC of the VolatileDB ('scheduleGC') for the 'SlotNo' of the most
 --   recent block that was copied.
@@ -228,50 +241,40 @@ copyToImmutableDB CDB{..} = electric $ do
 -- GC can happen, when we restart the node and schedule the /next/ GC, it will
 -- /imply/ any previously scheduled GC, since GC is driven by slot number
 -- ("garbage collect anything older than @x@").
-copyAndSnapshotRunner ::
+copyToImmutableDBRunner ::
   forall m blk.
   ( IOLike m
   , LedgerSupportsProtocol blk
   ) =>
   ChainDbEnv m blk ->
+  LedgerDbTasksTrigger m ->
   GcSchedule m ->
-  -- | Number of immutable blocks replayed on ledger DB startup
-  Word64 ->
   Fuse m ->
   m Void
-copyAndSnapshotRunner cdb@CDB{..} gcSchedule replayed fuse = do
+copyToImmutableDBRunner cdb@CDB{..} ledgerDbTasksTrigger gcSchedule fuse = do
   -- this first flush will persist the differences that come from the initial
   -- chain selection.
   LedgerDB.tryFlush cdbLedgerDB
-  loop =<< LedgerDB.tryTakeSnapshot cdbLedgerDB Nothing replayed
+  forever copyAndTrigger
  where
-  SecurityParam k = configSecurityParam cdbTopLevelConfig
-
-  loop :: LedgerDB.SnapCounters -> m Void
-  loop counters = do
-    let LedgerDB.SnapCounters
-          { prevSnapshotTime
-          , ntBlocksSinceLastSnap
-          } = counters
-
-    -- Wait for the chain to grow larger than @k@
+  copyAndTrigger :: m ()
+  copyAndTrigger = do
+    -- 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
     --
     -- This is a synchronous operation: when it returns, the blocks have been
     -- copied to disk (though not flushed, necessarily).
-    withFuse fuse (copyToImmutableDB cdb) >>= scheduleGC'
+    gcSlotNo <- withFuse fuse (copyToImmutableDB cdb)
 
-    LedgerDB.tryFlush cdbLedgerDB
-
-    now <- getMonotonicTime
-    let ntBlocksSinceLastSnap' = ntBlocksSinceLastSnap + numToWrite
-
-    loop =<< LedgerDB.tryTakeSnapshot cdbLedgerDB ((,now) <$> prevSnapshotTime) ntBlocksSinceLastSnap'
+    triggerLedgerDbTasks ledgerDbTasksTrigger gcSlotNo numToWrite
+    scheduleGC' gcSlotNo
 
   scheduleGC' :: WithOrigin SlotNo -> m ()
   scheduleGC' Origin = return ()
@@ -285,6 +288,97 @@ copyAndSnapshotRunner cdb@CDB{..} gcSchedule replayed fuse = do
         }
       gcSchedule
 
+{-------------------------------------------------------------------------------
+  LedgerDB maintenance tasks
+-------------------------------------------------------------------------------}
+
+-- | Trigger for the LedgerDB maintenance tasks, namely whenever the immutable
+-- DB tip slot advances when we finish copying blocks to it.
+newtype LedgerDbTasksTrigger m
+  = LedgerDbTasksTrigger (StrictTVar m LedgerDbTaskState)
+
+data LedgerDbTaskState = LedgerDbTaskState
+  { ldbtsImmTip :: !(WithOrigin SlotNo)
+  , ldbtsPrevSnapshotTime :: !(Maybe Time)
+  , ldbtsBlocksSinceLastSnapshot :: !Word64
+  }
+  deriving stock Generic
+  deriving anyclass NoThunks
+
+newLedgerDbTasksTrigger ::
+  IOLike m =>
+  -- | Number of blocks replayed.
+  Word64 ->
+  m (LedgerDbTasksTrigger m)
+newLedgerDbTasksTrigger replayed = LedgerDbTasksTrigger <$> newTVarIO st
+ where
+  st =
+    LedgerDbTaskState
+      { ldbtsImmTip = Origin
+      , ldbtsPrevSnapshotTime = Nothing
+      , ldbtsBlocksSinceLastSnapshot = replayed
+      }
+
+triggerLedgerDbTasks ::
+  forall m.
+  IOLike m =>
+  LedgerDbTasksTrigger m ->
+  -- | New tip of the ImmutableDB.
+  WithOrigin SlotNo ->
+  -- | Number of blocks written to the ImmutableDB.
+  Word64 ->
+  m ()
+triggerLedgerDbTasks (LedgerDbTasksTrigger varSt) immTip numWritten =
+  atomically $ modifyTVar varSt $ \st ->
+    st
+      { ldbtsImmTip = immTip
+      , ldbtsBlocksSinceLastSnapshot = ldbtsBlocksSinceLastSnapshot st + numWritten
+      }
+
+-- | Run LedgerDB maintenance tasks when 'LedgerDbTasksTrigger' changes.
+--
+--  * Flushing of differences.
+--  * Taking snapshots.
+--  * Garbage collection.
+ledgerDbTaskWatcher ::
+  forall m blk.
+  IOLike m =>
+  ChainDbEnv m blk ->
+  LedgerDbTasksTrigger m ->
+  Watcher m LedgerDbTaskState (WithOrigin SlotNo)
+ledgerDbTaskWatcher CDB{..} (LedgerDbTasksTrigger varSt) =
+  Watcher
+    { wFingerprint = ldbtsImmTip
+    , wInitial = Nothing
+    , wReader = readTVar varSt
+    , wNotify =
+        \LedgerDbTaskState
+           { ldbtsImmTip
+           , ldbtsBlocksSinceLastSnapshot = blocksSinceLast
+           , ldbtsPrevSnapshotTime = prevSnapTime
+           } ->
+            whenJust (withOriginToMaybe ldbtsImmTip) $ \slotNo -> do
+              LedgerDB.tryFlush cdbLedgerDB
+
+              now <- getMonotonicTime
+              LedgerDB.SnapCounters
+                { prevSnapshotTime
+                , ntBlocksSinceLastSnap
+                } <-
+                LedgerDB.tryTakeSnapshot
+                  cdbLedgerDB
+                  ((,now) <$> prevSnapTime)
+                  blocksSinceLast
+              atomically $ modifyTVar varSt $ \st ->
+                st
+                  { ldbtsBlocksSinceLastSnapshot =
+                      ldbtsBlocksSinceLastSnapshot st - blocksSinceLast + ntBlocksSinceLastSnap
+                  , ldbtsPrevSnapshotTime = prevSnapshotTime
+                  }
+
+              LedgerDB.garbageCollect cdbLedgerDB slotNo
+    }
+
 {-------------------------------------------------------------------------------
   Executing garbage collection
 -------------------------------------------------------------------------------}
@@ -292,9 +386,6 @@ copyAndSnapshotRunner cdb@CDB{..} gcSchedule replayed fuse = do
 -- | Trigger a garbage collection for blocks older than the given 'SlotNo' on
 -- the VolatileDB.
 --
--- Also removes the corresponding cached "previously applied points" from the
--- LedgerDB.
---
 -- This is thread-safe as the VolatileDB locks itself while performing a GC.
 --
 -- When calling this function it is __critical__ that the blocks that will be
@@ -304,12 +395,12 @@ copyAndSnapshotRunner cdb@CDB{..} gcSchedule replayed fuse = do
 --
 -- TODO will a long GC be a bottleneck? It will block any other calls to
 -- @putBlock@ and @getBlock@.
-garbageCollect :: forall m blk. IOLike m => ChainDbEnv m blk -> SlotNo -> m ()
-garbageCollect CDB{..} slotNo = do
+garbageCollectBlocks :: forall m blk. IOLike m => ChainDbEnv m blk -> SlotNo -> m ()
+garbageCollectBlocks CDB{..} slotNo = do
   VolatileDB.garbageCollect cdbVolatileDB slotNo
   atomically $ do
-    LedgerDB.garbageCollect cdbLedgerDB slotNo
     modifyTVar cdbInvalid $ fmap $ Map.filter ((>= slotNo) . invalidBlockSlotNo)
+  PerasCertDB.garbageCollect cdbPerasCertDB slotNo
   traceWith cdbTracer $ TraceGCEvent $ PerformedGC slotNo
 
 {-------------------------------------------------------------------------------
@@ -543,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
@@ -551,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 1fbd49f467..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,13 +13,14 @@
 -- adding a block.
 module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel
   ( addBlockAsync
+  , addPerasCertAsync
   , chainSelSync
   , chainSelectionForBlock
   , initialChainSelection
   , triggerChainSelectionAsync
 
     -- * Exported for testing purposes
-  , olderThanK
+  , olderThanImmTip
   ) where
 
 import Cardano.Ledger.BaseTypes (unNonZero)
@@ -38,7 +39,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,9 +64,12 @@ 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 (..)
   , AddBlockResult (..)
+  , AddPerasCertPromise
   , BlockComponent (..)
   , ChainType (..)
   , LoE (..)
@@ -89,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 (..))
@@ -122,6 +128,7 @@ initialChainSelection ::
   TopLevelConfig blk ->
   StrictTVar m (WithFingerprint (InvalidBlocks blk)) ->
   LoE () ->
+  PerasWeightSnapshot blk ->
   m (ChainAndLedger m blk)
 initialChainSelection
   immutableDB
@@ -131,7 +138,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.
     --
@@ -176,7 +184,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' ->
@@ -258,7 +266,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
@@ -273,6 +281,7 @@ initialChainSelection
             , bcfg
             , varInvalid
             , blockCache = BlockCache.empty
+            , weights
             , curChainAndLedger
             , validationTracer = InitChainSelValidation >$< tracer
             , -- initial chain selection is not concerned about pipelining
@@ -318,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.
@@ -404,8 +422,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)
@@ -456,34 +474,90 @@ 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
--- 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
@@ -540,14 +614,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
@@ -594,9 +669,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
@@ -612,14 +687,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
@@ -636,14 +711,11 @@ 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
 
-  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
@@ -654,6 +726,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
@@ -668,12 +741,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)
 
@@ -696,7 +770,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
@@ -721,11 +795,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
 
@@ -785,6 +860,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)) ->
@@ -792,7 +868,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
@@ -804,7 +880,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
             )
         )
@@ -815,10 +891,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,36 +908,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
 
   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
 
@@ -871,14 +950,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.
@@ -893,13 +971,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 $
@@ -963,7 +1042,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) $
@@ -1023,6 +1107,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
@@ -1068,7 +1153,7 @@ chainSelection ::
 chainSelection chainSelEnv rr chainDiffs =
   assert
     ( all
-        (preferAnchoredCandidate bcfg curChain . Diff.getSuffix)
+        (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix)
         chainDiffs
     )
     $ assert
@@ -1083,8 +1168,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
@@ -1120,7 +1204,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
@@ -1178,7 +1262,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]
@@ -1386,3 +1470,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/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs
index 821586f745..353bae1f65 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
@@ -18,6 +19,8 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query
   , getIsValid
   , getMaxSlotNo
   , getPastLedger
+  , getPerasWeightSnapshot
+  , getPerasCertSnapshot
   , getReadOnlyForkerAtPoint
   , getStatistics
   , getTipBlock
@@ -31,7 +34,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
@@ -43,6 +45,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
+  , takeVolatileSuffix
+  )
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( BlockComponent (..)
@@ -52,6 +58,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 (PerasCertSnapshot)
 import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB)
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import Ouroboros.Consensus.Util (eitherToMaybe)
@@ -83,29 +91,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.
@@ -262,6 +285,14 @@ 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 (WithFingerprint (PerasWeightSnapshot blk))
+getPerasWeightSnapshot CDB{..} = PerasCertDB.getWeightSnapshot cdbPerasCertDB
+
+getPerasCertSnapshot ::
+  ChainDbEnv m blk -> STM m (PerasCertSnapshot blk)
+getPerasCertSnapshot CDB{..} = PerasCertDB.getCertSnapshot cdbPerasCertDB
+
 {-------------------------------------------------------------------------------
   Unifying interface over the immutable DB and volatile DB, but independent
   of the ledger DB. These functions therefore do not require the entire
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..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
@@ -99,10 +100,12 @@ 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 (..)
   , AddBlockResult (..)
+  , AddPerasCertPromise (..)
   , ChainDbError (..)
   , ChainSelectionPromise (..)
   , ChainType
@@ -124,6 +127,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 +354,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
 
@@ -545,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'.
@@ -593,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 =>
@@ -647,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
@@ -676,6 +707,8 @@ processedChainSelMessage ::
 processedChainSelMessage ChainSelQueue{varChainSelPoints} = \case
   ChainSelAddBlock BlockToAdd{blockToAdd = blk} ->
     modifyTVar varChainSelPoints $ MultiSet.delete (blockRealPoint blk)
+  ChainSelAddPerasCert{} ->
+    pure ()
   ChainSelReprocessLoEBlocks{} ->
     pure ()
 
@@ -717,8 +750,10 @@ data TraceEvent blk
   | TraceLedgerDBEvent (LedgerDB.TraceEvent blk)
   | TraceImmutableDBEvent (ImmutableDB.TraceEvent blk)
   | TraceVolatileDBEvent (VolatileDB.TraceEvent blk)
+  | TracePerasCertDbEvent (PerasCertDB.TraceEvent blk)
   | TraceLastShutdownUnclean
   | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk)
+  | TraceAddPerasCertEvent (TraceAddPerasCertEvent blk)
   deriving Generic
 
 deriving instance
@@ -793,27 +828,28 @@ 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
-  = -- | 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.
@@ -1024,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/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/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs
index 3491f343da..8db64c44bc 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs
@@ -251,9 +251,15 @@ data LedgerDB m l blk = LedgerDB
   -- back as many blocks as the passed @Word64@.
   , getPrevApplied :: STM m (Set (RealPoint blk))
   -- ^ Get the references to blocks that have previously been applied.
-  , garbageCollect :: SlotNo -> STM m ()
-  -- ^ Garbage collect references to old blocks that have been previously
-  -- applied and committed.
+  , garbageCollect :: SlotNo -> m ()
+  -- ^ Garbage collect references to old state that is older than the given
+  -- slot.
+  --
+  -- Concretely, this affects:
+  --
+  --  * Ledger states (and potentially underlying handles for on-disk storage).
+  --
+  --  * The set of previously applied points.
   , tryTakeSnapshot ::
       l ~ ExtLedgerState blk =>
       Maybe (Time, Time) ->
@@ -298,7 +304,14 @@ data TestInternals m l blk = TestInternals
   { wipeLedgerDB :: m ()
   , takeSnapshotNOW :: WhereToTakeSnapshot -> Maybe String -> m ()
   , push :: ExtLedgerState blk DiffMK -> m ()
+  -- ^ Push a ledger state, and prune the 'LedgerDB' to its immutable tip.
+  --
+  -- This does not modify the set of previously applied points.
   , reapplyThenPushNOW :: blk -> m ()
+  -- ^ Apply block to the tip ledger state (using reapplication), and prune the
+  -- 'LedgerDB' to its immutable tip.
+  --
+  -- This does not modify the set of previously applied points.
   , truncateSnapshots :: m ()
   , closeLedgerDB :: m ()
   , getNumLedgerTablesHandles :: m Word64
@@ -456,11 +469,10 @@ data InitDB db m blk = InitDB
   -- ^ Closing the database, to be reopened again with a different snapshot or
   -- with the genesis state.
   , initReapplyBlock :: !(LedgerDbCfg (ExtLedgerState blk) -> blk -> db -> m db)
-  -- ^ Reapply a block from the immutable DB when initializing the DB.
+  -- ^ Reapply a block from the immutable DB when initializing the DB. Prune the
+  -- LedgerDB such that there are no volatile states.
   , currentTip :: !(db -> LedgerState blk EmptyMK)
   -- ^ Getting the current tip for tracing the Ledger Events.
-  , pruneDb :: !(db -> m db)
-  -- ^ Prune the database so that no immutable states are considered volatile.
   , mkLedgerDb ::
       !(db -> m (LedgerDB m (ExtLedgerState blk) blk, TestInternals m (ExtLedgerState blk) blk))
   -- ^ Create a LedgerDB from the initialized data structures from previous
@@ -545,13 +557,7 @@ initialize
         Left err -> do
           closeDb initDb
           error $ "Invariant violation: invalid immutable chain " <> show err
-        Right (db, replayed) -> do
-          db' <- pruneDb dbIface db
-          return
-            ( acc InitFromGenesis
-            , db'
-            , replayed
-            )
+        Right (db, replayed) -> return (acc InitFromGenesis, db, replayed)
     tryNewestFirst acc (s : ss) = do
       eInitDb <- initFromSnapshot s
       case eInitDb of
@@ -603,9 +609,7 @@ initialize
               Monad.when (diskSnapshotIsTemporary s) $ deleteSnapshot hasFS s
               closeDb initDb
               tryNewestFirst (acc . InitFailure s err) ss
-            Right (db, replayed) -> do
-              db' <- pruneDb dbIface db
-              return (acc (InitFromSnapshot s pt), db', replayed)
+            Right (db, replayed) -> return (acc (InitFromSnapshot s pt), db, replayed)
 
     replayTracer' =
       decorateReplayTracerWithGoal
@@ -775,10 +779,10 @@ type LedgerSupportsLedgerDB blk =
 -------------------------------------------------------------------------------}
 
 -- | Options for prunning the LedgerDB
---
--- Rather than using a plain `Word64` we use this to be able to distinguish that
--- we are indeed using
---   1. @0@ in places where it is necessary
---   2. the security parameter as is, in other places
-data LedgerDbPrune = LedgerDbPruneAll | LedgerDbPruneKeeping SecurityParam
+data LedgerDbPrune
+  = -- | Prune all states, keeping only the current tip.
+    LedgerDbPruneAll
+  | -- | Prune such that all (non-anchor) states are not older than the given
+    -- slot.
+    LedgerDbPruneBeforeSlot SlotNo
   deriving Show
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 aa08ce0cec..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
@@ -26,6 +26,7 @@ import Control.Monad.Trans (lift)
 import Control.ResourceRegistry
 import Control.Tracer
 import qualified Data.Foldable as Foldable
+import Data.Functor ((<&>))
 import Data.Functor.Contravariant ((>$<))
 import Data.Kind (Type)
 import Data.Map (Map)
@@ -82,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
@@ -119,7 +121,6 @@ mkInitDb args bss getBlock =
               else pure chlog'
         pure (chlog'', r, bstore)
     , currentTip = \(ch, _, _) -> ledgerState . current $ ch
-    , pruneDb = \(ch, r, bs) -> pure (pruneToImmTipOnly ch, r, bs)
     , mkLedgerDb = \(db, ldbBackingStoreKey, ldbBackingStore) -> do
         (varDB, prevApplied) <-
           (,) <$> newTVarIO db <*> newTVarIO Set.empty
@@ -142,6 +143,7 @@ mkInitDb args bss getBlock =
                 , ldbShouldFlush = shouldFlush flushFreq
                 , ldbQueryBatchSize = lgrQueryBatchSize
                 , ldbResolveBlock = getBlock
+                , ldbGetVolatileSuffix = getVolatileSuffix
                 }
         h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
         pure $ implMkLedgerDb h
@@ -185,7 +187,7 @@ implMkLedgerDb h =
       , getForkerAtTarget = newForkerAtTarget h
       , validateFork = getEnv5 h (implValidate h)
       , getPrevApplied = getEnvSTM h implGetPrevApplied
-      , garbageCollect = getEnvSTM1 h implGarbageCollect
+      , garbageCollect = getEnv1 h implGarbageCollect
       , tryTakeSnapshot = getEnv2 h implTryTakeSnapshot
       , tryFlush = getEnv h implTryFlush
       , closeDB = implCloseDB h
@@ -200,10 +202,16 @@ implGetVolatileTip ::
 implGetVolatileTip = fmap current . readTVar . ldbChangelog
 
 implGetImmutableTip ::
-  MonadSTM m =>
+  (MonadSTM m, GetTip l) =>
   LedgerDBEnv m l blk ->
   STM m (l EmptyMK)
-implGetImmutableTip = fmap anchor . readTVar . ldbChangelog
+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 . volSuffix . changelogStates)
+    . readTVar
+    $ ldbChangelog env
 
 implGetPastLedgerState ::
   ( MonadSTM m
@@ -214,7 +222,18 @@ implGetPastLedgerState ::
   , HeaderHash l ~ HeaderHash blk
   ) =>
   LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
-implGetPastLedgerState env point = getPastLedgerAt point <$> readTVar (ldbChangelog env)
+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
+    -- immutable tip).
+    guard $
+      AS.withinBounds
+        (pointSlot point)
+        ((point ==) . castPoint . either getTip getTip)
+        (volSuffix (changelogStates chlog))
+    getPastLedgerAt point chlog
 
 implGetHeaderStateHistory ::
   ( MonadSTM m
@@ -226,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
@@ -237,6 +257,9 @@ implGetHeaderStateHistory env = do
   pure
     . HeaderStateHistory
     . 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.
+    . volSuffix
     $ changelogStates ldb
 
 implValidate ::
@@ -274,10 +297,17 @@ implValidate h ldbEnv rr tr cache rollbacks hdrs =
 implGetPrevApplied :: MonadSTM m => LedgerDBEnv m l blk -> STM m (Set (RealPoint blk))
 implGetPrevApplied env = readTVar (ldbPrevApplied env)
 
--- | Remove all points with a slot older than the given slot from the set of
--- previously applied points.
-implGarbageCollect :: MonadSTM m => LedgerDBEnv m l blk -> SlotNo -> STM m ()
-implGarbageCollect env slotNo =
+-- | Remove 'DbChangelog' states older than the given slot, and all points with
+-- a slot older than the given slot from the set of previously applied points.
+implGarbageCollect ::
+  ( MonadSTM m
+  , IsLedger (LedgerState blk)
+  , l ~ ExtLedgerState blk
+  ) =>
+  LedgerDBEnv m l blk -> SlotNo -> m ()
+implGarbageCollect env slotNo = atomically $ do
+  modifyTVar (ldbChangelog env) $
+    prune (LedgerDbPruneBeforeSlot slotNo)
   modifyTVar (ldbPrevApplied env) $
     Set.dropWhileAntitone ((< slotNo) . realPointSlot)
 
@@ -410,7 +440,7 @@ implIntPush ::
   LedgerDBEnv m l blk -> l DiffMK -> m ()
 implIntPush env st = do
   chlog <- readTVarIO $ ldbChangelog env
-  let chlog' = prune (LedgerDbPruneKeeping (ledgerDbCfgSecParam $ ldbCfg env)) $ extend st chlog
+  let chlog' = pruneToImmTipOnly $ extend st chlog
   atomically $ writeTVar (ldbChangelog env) chlog'
 
 implIntReapplyThenPush ::
@@ -545,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
 
@@ -729,27 +760,39 @@ 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 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
+        | otherwise = case rollback pt dblog of
+            Nothing -> throwError PointNotOnChain
+            Just dblog' -> pure dblog'
   -- Get the prefix of the dblog ending in the specified target.
   case target of
     Right VolatileTip -> pure dblog
-    Right ImmutableTip -> pure $ rollbackToAnchor dblog
-    Right (SpecificPoint pt) -> do
-      let immTip = getTip $ anchor dblog
-      case rollback pt dblog of
-        Nothing
-          | pointSlot pt < pointSlot immTip -> throwError $ PointTooOld Nothing
-          | otherwise -> throwError PointNotOnChain
-        Just dblog' -> pure dblog'
-    Left n -> case rollbackN n dblog of
-      Nothing ->
+    Right ImmutableTip -> rollbackTo immTip
+    Right (SpecificPoint pt) -> rollbackTo pt
+    Left n -> do
+      when (n > rollbackMax) $
         throwError $
           PointTooOld $
             Just
               ExceededRollback
-                { rollbackMaximum = maxRollback dblog
+                { rollbackMaximum = rollbackMax
                 , rollbackRequested = n
                 }
-      Just dblog' -> pure dblog'
+      case rollbackN n dblog of
+        Nothing -> error "unreachable"
+        Just dblog' -> pure dblog'
 
 {-------------------------------------------------------------------------------
   Make forkers from consistent views
@@ -761,6 +804,7 @@ newForker ::
   , LedgerSupportsProtocol blk
   , NoThunks (l EmptyMK)
   , GetTip l
+  , StandardHash l
   ) =>
   LedgerDBHandle m l blk ->
   LedgerDBEnv m l blk ->
@@ -776,7 +820,6 @@ newForker h ldbEnv rr dblog = readLocked $ do
           { foeBackingStoreValueHandle = forkerMVar
           , foeChangelog = dblogVar
           , foeSwitchVar = ldbChangelog ldbEnv
-          , foeSecurityParam = ledgerDbCfgSecParam $ ldbCfg ldbEnv
           , foeTracer =
               LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv
           }
@@ -798,6 +841,7 @@ mkForker ::
   , HasHeader blk
   , HasLedgerTables l
   , GetTip l
+  , StandardHash l
   ) =>
   LedgerDBHandle m l blk ->
   QueryBatchSize ->
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs
index f402fde67d..bf913d6062 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs
@@ -47,8 +47,8 @@
 -- == Carrying states
 --
 -- The 'DbChangelog' contains an instantiation of the 'AnchoredSeq' data type to
--- hold the last \(k\) in-memory ledger states. This data type is impemented
--- using the /finger tree/ data structure and has the following time
+-- hold (at least) the last \(k\) in-memory ledger states. This data type is
+-- implemented using the /finger tree/ data structure and has the following time
 -- complexities:
 --
 -- - Appending a new ledger state to the end in constant time.
@@ -67,16 +67,12 @@
 --
 -- == Appending in-memory states
 --
--- When a new ledger state is appended to a fully saturated 'DbChangelog' (i.e.
--- that contains \(k\) states), the ledger state at the anchor is dropped and
--- the oldest element in the sequence becomes the new anchor, as it has become
--- immutable. Note that we only refer here to the in-memory states, as the diffs
--- from the anchor will remain in the 'DbChangelog' until flushing happens. This
--- maintains the invariant that only the last \(k\) in-memory ledger states are
--- stored, /excluding/ the ledger state at the anchor. This means that in
--- practice, \(k + 1\) ledger states will be kept in memory. When the
--- 'DbChangelog' contains fewer than \(k\) elements, new ones are appended
--- without shifting the anchor until it is saturated.
+-- When a new ledger state is appended to a 'DbChangelog', the ledger state at
+-- the anchor is now subject to pruning/garbage collection as they are
+-- immutable. This means that in practice, slightly more than \(k + 1\) ledger
+-- states will be kept in memory. When the 'DbChangelog' contains fewer than
+-- \(k\) elements, new ones are appended without causing the ones near the
+-- anchor to be pruned/garbage-collected.
 --
 -- == Getting and appending differences
 --
@@ -223,7 +219,8 @@ import qualified Ouroboros.Network.AnchoredSeq as AS
 -- that need a 'BackingStore' as an anchor point.
 --
 -- We illustrate its contents below, where @k = 3@ (for a state @Li@, the
--- corresponding set of differences is @Di@):
+-- corresponding set of differences is @Di@), assuming that we prune after every
+-- step:
 --
 -- +----------------+------------------------------------+------------------------------------------+
 -- | lastFlushed    | states                             | tableDiffs                               |
@@ -362,27 +359,28 @@ reapplyThenPush ::
   DbChangelog l ->
   m (DbChangelog l)
 reapplyThenPush cfg ap ksReader db =
-  (\current' -> prune (LedgerDbPruneKeeping (ledgerDbCfgSecParam cfg)) $ extend current' db)
+  (\current' -> pruneToImmTipOnly $ extend current' db)
     <$> reapplyBlock (ledgerDbCfgComputeLedgerEvents cfg) (ledgerDbCfg cfg) ap ksReader db
 
--- | Prune oldest ledger states until at we have at most @k@ in the DbChangelog,
--- excluding the one stored at the anchor.
+-- | Prune oldest ledger states according to the given 'LedgerDbPrune' strategy.
 --
 -- +--------------+----------------------------+----------------------+
 -- | lastFlushed  | states                     | tableDiffs           |
 -- +==============+============================+======================+
 -- |     @L0@     | @L0 :> [ L1, L2, L3, L4 ]@ | @[ D1, D2, D3, D4 ]@ |
 -- +--------------+----------------------------+----------------------+
--- | @>> prune (SecurityParam 3)@                                     |
+-- | @>> prune (LedgerDbPruneBeforeSlot 3)@                           |
 -- +--------------+----------------------------+----------------------+
 -- |     @L0@     | @L2 :> [         L3, L4 ]@ | @[ D1, D2, D3, D4 ]@ |
 -- +--------------+----------------------------+----------------------+
+--
+-- where the state @LX@ is from slot @X@.
 prune ::
   GetTip l =>
   LedgerDbPrune ->
   DbChangelog l ->
   DbChangelog l
-prune (LedgerDbPruneKeeping (SecurityParam k)) dblog =
+prune LedgerDbPruneAll dblog =
   dblog{changelogStates = vol'}
  where
   DbChangelog{changelogStates} = dblog
@@ -390,18 +388,15 @@ prune (LedgerDbPruneKeeping (SecurityParam k)) dblog =
   nvol = AS.length changelogStates
 
   vol' =
-    if toEnum nvol <= unNonZero k
-      then changelogStates
-      else snd $ AS.splitAt (nvol - fromEnum (unNonZero k)) changelogStates
-prune LedgerDbPruneAll dblog =
+    snd $ AS.splitAt nvol changelogStates
+prune (LedgerDbPruneBeforeSlot slot) dblog =
   dblog{changelogStates = vol'}
  where
   DbChangelog{changelogStates} = dblog
 
-  nvol = AS.length changelogStates
-
-  vol' =
-    snd $ AS.splitAt nvol changelogStates
+  -- The anchor of @vol'@ might still have a tip slot smaller than @slot@, which
+  -- is fine to ignore (we will prune it later).
+  vol' = snd $ AS.splitAtMeasure (NotOrigin slot) changelogStates
 
 -- NOTE: we must inline 'prune' otherwise we get unexplained thunks in
 -- 'DbChangelog' and thus a space leak. Alternatively, we could disable the
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs
index aa1e162932..a018764611 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs
@@ -29,11 +29,9 @@ import qualified Data.Set as Set
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
-import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.SupportsProtocol
 import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
-import Ouroboros.Consensus.Storage.LedgerDB.API
 import Ouroboros.Consensus.Storage.LedgerDB.Args
 import Ouroboros.Consensus.Storage.LedgerDB.Forker as Forker
 import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore
@@ -46,6 +44,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
 import Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
 import Ouroboros.Consensus.Util.IOLike
+import qualified Ouroboros.Network.AnchoredSeq as AS
 
 {-------------------------------------------------------------------------------
   Forkers
@@ -71,8 +70,6 @@ data ForkerEnv m l blk = ForkerEnv
   --
   -- The anchor of this and 'foeChangelog' might get out of sync if diffs are
   -- flushed, but 'forkerCommit' will take care of this.
-  , foeSecurityParam :: !SecurityParam
-  -- ^ Config
   , foeTracer :: !(Tracer m TraceForkerEvent)
   -- ^ Config
   }
@@ -314,14 +311,12 @@ implForkerPush env newState = do
   traceWith (foeTracer env) ForkerPushStart
   atomically $ do
     chlog <- readTVar (foeChangelog env)
-    let chlog' =
-          prune (LedgerDbPruneKeeping (foeSecurityParam env)) $
-            extend newState chlog
+    let chlog' = extend newState chlog
     writeTVar (foeChangelog env) chlog'
   traceWith (foeTracer env) ForkerPushEnd
 
 implForkerCommit ::
-  (MonadSTM m, GetTip l, HasLedgerTables l) =>
+  (MonadSTM m, GetTip l, StandardHash l, HasLedgerTables l) =>
   ForkerEnv m l blk ->
   STM m ()
 implForkerCommit env = do
@@ -335,9 +330,17 @@ implForkerCommit env = do
             . pointSlot
             . getTip
             $ changelogLastFlushedState orig
+        -- The 'DbChangelog' might have gotten pruned in the meantime.
+        splitAfterOrigAnchor =
+          AS.splitAfterMeasure (pointSlot origAnchor) (either sameState sameState)
+         where
+          sameState = (origAnchor ==) . getTip
+          origAnchor = getTip $ anchor orig
      in DbChangelog
           { changelogLastFlushedState = changelogLastFlushedState orig
-          , changelogStates = changelogStates dblog
+          , changelogStates = case splitAfterOrigAnchor (changelogStates dblog) of
+              Nothing -> error "Forker chain does no longer intersect with selected chain."
+              Just (_, suffix) -> suffix
           , changelogDiffs =
               ltliftA2 (doPrune s) (changelogDiffs orig) (changelogDiffs dblog)
           }
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 b7c523d469..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
@@ -17,6 +17,7 @@
 module Ouroboros.Consensus.Storage.LedgerDB.V2 (mkInitDb) where
 
 import Control.Arrow ((>>>))
+import Control.Monad (join)
 import qualified Control.Monad as Monad (void, (>=>))
 import Control.Monad.Except
 import Control.RAWLock
@@ -77,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 =
@@ -89,10 +91,6 @@ mkInitDb args flavArgs getBlock =
         x
         pure y
     , currentTip = ledgerState . current
-    , pruneDb = \lseq -> do
-        let (rel, dbPrunedToImmDBTip) = pruneToImmTipOnly lseq
-        rel
-        pure dbPrunedToImmDBTip
     , mkLedgerDb = \lseq -> do
         varDB <- newTVarIO lseq
         prevApplied <- newTVarIO Set.empty
@@ -112,6 +110,7 @@ mkInitDb args flavArgs getBlock =
                 , ldbResolveBlock = getBlock
                 , ldbQueryBatchSize = lgrQueryBatchSize
                 , ldbOpenHandlesLock = lock
+                , ldbGetVolatileSuffix = getVolatileSuffix
                 }
         h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
         pure $ implMkLedgerDb h bss
@@ -173,7 +172,7 @@ implMkLedgerDb h bss =
       , getForkerAtTarget = newForkerAtTarget h
       , validateFork = getEnv5 h (implValidate h)
       , getPrevApplied = getEnvSTM h implGetPrevApplied
-      , garbageCollect = \s -> getEnvSTM h (flip implGarbageCollect s)
+      , garbageCollect = \s -> getEnv h (flip implGarbageCollect s)
       , tryTakeSnapshot = getEnv2 h (implTryTakeSnapshot bss)
       , tryFlush = getEnv h implTryFlush
       , closeDB = implCloseDB h
@@ -209,8 +208,9 @@ mkInternals bss h =
         eFrk <- newForkerAtTarget h reg VolatileTip
         case eFrk of
           Left{} -> error "Unreachable, Volatile tip MUST be in LedgerDB"
-          Right frk ->
+          Right frk -> do
             forkerPush frk st >> atomically (forkerCommit frk) >> forkerClose frk
+            getEnv h pruneLedgerSeq
     , reapplyThenPushNOW = \blk -> getEnv h $ \env -> withRegistry $ \reg -> do
         eFrk <- newForkerAtTarget h reg VolatileTip
         case eFrk of
@@ -225,6 +225,7 @@ mkInternals bss h =
                     blk
                     (st `withLedgerTables` tables)
             forkerPush frk st' >> atomically (forkerCommit frk) >> forkerClose frk
+            pruneLedgerSeq env
     , wipeLedgerDB = getEnv h $ destroySnapshots . ldbHasFS
     , closeLedgerDB =
         let LDBHandle tvar = h
@@ -247,6 +248,10 @@ mkInternals bss h =
     InMemoryHandleArgs -> InMemory.takeSnapshot
     LSMHandleArgs x -> absurd x
 
+  pruneLedgerSeq :: LedgerDBEnv m (ExtLedgerState blk) blk -> m ()
+  pruneLedgerSeq env =
+    join $ atomically $ stateTVar (ldbSeq env) $ pruneToImmTipOnly
+
 -- | Testing only! Truncate all snapshots in the DB.
 implIntTruncateSnapshots :: MonadThrow m => SomeHasFS m -> m ()
 implIntTruncateSnapshots sfs@(SomeHasFS fs) = do
@@ -268,13 +273,13 @@ implGetVolatileTip ::
   (MonadSTM m, GetTip l) =>
   LedgerDBEnv m l blk ->
   STM m (l EmptyMK)
-implGetVolatileTip = fmap current . readTVar . ldbSeq
+implGetVolatileTip = fmap current . getVolatileLedgerSeq
 
 implGetImmutableTip ::
-  MonadSTM m =>
+  (MonadSTM m, GetTip l) =>
   LedgerDBEnv m l blk ->
   STM m (l EmptyMK)
-implGetImmutableTip = fmap anchor . readTVar . ldbSeq
+implGetImmutableTip = fmap anchor . getVolatileLedgerSeq
 
 implGetPastLedgerState ::
   ( MonadSTM m
@@ -284,7 +289,8 @@ implGetPastLedgerState ::
   , HeaderHash l ~ HeaderHash blk
   ) =>
   LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
-implGetPastLedgerState env point = getPastLedgerAt point <$> readTVar (ldbSeq env)
+implGetPastLedgerState env point =
+  getPastLedgerAt point <$> getVolatileLedgerSeq env
 
 implGetHeaderStateHistory ::
   ( MonadSTM m
@@ -295,7 +301,7 @@ implGetHeaderStateHistory ::
   ) =>
   LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
 implGetHeaderStateHistory env = do
-  ldb <- readTVar (ldbSeq env)
+  ldb <- getVolatileLedgerSeq 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
@@ -308,7 +314,8 @@ implGetHeaderStateHistory env = do
   pure
     . HeaderStateHistory
     . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime'
-    $ getLedgerSeq ldb
+    . getLedgerSeq
+    $ ldb
 
 implValidate ::
   forall m l blk.
@@ -345,12 +352,18 @@ implValidate h ldbEnv rr tr cache rollbacks hdrs =
 implGetPrevApplied :: MonadSTM m => LedgerDBEnv m l blk -> STM m (Set (RealPoint blk))
 implGetPrevApplied env = readTVar (ldbPrevApplied env)
 
--- | Remove all points with a slot older than the given slot from the set of
--- previously applied points.
-implGarbageCollect :: MonadSTM m => LedgerDBEnv m l blk -> SlotNo -> STM m ()
-implGarbageCollect env slotNo =
-  modifyTVar (ldbPrevApplied env) $
-    Set.dropWhileAntitone ((< slotNo) . realPointSlot)
+-- | Remove 'LedgerSeq' states older than the given slot, and all points with a
+-- slot older than the given slot from the set of previously applied points.
+implGarbageCollect :: (IOLike m, GetTip l) => LedgerDBEnv m l blk -> SlotNo -> m ()
+implGarbageCollect env slotNo = do
+  atomically $
+    modifyTVar (ldbPrevApplied env) $
+      Set.dropWhileAntitone ((< slotNo) . realPointSlot)
+  -- It is safe to close the handles outside of the locked region, which reduces
+  -- contention. See the docs of 'ldbOpenHandlesLock'.
+  join $ RAWLock.withWriteAccess (ldbOpenHandlesLock env) $ \() -> do
+    close <- atomically $ stateTVar (ldbSeq env) $ prune (LedgerDbPruneBeforeSlot slotNo)
+    pure (close, ())
 
 implTryTakeSnapshot ::
   forall m l blk.
@@ -473,7 +486,8 @@ data LedgerDBEnv m l blk = LedgerDBEnv
   --    while holding a write lock. See e.g. 'closeForkerEnv'.
   --
   --  * Modify 'ldbSeq' while holding a write lock, and then close the removed
-  --    handles without any locking.
+  --    handles without any locking. See e.g. 'implGarbageCollect'.
+  , ldbGetVolatileSuffix :: !(GetVolatileSuffix m blk)
   }
   deriving Generic
 
@@ -563,21 +577,33 @@ getEnvSTM (LDBHandle varState) f =
   Acquiring consistent views
 -------------------------------------------------------------------------------}
 
--- | Get a 'StateRef' from the 'LedgerSeq' in the 'LedgerDBEnv', with the
--- 'LedgerTablesHandle' having been duplicated (such that the original can be
--- closed). The caller is responsible for closing the handle.
+-- | 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 = 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
+-- that the original can be closed). The caller is responsible for closing the
+-- handle.
 --
 -- For more flexibility, an arbitrary 'Traversable' of the 'StateRef' can be
 -- returned; for the simple use case of getting a single 'StateRef', use @t ~
 -- 'Solo'@.
 getStateRef ::
-  (IOLike m, Traversable t) =>
+  (IOLike m, Traversable t, GetTip l) =>
   LedgerDBEnv m l blk ->
   (LedgerSeq m l -> t (StateRef m l)) ->
   m (t (StateRef m l))
 getStateRef ldbEnv project =
   RAWLock.withReadAccess (ldbOpenHandlesLock ldbEnv) $ \() -> do
-    tst <- project <$> readTVarIO (ldbSeq ldbEnv)
+    tst <- project <$> atomically (getVolatileLedgerSeq ldbEnv)
     for tst $ \st -> do
       tables' <- duplicate $ tables st
       pure st{tables = tables'}
@@ -585,7 +611,7 @@ getStateRef ldbEnv project =
 -- | Like 'StateRef', but takes care of closing the handle when the given action
 -- returns or errors.
 withStateRef ::
-  (IOLike m, Traversable t) =>
+  (IOLike m, Traversable t, GetTip l) =>
   LedgerDBEnv m l blk ->
   (LedgerSeq m l -> t (StateRef m l)) ->
   (t (StateRef m l) -> m a) ->
@@ -762,7 +788,6 @@ newForker h ldbEnv rr st = do
         ForkerEnv
           { foeLedgerSeq = lseqVar
           , foeSwitchVar = ldbSeq ldbEnv
-          , foeSecurityParam = ledgerDbCfgSecParam $ ldbCfg ldbEnv
           , foeTracer = tr
           , foeResourcesToRelease = (ldbOpenHandlesLock ldbEnv, k, toRelease)
           }
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs
index 3a2e7f8940..76c076ca6f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs
@@ -26,7 +26,6 @@ import Data.Maybe (fromMaybe)
 import GHC.Generics
 import NoThunks.Class
 import Ouroboros.Consensus.Block
-import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.SupportsProtocol
 import Ouroboros.Consensus.Ledger.Tables.Utils
@@ -49,8 +48,6 @@ data ForkerEnv m l blk = ForkerEnv
   -- ^ Local version of the LedgerSeq
   , foeSwitchVar :: !(StrictTVar m (LedgerSeq m l))
   -- ^ This TVar is the same as the LedgerDB one
-  , foeSecurityParam :: !SecurityParam
-  -- ^ Config
   , foeTracer :: !(Tracer m TraceForkerEvent)
   -- ^ Config
   , foeResourcesToRelease :: !(RAWLock m (), ResourceKey m, StrictTVar m (m ()))
@@ -154,10 +151,7 @@ implForkerCommit env = do
           (olddb', toClose) <- AS.splitAfterMeasure intersectionSlot (either predicate predicate) olddb
           -- Join the prefix of the selection with the sequence in the forker
           newdb <- AS.join (const $ const True) olddb' lseq
-          -- Prune the resulting sequence to keep @k@ states
-          let (closePruned, s) = prune (LedgerDbPruneKeeping (foeSecurityParam env)) (LedgerSeq newdb)
-              closeDiscarded = do
-                closePruned
+          let closeDiscarded = do
                 -- Do /not/ close the anchor of @toClose@, as that is also the
                 -- tip of @olddb'@ which will be used in @newdb@.
                 case toClose of
@@ -166,7 +160,7 @@ implForkerCommit env = do
                 -- Finally, close the anchor of @lseq@ (which is a duplicate of
                 -- the head of @olddb'@).
                 close $ tables $ AS.anchor lseq
-          pure (closeDiscarded, s)
+          pure (closeDiscarded, LedgerSeq newdb)
       )
 
   -- We are discarding the previous value in the TVar because we had accumulated
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs
index fdf3b75207..52719cc453 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs
@@ -14,7 +14,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
 
 -- | The data structure that holds the cached ledger states.
 module Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
@@ -206,7 +205,7 @@ reapplyThenPush ::
   LedgerSeq m l ->
   m (m (), LedgerSeq m l)
 reapplyThenPush rr cfg ap db =
-  (\current' -> prune (LedgerDbPruneKeeping (ledgerDbCfgSecParam cfg)) $ extend current' db)
+  (\current' -> pruneToImmTipOnly $ extend current' db)
     <$> reapplyBlock (ledgerDbCfgComputeLedgerEvents cfg) (ledgerDbCfg cfg) ap rr db
 
 reapplyBlock ::
@@ -229,32 +228,33 @@ reapplyBlock evs cfg b _rr db = do
   pushDiffs newtbs st st'
   pure (StateRef newst newtbs)
 
--- | Prune older ledger states until at we have at most @k@ volatile states in
--- the LedgerDB, plus the one stored at the anchor.
+-- | Prune older ledger states according to the given 'LedgerDbPrune' strategy.
 --
 -- The @fst@ component of the returned value is an action closing the pruned
 -- ledger states.
 --
 -- >>> ldb  = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
 -- >>> ldb' = LedgerSeq $ AS.fromOldestFirst     l1 [l2, l3]
--- >>> snd (prune (LedgerDbPruneKeeping (SecurityParam (unsafeNonZero 2))) ldb) == ldb'
+-- >>> snd (prune (LedgerDbPruneBeforeSlot 1) ldb) == ldb'
 -- True
+--
+-- where @lX@ is a ledger state from slot @X-1@ (or 'Origin' for @l0@).
 prune ::
   (Monad m, GetTip l) =>
   LedgerDbPrune ->
   LedgerSeq m l ->
   (m (), LedgerSeq m l)
 prune howToPrune (LedgerSeq ldb) = case howToPrune of
-  LedgerDbPruneKeeping (SecurityParam (fromEnum . unNonZero -> k))
-    | nvol <= k -> (pure (), LedgerSeq ldb)
-    | otherwise -> (closeButHead before, LedgerSeq after)
-   where
-    nvol = AS.length ldb
-    (before, after) = AS.splitAt (nvol - k) ldb
   LedgerDbPruneAll ->
     (closeButHead before, LedgerSeq after)
    where
     (before, after) = (ldb, AS.Empty (AS.headAnchor ldb))
+  LedgerDbPruneBeforeSlot slot ->
+    (closeButHead before, LedgerSeq after)
+   where
+    -- The anchor of @vol'@ might still have a tip slot older than @slot@, which
+    -- is fine to ignore (we will prune it later).
+    (before, after) = AS.splitAtMeasure (NotOrigin slot) ldb
  where
   -- Above, we split @ldb@ into two sequences @before@ and @after@ such that
   -- @AS.headAnchor before == AS.anchor after@. We want to close all handles of
@@ -292,15 +292,7 @@ extend newState =
   Reset
 -------------------------------------------------------------------------------}
 
--- | When creating a new @LedgerDB@, we should load whichever snapshot we find
--- and then replay the chain up to the immutable tip. When we get there, the
--- @LedgerDB@ will have a @k@-long sequence of states, which all come from
--- immutable blocks, so we just prune all of them and only keep the last one as
--- an anchor, as it is the immutable tip. Then we can proceed with opening the
--- VolatileDB.
---
--- If we didn't do this step, the @LedgerDB@ would accept rollbacks into the
--- immutable part of the chain, which must never be possible.
+-- | Set the volatile tip as the immutable tip and prune all older states.
 --
 -- >>> ldb  = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
 -- >>> LedgerSeq ldb' = snd $ pruneToImmTipOnly ldb
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..6879576541
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Ouroboros.Consensus.Storage.PerasCertDB.API
+  ( PerasCertDB (..)
+  , AddPerasCertResult (..)
+
+    -- * 'PerasCertSnapshot'
+  , PerasCertSnapshot (..)
+  , PerasCertTicketNo
+  , zeroPerasCertTicketNo
+  ) where
+
+import Data.Word (Word64)
+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 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
+  -- 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.
+  , getCertSnapshot :: STM m (PerasCertSnapshot blk)
+  , garbageCollect :: SlotNo -> m ()
+  -- ^ Garbage-collect state older than the given slot number.
+  , closeDB :: m ()
+  }
+  deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk)
+
+data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB
+  deriving stock (Show, Eq)
+
+-- TODO: also move the weight snapshot in here?
+data PerasCertSnapshot blk = PerasCertSnapshot
+  { containsCert :: PerasRoundNo -> Bool
+  -- ^ Do we have the certificate for this round?
+  , getCertsAfter :: PerasCertTicketNo -> [(PerasCert blk, PerasCertTicketNo)]
+  }
+
+-- TODO: Once we store historical certificates on disk, this should (also) track
+-- round numbers, as we only have ticket numbers for in-memory certs.
+newtype PerasCertTicketNo = PerasCertTicketNo Word64
+  deriving stock Show
+  deriving newtype (Eq, Ord, Enum, NoThunks)
+
+zeroPerasCertTicketNo :: PerasCertTicketNo
+zeroPerasCertTicketNo = PerasCertTicketNo 0
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..3e86bf9df7
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs
@@ -0,0 +1,296 @@
+{-# 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.Tracer (Tracer, nullTracer, traceWith)
+import Data.Functor ((<&>))
+import Data.Kind (Type)
+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.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
+------------------------------------------------------------------------------}
+
+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
+  pcdbVolatileState <- newTVarIO initialPerasVolatileCertState
+  let env =
+        PerasCertDbEnv
+          { pcdbTracer
+          , pcdbVolatileState
+          }
+  h <- PerasCertDbHandle <$> newTVarIO (PerasCertDbOpen env)
+  traceWith pcdbTracer OpenedPerasCertDB
+  pure
+    PerasCertDB
+      { addCert = getEnv1 h implAddCert
+      , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot
+      , getCertSnapshot = getEnvSTM h implGetCertSnapshot
+      , garbageCollect = getEnv1 h implGarbageCollect
+      , 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))
+  , pcdbVolatileState :: !(StrictTVar m (WithFingerprint (PerasVolatileCertState blk)))
+  -- ^ The 'RoundNo's of all certificates currently in the db.
+  }
+  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 AddPerasCertResult
+implAddCert env cert = do
+  traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt
+  res <- atomically $ do
+    WithFingerprint
+      PerasVolatileCertState
+        { pvcsCerts
+        , pvcsWeightByPoint
+        , pvcsCertsByTicket
+        , pvcsLastTicketNo
+        }
+      fp <-
+      readTVar pcdbVolatileState
+    if Map.member roundNo pvcsCerts
+      then pure PerasCertAlreadyInDB
+      else do
+        let pvcsLastTicketNo' = succ pvcsLastTicketNo
+        writeTVar pcdbVolatileState $
+          WithFingerprint
+            PerasVolatileCertState
+              { pvcsCerts =
+                  Map.insert roundNo cert pvcsCerts
+              , -- Note that the same block might be boosted by multiple points.
+                pvcsWeightByPoint =
+                  addToPerasWeightSnapshot boostedPt boostPerCert pvcsWeightByPoint
+              , pvcsCertsByTicket =
+                  Map.insert pvcsLastTicketNo' cert pvcsCertsByTicket
+              , pvcsLastTicketNo = pvcsLastTicketNo'
+              }
+            (succ fp)
+        pure AddedPerasCertToDB
+  traceWith pcdbTracer $ case res of
+    AddedPerasCertToDB -> AddedPerasCert roundNo boostedPt
+    PerasCertAlreadyInDB -> IgnoredCertAlreadyInDB roundNo boostedPt
+  pure res
+ where
+  PerasCertDbEnv
+    { pcdbTracer
+    , pcdbVolatileState
+    } = env
+
+  roundNo = perasCertRound cert
+  boostedPt = perasCertBoostedBlock cert
+
+implGetWeightSnapshot ::
+  IOLike m =>
+  PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk))
+implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} =
+  fmap pvcsWeightByPoint <$> readTVar pcdbVolatileState
+
+implGetCertSnapshot ::
+  IOLike m =>
+  PerasCertDbEnv m blk -> STM m (PerasCertSnapshot blk)
+implGetCertSnapshot PerasCertDbEnv{pcdbVolatileState} =
+  readTVar pcdbVolatileState
+    <&> forgetFingerprint
+    <&> \PerasVolatileCertState
+           { pvcsCerts
+           , pvcsCertsByTicket
+           } ->
+        PerasCertSnapshot
+          { containsCert = \r -> Map.member r pvcsCerts
+          , getCertsAfter = \ticketNo ->
+              let (_, certs) = Map.split ticketNo pvcsCertsByTicket
+               in [(cert, tno) | (tno, cert) <- Map.toAscList certs]
+          }
+
+implGarbageCollect ::
+  forall m blk.
+  (IOLike m, StandardHash blk) =>
+  PerasCertDbEnv m blk -> SlotNo -> m ()
+implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
+  -- 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
+      , pvcsLastTicketNo
+      , pvcsCertsByTicket
+      } =
+      PerasVolatileCertState
+        { pvcsCerts = Map.filter keepCert pvcsCerts
+        , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint
+        , pvcsCertsByTicket = Map.filter keepCert pvcsCertsByTicket
+        , pvcsLastTicketNo = pvcsLastTicketNo
+        }
+     where
+      keepCert cert =
+        pointSlot (perasCertBoostedBlock cert) >= NotOrigin slot
+
+{-------------------------------------------------------------------------------
+  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 :: !(PerasWeightSnapshot blk)
+  -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db.
+  --
+  -- INVARIANT: In sync with 'pvcsCerts'.
+  , pvcsCertsByTicket :: !(Map PerasCertTicketNo (PerasCert blk))
+  -- ^ The certificates by 'PerasCertTicketNo'.
+  --
+  -- INVARIANT: In sync with 'pvcsCerts'.
+  , pvcsLastTicketNo :: !PerasCertTicketNo
+  -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo'
+  -- otherwise).
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass NoThunks
+
+initialPerasVolatileCertState :: WithFingerprint (PerasVolatileCertState blk)
+initialPerasVolatileCertState =
+  WithFingerprint
+    PerasVolatileCertState
+      { pvcsCerts = Map.empty
+      , pvcsWeightByPoint = emptyPerasWeightSnapshot
+      , pvcsCertsByTicket = Map.empty
+      , pvcsLastTicketNo = zeroPerasCertTicketNo
+      }
+    (Fingerprint 0)
+
+{-------------------------------------------------------------------------------
+  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/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs
index cfcb5c3050..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,26 +10,21 @@ module Ouroboros.Consensus.Util.AnchoredFragment
   ( compareAnchoredFragments
   , compareHeadBlockNo
   , cross
-  , forksAtMostKBlocks
+  , forksAtMostKWeight
   , preferAnchoredCandidate
   , 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
 
 {-------------------------------------------------------------------------------
@@ -59,76 +54,67 @@ 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.
 --
--- 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 +128,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/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/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/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/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/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs
index 88681b82fa..79d681213a 100644
--- a/ouroboros-consensus/test/consensus-test/Main.hs
+++ b/ouroboros-consensus/test/consensus-test/Main.hs
@@ -16,6 +16,9 @@ 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.MiniProtocol.ObjectDiffusion.PerasCert.Smoke (tests)
+import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (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
@@ -36,6 +39,8 @@ tests =
     , Test.Consensus.MiniProtocol.BlockFetch.Client.tests
     , Test.Consensus.MiniProtocol.ChainSync.CSJ.tests
     , Test.Consensus.MiniProtocol.ChainSync.Client.tests
+    , Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke.tests
+    , Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke.tests
     , Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests
     , testGroup
         "Mempool"
@@ -43,6 +48,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/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
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..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 =
@@ -244,6 +245,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/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs
new file mode 100644
index 0000000000..a04d6b97fa
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke (tests) where
+
+import Control.Tracer (contramap, nullTracer)
+import Data.Functor.Identity (Identity (..))
+import qualified Data.List.NonEmpty as NE
+import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer)
+import Ouroboros.Consensus.Block.SupportsPeras
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
+import Ouroboros.Consensus.Storage.PerasCertDB.API
+  ( AddPerasCertResult (..)
+  , PerasCertDB
+  , PerasCertTicketNo
+  )
+import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB
+import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB
+import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Network.Block (Point (..), SlotNo (SlotNo), StandardHash)
+import Ouroboros.Network.Point (Block (Block), WithOrigin (..))
+import Ouroboros.Network.Protocol.ObjectDiffusion.Codec
+import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound
+  ( objectDiffusionInboundServerPeerPipelined
+  )
+import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundClientPeer)
+import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
+  ( ListWithUniqueIds (..)
+  , ProtocolConstants
+  , WithId
+  , getId
+  , prop_smoke_object_diffusion
+  )
+import Test.QuickCheck
+import Test.Tasty
+import Test.Tasty.QuickCheck (testProperty)
+import Test.Util.TestBlock
+
+tests :: TestTree
+tests =
+  testGroup
+    "ObjectDiffusion.PerasCert.Smoke"
+    [ testProperty "PerasCertDiffusion smoke test" prop_smoke
+    ]
+
+instance Arbitrary (Point TestBlock) where
+  arbitrary =
+    -- Sometimes pick the genesis point
+    frequency
+      [ (1, pure $ Point Origin)
+      ,
+        ( 4
+        , do
+            slotNo <- SlotNo <$> arbitrary
+            hash <- TestHash . NE.fromList . getNonEmpty <$> arbitrary
+            pure $ Point (At (Block slotNo hash))
+        )
+      ]
+
+instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where
+  arbitrary = do
+    pcCertRound <- PerasRoundNo <$> arbitrary
+    pcCertBoostedBlock <- arbitrary
+    pure $ PerasCert{pcCertRound, pcCertBoostedBlock}
+
+instance WithId (PerasCert blk) PerasRoundNo where
+  getId = pcCertRound
+
+newCertDB :: (IOLike m, StandardHash blk) => [PerasCert blk] -> m (PerasCertDB m blk)
+newCertDB certs = do
+  db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer)
+  mapM_
+    ( \cert -> do
+        result <- PerasCertDB.addCert db cert
+        case result of
+          AddedPerasCertToDB -> pure ()
+          PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB")
+    )
+    certs
+  pure db
+
+prop_smoke :: ProtocolConstants -> ListWithUniqueIds (PerasCert TestBlock) PerasRoundNo -> Property
+prop_smoke protocolConstants (ListWithUniqueIds certs) =
+  prop_smoke_object_diffusion protocolConstants certs runOutboundPeer runInboundPeer mkPoolInterfaces
+ where
+  runOutboundPeer outbound outboundChannel tracer =
+    runPeer
+      ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer)
+      codecObjectDiffusionId
+      outboundChannel
+      (objectDiffusionOutboundClientPeer outbound)
+      >> pure ()
+  runInboundPeer inbound inboundChannel tracer =
+    runPipelinedPeer
+      ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer)
+      codecObjectDiffusionId
+      inboundChannel
+      (objectDiffusionInboundServerPeerPipelined inbound)
+      >> pure ()
+  mkPoolInterfaces ::
+    forall m.
+    IOLike m =>
+    m
+      ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m
+      , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m
+      , m [PerasCert TestBlock]
+      )
+  mkPoolInterfaces = do
+    outboundPool <- newCertDB certs
+    inboundPool <- newCertDB []
+
+    let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool
+        inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool
+        getAllInboundPoolContent = do
+          snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool
+          let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo)
+          pure $ fst <$> rawContent
+
+    return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent)
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs
new file mode 100644
index 0000000000..d681c12016
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs
@@ -0,0 +1,333 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Smoke tests for the object diffusion protocol. This uses a trivial object
+-- pool and checks that a few objects can indeed be transferred from the
+-- outbound to the inbound peer.
+module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
+  ( tests
+  , WithId (..)
+  , ListWithUniqueIds (..)
+  , ProtocolConstants
+  , prop_smoke_object_diffusion
+  ) where
+
+import Control.Monad.IOSim (runSimStrictShutdown)
+import Control.ResourceRegistry (forkLinkedThread, waitAnyThread, withRegistry)
+import Control.Tracer (Tracer, nullTracer, traceWith)
+import Data.Containers.ListUtils (nubOrdOn)
+import Data.Functor.Contravariant (contramap)
+import Network.TypedProtocol.Channel (Channel, createConnectedChannels)
+import Network.TypedProtocol.Codec (AnyMessage)
+import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer)
+import NoThunks.Class (NoThunks)
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
+  ( objectDiffusionInbound
+  )
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
+  ( ObjectPoolReader (..)
+  , ObjectPoolWriter (..)
+  )
+import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound)
+import Ouroboros.Consensus.Util.IOLike
+  ( IOLike
+  , MonadDelay (..)
+  , MonadSTM (..)
+  , StrictTVar
+  , modifyTVar
+  , readTVar
+  , uncheckedNewTVarM
+  , writeTVar
+  )
+import Ouroboros.Network.ControlMessage (ControlMessage (..))
+import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..))
+import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId)
+import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound
+  ( ObjectDiffusionInboundPipelined
+  , objectDiffusionInboundClientPeerPipelined
+  , objectDiffusionInboundServerPeerPipelined
+  )
+import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound
+  ( ObjectDiffusionOutbound
+  , objectDiffusionOutboundClientPeer
+  , objectDiffusionOutboundServerPeer
+  )
+import Ouroboros.Network.Protocol.ObjectDiffusion.Type
+  ( NumObjectIdsReq (..)
+  , NumObjectsOutstanding (..)
+  , NumObjectsReq (..)
+  , ObjectDiffusion
+  )
+import Test.QuickCheck
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.Util.Orphans.Arbitrary ()
+import Test.Util.Orphans.IOLike ()
+
+tests :: TestTree
+tests =
+  testGroup
+    "ObjectDiffusion.Smoke"
+    [ testProperty
+        "ObjectDiffusion smoke test with mock objects (client inbound, server outbound)"
+        prop_smoke_init_inbound
+    , testProperty
+        "ObjectDiffusion smoke test with mock objects (client outbound, server inbound)"
+        prop_smoke_init_outbound
+    ]
+
+{-------------------------------------------------------------------------------
+  Provides a way to generate lists composed of objects with no duplicate ids,
+  with an Arbitrary instance
+-------------------------------------------------------------------------------}
+
+class WithId a idTy | a -> idTy where
+  getId :: a -> idTy
+
+newtype ListWithUniqueIds a idTy = ListWithUniqueIds [a]
+  deriving (Eq, Show, Ord)
+
+instance (Ord idTy, WithId a idTy, Arbitrary a) => Arbitrary (ListWithUniqueIds a idTy) where
+  arbitrary = ListWithUniqueIds . nubOrdOn getId <$> arbitrary
+
+instance WithId SmokeObject SmokeObjectId where getId = getSmokeObjectId
+
+{-------------------------------------------------------------------------------
+  Mock objectPools
+-------------------------------------------------------------------------------}
+
+newtype SmokeObjectId = SmokeObjectId Int
+  deriving (Eq, Ord, Show, NoThunks, Arbitrary)
+
+newtype SmokeObject = SmokeObject {getSmokeObjectId :: SmokeObjectId}
+  deriving (Eq, Ord, Show, NoThunks, Arbitrary)
+
+newtype SmokeObjectPool m = SmokeObjectPool (StrictTVar m [SmokeObject])
+
+newObjectPool :: MonadSTM m => [SmokeObject] -> m (SmokeObjectPool m)
+newObjectPool initialPoolContent = SmokeObjectPool <$> uncheckedNewTVarM initialPoolContent
+
+makeObjectPoolReader ::
+  MonadSTM m => SmokeObjectPool m -> ObjectPoolReader SmokeObjectId SmokeObject Int m
+makeObjectPoolReader (SmokeObjectPool poolContentTvar) =
+  ObjectPoolReader
+    { oprObjectId = getSmokeObjectId
+    , oprObjectsAfter = \minTicketNo limit -> do
+        poolContent <- readTVar poolContentTvar
+        pure $
+          take (fromIntegral limit) $
+            drop (minTicketNo + 1) $
+              ( (\(ticketNo, smokeObject) -> (ticketNo, getSmokeObjectId smokeObject, pure smokeObject))
+                  <$> zip [(0 :: Int) ..] poolContent
+              )
+    , oprZeroTicketNo = -1 -- objectPoolObjectIdsAfter uses strict comparison, and first ticketNo is 0.
+    }
+
+makeObjectPoolWriter ::
+  MonadSTM m => SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m
+makeObjectPoolWriter (SmokeObjectPool poolContentTvar) =
+  ObjectPoolWriter
+    { opwObjectId = getSmokeObjectId
+    , opwAddObjects = \objects -> do
+        atomically $ modifyTVar poolContentTvar (++ objects)
+        return ()
+    , opwHasObject = do
+        poolContent <- readTVar poolContentTvar
+        pure $ \objectId -> any (\obj -> getSmokeObjectId obj == objectId) poolContent
+    }
+
+mkMockPoolInterfaces ::
+  MonadSTM m =>
+  [SmokeObject] ->
+  m
+    ( ObjectPoolReader SmokeObjectId SmokeObject Int m
+    , ObjectPoolWriter SmokeObjectId SmokeObject m
+    , m [SmokeObject]
+    )
+mkMockPoolInterfaces objects = do
+  outboundPool <- newObjectPool objects
+  inboundPool@(SmokeObjectPool tvar) <- newObjectPool []
+
+  let outboundPoolReader = makeObjectPoolReader outboundPool
+      inboundPoolWriter = makeObjectPoolWriter inboundPool
+
+  return (outboundPoolReader, inboundPoolWriter, atomically $ readTVar tvar)
+
+{-------------------------------------------------------------------------------
+  Main properties
+-------------------------------------------------------------------------------}
+
+-- Protocol constants
+
+newtype ProtocolConstants
+  = ProtocolConstants (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq)
+  deriving Show
+
+instance Arbitrary ProtocolConstants where
+  arbitrary = do
+    maxFifoSize <- choose (5, 20)
+    maxIdsToReq <- choose (3, maxFifoSize)
+    maxObjectsToReq <- choose (2, maxIdsToReq)
+    pure $
+      ProtocolConstants
+        ( NumObjectsOutstanding maxFifoSize
+        , NumObjectIdsReq maxIdsToReq
+        , NumObjectsReq maxObjectsToReq
+        )
+
+nodeToNodeVersion :: NodeToNodeVersion
+nodeToNodeVersion = NodeToNodeV_14
+
+prop_smoke_init_inbound :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property
+prop_smoke_init_inbound protocolConstants (ListWithUniqueIds objects) =
+  prop_smoke_object_diffusion
+    protocolConstants
+    objects
+    runOutboundPeer
+    runInboundPeer
+    (mkMockPoolInterfaces objects)
+ where
+  runOutboundPeer outbound outboundChannel tracer =
+    runPeer
+      ((\x -> "Outbound (Server): " ++ show x) `contramap` tracer)
+      codecObjectDiffusionId
+      outboundChannel
+      (objectDiffusionOutboundServerPeer outbound)
+      >> pure ()
+
+  runInboundPeer inbound inboundChannel tracer =
+    runPipelinedPeer
+      ((\x -> "Inbound (Client): " ++ show x) `contramap` tracer)
+      codecObjectDiffusionId
+      inboundChannel
+      (objectDiffusionInboundClientPeerPipelined inbound)
+      >> pure ()
+
+prop_smoke_init_outbound ::
+  ProtocolConstants -> ListWithUniqueIds SmokeObject SmokeObjectId -> Property
+prop_smoke_init_outbound protocolConstants (ListWithUniqueIds objects) =
+  prop_smoke_object_diffusion
+    protocolConstants
+    objects
+    runOutboundPeer
+    runInboundPeer
+    (mkMockPoolInterfaces objects)
+ where
+  runOutboundPeer outbound outboundChannel tracer =
+    runPeer
+      ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer)
+      codecObjectDiffusionId
+      outboundChannel
+      (objectDiffusionOutboundClientPeer outbound)
+      >> pure ()
+
+  runInboundPeer inbound inboundChannel tracer =
+    runPipelinedPeer
+      ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer)
+      codecObjectDiffusionId
+      inboundChannel
+      (objectDiffusionInboundServerPeerPipelined inbound)
+      >> pure ()
+
+--- The core logic of the smoke test is shared between the generic smoke tests for ObjectDiffusion, and the ones specialised to PerasCert/PerasVote diffusion
+prop_smoke_object_diffusion ::
+  ( Eq object
+  , Show object
+  , Ord objectId
+  , NoThunks objectId
+  , Show objectId
+  , NoThunks object
+  , Ord ticketNo
+  ) =>
+  ProtocolConstants ->
+  [object] ->
+  ( forall m.
+    IOLike m =>
+    ObjectDiffusionOutbound objectId object m () ->
+    Channel m (AnyMessage (ObjectDiffusion initAgency objectId object)) ->
+    (Tracer m String) ->
+    m ()
+  ) ->
+  ( forall m.
+    IOLike m =>
+    ObjectDiffusionInboundPipelined objectId object m () ->
+    (Channel m (AnyMessage (ObjectDiffusion initAgency objectId object))) ->
+    (Tracer m String) ->
+    m ()
+  ) ->
+  ( forall m.
+    IOLike m =>
+    m
+      ( ObjectPoolReader objectId object ticketNo m
+      , ObjectPoolWriter objectId object m
+      , m [object]
+      )
+  ) ->
+  Property
+prop_smoke_object_diffusion
+  (ProtocolConstants (maxFifoSize, maxIdsToReq, maxObjectsToReq))
+  objects
+  runOutboundPeer
+  runInboundPeer
+  mkPoolInterfaces =
+    let
+      simulationResult = runSimStrictShutdown $ do
+        let tracer = nullTracer
+
+        traceWith tracer "========== [ Starting ObjectDiffusion smoke test ] =========="
+        traceWith tracer (show objects)
+
+        (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) <- mkPoolInterfaces
+        controlMessage <- uncheckedNewTVarM Continue
+
+        let
+          inbound =
+            objectDiffusionInbound
+              tracer
+              ( maxFifoSize
+              , maxIdsToReq
+              , maxObjectsToReq
+              )
+              inboundPoolWriter
+              nodeToNodeVersion
+
+          outbound =
+            objectDiffusionOutbound
+              tracer
+              maxFifoSize
+              outboundPoolReader
+              nodeToNodeVersion
+              (readTVar controlMessage)
+
+        withRegistry $ \reg -> do
+          (outboundChannel, inboundChannel) <- createConnectedChannels
+          outboundThread <-
+            forkLinkedThread reg "ObjectDiffusion Outbound peer thread" $
+              runOutboundPeer outbound outboundChannel tracer
+          inboundThread <-
+            forkLinkedThread reg "ObjectDiffusion Inbound peer thread" $
+              runInboundPeer inbound inboundChannel tracer
+          controlMessageThread <- forkLinkedThread reg "ObjectDiffusion Control thread" $ do
+            threadDelay 1000 -- give a head start to the other threads
+            atomically $ writeTVar controlMessage Terminate
+            threadDelay 1000 -- wait for the other threads to finish
+          waitAnyThread [outboundThread, inboundThread, controlMessageThread]
+
+        traceWith tracer "========== [ ObjectDiffusion smoke test finished ] =========="
+        poolContent <- getAllInboundPoolContent
+
+        traceWith tracer "inboundPoolContent:"
+        traceWith tracer (show poolContent)
+        traceWith tracer "========== ======================================= =========="
+        pure poolContent
+     in
+      case simulationResult of
+        Right inboundPoolContent -> inboundPoolContent === objects
+        Left msg -> counterexample (show msg) $ property False
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
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
index 419d8872a7..1153457c70 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs
@@ -5,6 +5,7 @@ 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.PerasCertDB as PerasCertDB
 import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB
 import Test.Tasty (TestTree, testGroup)
 
@@ -20,4 +21,5 @@ tests =
     , VolatileDB.tests
     , LedgerDB.tests
     , ChainDB.tests
+    , PerasCertDB.tests
     ]
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 5b352d2bc3..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
@@ -33,7 +34,6 @@ module Test.Ouroboros.Storage.ChainDB.Model
   , getBlock
   , getBlockByPoint
   , getBlockComponentByPoint
-  , getDbChangelog
   , getIsValid
   , getLoEFragment
   , getMaxSlotNo
@@ -45,7 +45,7 @@ module Test.Ouroboros.Storage.ChainDB.Model
   , invalid
   , isOpen
   , isValid
-  , lastK
+  , maxPerasRoundNo
   , tipBlock
   , tipPoint
   , volatileChain
@@ -84,17 +84,14 @@ module Test.Ouroboros.Storage.ChainDB.Model
   , wipeVolatileDB
   ) where
 
-import Cardano.Ledger.BaseTypes
-  ( knownNonZeroBounded
-  , nonZeroOr
-  , unNonZero
-  )
+import Cardano.Ledger.BaseTypes (unNonZero)
 import Codec.Serialise (Serialise, serialise)
 import Control.Monad (unless)
 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)
@@ -105,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
@@ -113,6 +109,8 @@ 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
 import Ouroboros.Consensus.Storage.ChainDB.API
@@ -127,13 +125,8 @@ 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.Storage.LedgerDB.API
-  ( LedgerDbCfgF (..)
-  , LedgerDbPrune (..)
-  )
-import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbChangelog
 import Ouroboros.Consensus.Util (repeatedly)
 import qualified Ouroboros.Consensus.Util.AnchoredFragment as Fragment
 import Ouroboros.Consensus.Util.IOLike (MonadSTM)
@@ -155,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
@@ -241,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 ::
@@ -375,38 +375,20 @@ isValid ::
   Maybe Bool
 isValid = flip getIsValid
 
-getDbChangelog ::
-  (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (LedgerState blk)) =>
-  TopLevelConfig blk ->
-  Model blk ->
-  DbChangelog.DbChangelog' blk
-getDbChangelog cfg m@Model{..} =
-  DbChangelog.prune tip
-    . DbChangelog.reapplyThenPushMany' ledgerDbCfg blks
-    $ DbChangelog.empty initLedger
- where
-  blks = Chain.toOldestFirst $ currentChain m
-
-  k = configSecurityParam cfg
-
-  ledgerDbCfg =
-    LedgerDbCfg
-      { ledgerDbCfgSecParam = k
-      , ledgerDbCfg = ExtLedgerCfg cfg
-      , ledgerDbCfgComputeLedgerEvents = OmitLedgerEvents
-      }
-
-  tip =
-    case maxActualRollback k m of
-      0 -> LedgerDbPruneAll
-      n ->
-        -- Since we know that @`n`@ is not zero, it is impossible for `nonZeroOr`
-        -- to return a `Nothing` and the final result to have default value of @`1`@.
-        LedgerDbPruneKeeping $ SecurityParam $ nonZeroOr n $ knownNonZeroBounded @1
-
 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
 -------------------------------------------------------------------------------}
@@ -420,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
@@ -454,11 +437,28 @@ 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)
 
+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)
@@ -471,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
@@ -570,7 +571,10 @@ chainSelection cfg m =
       . selectChain
         (Proxy @(BlockProtocol blk))
         (projectChainOrderConfig (configBlock cfg))
-        (selectView (configBlock cfg) . getHeader)
+        ( weightedSelectView (configBlock cfg) (perasWeights m)
+            . Chain.toAnchoredFragment
+            . fmap getHeader
+        )
         (currentChain m)
       $ consideredCandidates
 
@@ -902,7 +906,7 @@ validChains cfg m bs =
   sortChains =
     sortBy $
       flip
-        ( Fragment.compareAnchoredFragments (configBlock cfg)
+        ( Fragment.compareAnchoredFragments (configBlock cfg) (perasWeights m)
             `on` (Chain.toAnchoredFragment . fmap getHeader)
         )
 
@@ -938,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
@@ -1078,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?
@@ -1129,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
@@ -1147,7 +1164,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)
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..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,11 +22,11 @@
 -- 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
 import Ouroboros.Consensus.Ledger.Tables
+import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Storage.ChainDB.API
   ( LoE (..)
   , StreamFrom (..)
@@ -96,16 +96,20 @@ prop_alwaysPickPreferredChain bt p =
 
   curFragment = Chain.toAnchoredFragment (getHeader <$> current)
 
-  SecurityParam k = configSecurityParam singleNodeTestConfig
+  k = configSecurityParam singleNodeTestConfig
 
   bcfg = configBlock singleNodeTestConfig
 
   preferCandidate' candidate =
-    AF.preferAnchoredCandidate bcfg curFragment candFragment
-      && AF.forksAtMostKBlocks (unNonZero k) curFragment candFragment
+    AF.preferAnchoredCandidate bcfg weights curFragment candFragment
+      && AF.forksAtMostKWeight weights (maxRollbackWeight 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 =
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..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
@@ -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
@@ -178,6 +179,7 @@ import Test.Util.WithEq
 -- | Commands
 data Cmd blk it flr
   = AddBlock blk
+  | AddPerasCert (PerasCert blk)
   | GetCurrentChain
   | GetTipBlock
   | GetTipHeader
@@ -402,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
@@ -639,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)
@@ -910,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)
@@ -1035,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
@@ -1233,16 +1256,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 =>
@@ -1272,7 +1312,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
@@ -1330,14 +1370,19 @@ 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)
+deriving anyclass instance SOP.Generic (TraceAddPerasCertEvent blk)
+deriving anyclass instance SOP.HasDatatypeInfo (TraceAddPerasCertEvent blk)
 
 data Tag
   = TagGetIsValidJust
   | TagGetIsValidNothing
   | TagChainSelReprocessChangedSelection
   | TagChainSelReprocessKeptSelection
+  | TagSwitchedToShorterChain
   deriving (Show, Eq)
 
 -- | Predicate on events
@@ -1364,6 +1409,7 @@ tag =
     , tagGetIsValidNothing
     , tagChainSelReprocess TagChainSelReprocessChangedSelection (/=)
     , tagChainSelReprocess TagChainSelReprocessKeptSelection (==)
+    , tagSwitchedToShorterChain
     ]
  where
   tagGetIsValidJust :: EventPred m
@@ -1388,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 ::
@@ -1756,8 +1817,10 @@ 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
+  TraceAddPerasCertEvent ev -> "AddPerasCert." <> constrName ev
 
 mkArgs ::
   IOLike m =>
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 308141d5bb..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
@@ -302,7 +302,13 @@ instance StateModel Model where
                   min
                     (fromIntegral . AS.length $ chain)
                     (BT.unNonZero $ maxRollbacks secParam)
-            numRollback <- QC.choose (0, maxRollback)
+            numRollback <-
+              frequency
+                [ (10, QC.choose (0, maxRollback))
+                , -- Sometimes generate invalid 'ValidateAndCommit's for
+                  -- negative testing.
+                  (1, QC.choose (maxRollback + 1, maxRollback + 5))
+                ]
             numNewBlocks <- QC.choose (numRollback, numRollback + 2)
             let
               chain' = case modelRollback numRollback model of
@@ -371,6 +377,9 @@ instance StateModel Model where
   precondition _ Init{} = False
   precondition _ _ = True
 
+  validFailingAction Model{} ValidateAndCommit{} = True
+  validFailingAction _ _ = False
+
 {-------------------------------------------------------------------------------
   Mocked ChainDB
 -------------------------------------------------------------------------------}
@@ -495,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 =
@@ -502,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)
@@ -527,22 +538,29 @@ data Environment
       (IO NumOpenHandles)
       (IO ())
 
+data LedgerDBError = ErrorValidateExceededRollback
+
 instance RunModel Model (StateT Environment IO) where
+  type Error Model (StateT Environment IO) = LedgerDBError
+
   perform _ (Init secParam) _ = do
     Environment _ _ chainDb mkArgs fs _ cleanup <- get
     (ldb, testInternals, getNumOpenHandles) <- lift $ do
       let args = mkArgs secParam
       openLedgerDB (argFlavorArgs args) chainDb (argLedgerDbCfg args) fs
     put (Environment ldb testInternals chainDb mkArgs fs getNumOpenHandles cleanup)
+    pure $ pure ()
   perform _ WipeLedgerDB _ = do
     Environment _ testInternals _ _ _ _ _ <- get
     lift $ wipeLedgerDB testInternals
+    pure $ pure ()
   perform _ GetState _ = do
     Environment ldb _ _ _ _ _ _ <- get
-    lift $ atomically $ (,) <$> getImmutableTip ldb <*> getVolatileTip ldb
+    lift $ fmap pure $ atomically $ (,) <$> getImmutableTip ldb <*> getVolatileTip ldb
   perform _ ForceTakeSnapshot _ = do
     Environment _ testInternals _ _ _ _ _ <- get
     lift $ takeSnapshotNOW testInternals TakeAtImmutableTip Nothing
+    pure $ pure ()
   perform _ (ValidateAndCommit n blks) _ = do
     Environment ldb _ chainDb _ _ _ _ <- get
     lift $ do
@@ -558,7 +576,8 @@ instance RunModel Model (StateT Environment IO) where
                 (reverse (map blockRealPoint blks) ++) . drop (fromIntegral n)
             atomically (forkerCommit forker)
             forkerClose forker
-          ValidateExceededRollBack{} -> error "Unexpected Rollback"
+            pure $ pure ()
+          ValidateExceededRollBack{} -> pure $ Left ErrorValidateExceededRollback
           ValidateLedgerError (AnnLedgerError forker _ _) -> forkerClose forker >> error "Unexpected ledger error"
   perform state@(Model _ secParam) (DropAndRestore n) lk = do
     Environment _ testInternals chainDb _ _ _ _ <- get
@@ -569,6 +588,7 @@ instance RunModel Model (StateT Environment IO) where
   perform _ TruncateSnapshots _ = do
     Environment _ testInternals _ _ _ _ _ <- get
     lift $ truncateSnapshots testInternals
+    pure $ pure ()
   perform UnInit _ _ = error "Uninitialized model created a command different than Init"
 
   monitoring _ (ValidateAndCommit n _) _ _ = tabulate "Rollback depths" [show n]
@@ -602,6 +622,11 @@ instance RunModel Model (StateT Environment IO) where
           pure $ volSt == vol && immSt == imm
   postcondition _ _ _ _ = pure True
 
+  postconditionOnFailure _ ValidateAndCommit{} _ res = case res of
+    Right () -> False <$ counterexamplePost "Unexpected success on invalid ValidateAndCommit"
+    Left ErrorValidateExceededRollback -> pure True
+  postconditionOnFailure _ _ _ _ = pure True
+
 {-------------------------------------------------------------------------------
   Additional checks
 -------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog.hs
index c423167baa..00d5cee279 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/DbChangelog.hs
@@ -31,7 +31,7 @@
 -- * etc.
 module Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog (tests) where
 
-import Cardano.Ledger.BaseTypes (NonZero (..), unsafeNonZero)
+import Cardano.Ledger.BaseTypes (NonZero (..))
 import Cardano.Slotting.Slot (WithOrigin (..))
 import Control.Monad hiding (ap)
 import Control.Monad.Trans.Class (lift)
@@ -85,15 +85,12 @@ tests =
     , testGroup
         "Push"
         [ testProperty "expectedLedger" prop_pushExpectedLedger
-        , testProperty "pastLedger" prop_pastLedger
         ]
     , testGroup
         "Rollback"
         [ testProperty "maxRollbackGenesisZero" prop_maxRollbackGenesisZero
-        , testProperty "ledgerDbMaxRollback" prop_snapshotsMaxRollback
         , testProperty "switchSameChain" prop_switchSameChain
         , testProperty "switchExpectedLedger" prop_switchExpectedLedger
-        , testProperty "pastAfterSwitch" prop_pastAfterSwitch
         ]
     , testProperty "flushing" $
         withMaxSuccess samples $
@@ -117,8 +114,8 @@ tests =
             ]
     , testProperty "extending adds head to volatile states" $
         withMaxSuccess samples prop_extendingAdvancesTipOfVolatileStates
-    , testProperty "pruning leaves at most maxRollback volatile states" $
-        withMaxSuccess samples prop_pruningLeavesAtMostMaxRollbacksVolatileStates
+    , testProperty "pruning before a slot works as expected" $
+        withMaxSuccess samples prop_pruningBeforeSlotCorrectness
     ]
 
 {-------------------------------------------------------------------------------
@@ -151,28 +148,6 @@ prop_pushExpectedLedger setup@ChainSetup{..} =
   cfg :: LedgerConfig TestBlock.TestBlock
   cfg = ledgerDbCfg (csBlockConfig setup)
 
-prop_pastLedger :: ChainSetup -> Property
-prop_pastLedger setup@ChainSetup{..} =
-  classify (chainSetupSaturated setup) "saturated" $
-    classify withinReach "within reach" $
-      getPastLedgerAt tip csPushed
-        === if withinReach
-          then Just (current afterPrefix)
-          else Nothing
- where
-  prefix :: [TestBlock.TestBlock]
-  prefix = take (fromIntegral csPrefixLen) csChain
-
-  tip :: Point TestBlock.TestBlock
-  tip = maybe GenesisPoint blockPoint (lastMaybe prefix)
-
-  afterPrefix :: DbChangelog (LedgerState TestBlock.TestBlock)
-  afterPrefix = reapplyThenPushMany' (csBlockConfig setup) prefix csGenSnaps
-
-  -- See 'prop_snapshotsMaxRollback'
-  withinReach :: Bool
-  withinReach = (csNumBlocks - csPrefixLen) <= maxRollback csPushed
-
 {-------------------------------------------------------------------------------
   Rollback
 -------------------------------------------------------------------------------}
@@ -182,18 +157,6 @@ prop_maxRollbackGenesisZero =
   maxRollback (empty (convertMapKind TestBlock.testInitLedger))
     === 0
 
-prop_snapshotsMaxRollback :: ChainSetup -> Property
-prop_snapshotsMaxRollback setup@ChainSetup{..} =
-  classify (chainSetupSaturated setup) "saturated" $
-    conjoin
-      [ if chainSetupSaturated setup
-          then (maxRollback csPushed) `ge` unNonZero k
-          else (maxRollback csPushed) `ge` (min (unNonZero k) csNumBlocks)
-      , (maxRollback csPushed) `le` unNonZero k
-      ]
- where
-  SecurityParam k = csSecParam
-
 prop_switchSameChain :: SwitchSetup -> Property
 prop_switchSameChain setup@SwitchSetup{..} =
   classify (switchSetupSaturated setup) "saturated" $
@@ -219,29 +182,6 @@ prop_switchExpectedLedger setup@SwitchSetup{..} =
   cfg :: LedgerConfig TestBlock.TestBlock
   cfg = ledgerDbCfg (csBlockConfig ssChainSetup)
 
--- | Check 'prop_pastLedger' still holds after switching to a fork
-prop_pastAfterSwitch :: SwitchSetup -> Property
-prop_pastAfterSwitch setup@SwitchSetup{..} =
-  classify (switchSetupSaturated setup) "saturated" $
-    classify withinReach "within reach" $
-      getPastLedgerAt tip ssSwitched
-        === if withinReach
-          then Just (current afterPrefix)
-          else Nothing
- where
-  prefix :: [TestBlock.TestBlock]
-  prefix = take (fromIntegral ssPrefixLen) ssChain
-
-  tip :: Point TestBlock.TestBlock
-  tip = maybe GenesisPoint blockPoint (lastMaybe prefix)
-
-  afterPrefix :: DbChangelog (LedgerState TestBlock.TestBlock)
-  afterPrefix = reapplyThenPushMany' (csBlockConfig ssChainSetup) prefix (csGenSnaps ssChainSetup)
-
-  -- See 'prop_snapshotsMaxRollback'
-  withinReach :: Bool
-  withinReach = (ssNumBlocks - ssPrefixLen) <= maxRollback ssSwitched
-
 {-------------------------------------------------------------------------------
   Test setup
 -------------------------------------------------------------------------------}
@@ -442,7 +382,7 @@ data DbChangelogTestSetup = DbChangelogTestSetup
   , dbChangelogStartsAt :: WithOrigin SlotNo
   }
 
-data Operation l = Extend (l DiffMK) | Prune LedgerDbPrune
+data Operation l = Extend (l DiffMK) | Prune
 deriving instance Show (l DiffMK) => Show (Operation l)
 
 data DbChangelogTestSetupWithRollbacks = DbChangelogTestSetupWithRollbacks
@@ -507,7 +447,7 @@ applyOperations ::
 applyOperations ops dblog = foldr' apply' dblog ops
  where
   apply' (Extend newState) dblog' = DbChangelog.extend newState dblog'
-  apply' (Prune sp) dblog' = DbChangelog.prune sp dblog'
+  apply' Prune dblog' = DbChangelog.pruneToImmTipOnly dblog'
 
 {-------------------------------------------------------------------------------
   Properties
@@ -549,14 +489,40 @@ prop_rollbackAfterExtendIsNoop setup (Positive n) =
  where
   dblog = resultingDbChangelog setup
 
--- | The number of volatile states left after pruning is at most the maximum number of rollbacks.
-prop_pruningLeavesAtMostMaxRollbacksVolatileStates ::
-  DbChangelogTestSetup -> SecurityParam -> Property
-prop_pruningLeavesAtMostMaxRollbacksVolatileStates setup sp@(SecurityParam k) =
-  property $ AS.length (DbChangelog.changelogStates dblog') <= fromIntegral (unNonZero k)
+-- | When pruning after a slot, all (non-anchor) states are not older than this
+-- slot, and the anchor /is/ older (unless nothing was pruned).
+prop_pruningBeforeSlotCorrectness ::
+  DbChangelogTestSetup -> Property
+prop_pruningBeforeSlotCorrectness setup =
+  counterexample ("dblog: " <> show dblog) $ forAll genPruneSlot $ \pruneSlot ->
+    let dblog' = DbChangelog.prune (LedgerDbPruneBeforeSlot pruneSlot) dblog
+     in counterexample ("pruned dblog: " <> show dblog') $
+          conjoin
+            [ counterexample "State not pruned unexpectedly" $
+                conjoin
+                  [ (NotOrigin pruneSlot `le` getTipSlot st)
+                  | (_, st) <-
+                      DbChangelog.snapshots dblog'
+                  ]
+            , counterexample "Anchor too old" $
+                let nothingPruned = DbChangelog.maxRollback dblog == DbChangelog.maxRollback dblog'
+                 in if nothingPruned
+                      then property ()
+                      else
+                        getTipSlot (DbChangelog.anchor dblog') `lt` NotOrigin pruneSlot
+            ]
  where
   dblog = resultingDbChangelog setup
-  dblog' = DbChangelog.prune (LedgerDbPruneKeeping sp) dblog
+
+  genPruneSlot = chooseEnum (lb, ub)
+   where
+    jitter = 5
+    lb
+      | anchorSlot >= jitter = anchorSlot - jitter
+      | otherwise = 0
+     where
+      anchorSlot = succWithOrigin $ getTipSlot $ DbChangelog.anchor dblog
+    ub = succWithOrigin (pointSlot (DbChangelog.tip dblog)) + jitter
 
 -- | The rollbackToAnchor function rolls back all volatile states.
 prop_rollbackToAnchorIsRollingBackVolatileStates :: DbChangelogTestSetup -> Property
@@ -628,19 +594,9 @@ genOperations slotNo nOps = gosOps <$> execStateT (replicateM_ nOps genOperation
 
   genOperation :: StateT GenOperationsState Gen ()
   genOperation = do
-    op <- frequency' [(1, genPrune), (10, genExtend)]
+    op <- frequency' [(1, pure Prune), (20, genExtend)]
     modify' $ \st -> st{gosOps = op : gosOps st}
 
-  genPrune :: StateT GenOperationsState Gen (Operation TestLedger)
-  genPrune =
-    Prune
-      <$> lift
-        ( oneof
-            [ pure LedgerDbPruneAll
-            , LedgerDbPruneKeeping . SecurityParam . unsafeNonZero <$> chooseEnum (1, 10)
-            ]
-        )
-
   genExtend :: StateT GenOperationsState Gen (Operation TestLedger)
   genExtend = do
     nextSlotNo <- advanceSlotNo =<< lift (chooseEnum (1, 5))
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..a1cda0e044
--- /dev/null
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Test.Ouroboros.Storage.PerasCertDB.Model
+  ( Model (..)
+  , initModel
+  , openDB
+  , closeDB
+  , addCert
+  , getWeightSnapshot
+  , garbageCollect
+  ) where
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+import GHC.Generics (Generic)
+import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Peras.Weight
+  ( PerasWeightSnapshot
+  , mkPerasWeightSnapshot
+  )
+
+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} =
+  mkPerasWeightSnapshot
+    [(perasCertBoostedBlock cert, boostPerCert) | cert <- Set.toList 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
new file mode 100644
index 0000000000..917c96eef6
--- /dev/null
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+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 (AddPerasCertResult (..), 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
+import Test.QuickCheck.StateModel
+import Test.Tasty
+import Test.Tasty.QuickCheck hiding (Some (..))
+import Test.Util.TestBlock (TestBlock, TestHash (..))
+import Test.Util.TestEnv (adjustQuickCheckTests)
+
+tests :: TestTree
+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")
+
+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 TestBlock -> Action Model AddPerasCertResult
+    GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock)
+    GarbageCollect :: SlotNo -> Action Model ()
+
+  arbitraryAction _ (Model model)
+    | model.open =
+        frequency
+          [ (1, pure $ Some CloseDB)
+          , (20, Some <$> genAddCert)
+          , (20, pure $ Some GetWeightSnapshot)
+          , (5, Some . GarbageCollect . SlotNo <$> arbitrary)
+          ]
+    | otherwise = pure $ Some OpenDB
+   where
+    genAddCert = do
+      pcCertRound <- PerasRoundNo <$> 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
+    OpenDB -> Model.openDB model
+    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
+    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'
+        GetWeightSnapshot -> True
+        GarbageCollect _slot -> 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 $ forgetFingerprint <$> PerasCertDB.getWeightSnapshot perasCertDB
+    GarbageCollect slot -> do
+      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
+    counterexamplePost $ "SUT: " <> show actual
+    pure $ expected == actual
+  postcondition _ _ _ _ = pure True