Remove LedgerDbPruneKeeping

It was already superseded in the most important places due to
`LedgerDbPruneBeforeSlot`. Its remaining use cases are non-essential:

 - Replay on startup.

   In this case, we never roll back, so not maintaining k states is actually an
   optimization here. We can also remove the now-redundant `InitDB.pruneDb`
   function.

 - Internal functions used for db-analyser.

   Here, we can just as well use `LedgerDbPruneAll` (which is used by
   `pruneToImmTipOnly`) as we never need to roll back.

 - Testing.

   In particular, we remove some DbChangelog tests that previously ensured that
   only at most @k@ states are kept. This is now no longer true; that property
   is instead enforced by the LedgerDB built on top of the DbChangelog.

   A follow-up commit in this PR enriches the LedgerDB state machine test to
   make sure that the public API functions behave appropriately, ensuring that
   we don't lose test coverage (and also testing V2, which previously didn't
   have any such tests).

Author: amesgen

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs

@@ -304,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
@@ -462,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
@@ -551,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
@@ -609,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
@@ -784,8 +782,6 @@ type LedgerSupportsLedgerDB blk =
 data LedgerDbPrune
   = -- | Prune all states, keeping only the current tip.
     LedgerDbPruneAll
-  | -- | Prune to only keep the last @k@ states.
-    LedgerDbPruneKeeping SecurityParam
   | -- | Prune such that all (non-anchor) states are not older than the given
     -- slot.
     LedgerDbPruneBeforeSlot SlotNo

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs

@@ -121,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
@@ -437,7 +436,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 ::

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/DbChangelog.hs

@@ -359,37 +359,27 @@ 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 =
-  dblog{changelogStates = vol'}
- where
-  DbChangelog{changelogStates} = 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 =
   dblog{changelogStates = vol'}
  where

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs

@@ -91,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
@@ -211,8 +207,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
@@ -227,6 +224,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
@@ -249,6 +247,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

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,28 +228,23 @@ 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 2) ldb) == ldb'
 -- True
+--
+-- where @lX@ is a ledger state from slot @X@.
 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
@@ -298,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

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs

@@ -33,7 +33,6 @@ module Test.Ouroboros.Storage.ChainDB.Model
   , getBlock
   , getBlockByPoint
   , getBlockComponentByPoint
-  , getDbChangelog
   , getIsValid
   , getLoEFragment
   , getMaxSlotNo
@@ -84,11 +83,7 @@ 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)
@@ -129,11 +124,6 @@ import Ouroboros.Consensus.Storage.ChainDB.API
   )
 import Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel (olderThanK)
 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)
@@ -375,35 +365,6 @@ 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