LedgerDB: abstract out immutability criterion

The only remaining use of the `SecurityParam` is for the snapshot policy 🙃

Author: amesgen

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs

@@ -71,6 +71,7 @@ openLedgerDB [email protected]{LedgerDB.lgrFlavorArgs = LedgerDB.L
           lgrDbArgs
           bss
           (\_ -> error "no replay")
+          (LedgerDB.praosGetVolatileSuffix $ LedgerDB.ledgerDbCfgSecParam $ LedgerDB.lgrConfig lgrDbArgs)
       )
       emptyStream
       genesisPoint
@@ -83,6 +84,7 @@ openLedgerDB [email protected]{LedgerDB.lgrFlavorArgs = LedgerDB.L
           lgrDbArgs
           args
           (\_ -> error "no replay")
+          (LedgerDB.praosGetVolatileSuffix $ LedgerDB.ledgerDbCfgSecParam $ LedgerDB.lgrConfig lgrDbArgs)
       )
       emptyStream
       genesisPoint

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs

@@ -160,12 +160,14 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
   (chainDB, testing, env) <- lift $ do
     traceWith tracer $ TraceOpenEvent (OpenedVolatileDB maxSlot)
     traceWith tracer $ TraceOpenEvent StartedOpeningLgrDB
+    let secParam = configSecurityParam $ Args.cdbsTopLevelConfig cdbSpecificArgs
     (lgrDB, replayed) <-
       LedgerDB.openDB
         argsLgrDb
         (ImmutableDB.streamAPI immutableDB)
         immutableDbTipPoint
         (Query.getAnyKnownBlock immutableDB volatileDB)
+        (LedgerDB.praosGetVolatileSuffix secParam)
     traceWith tracer $ TraceOpenEvent OpenedLgrDB
 
     varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0))

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

@@ -58,25 +58,29 @@ 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 =
             V2.mkInitDb
               args
               bss
               getBlock
+              getVolatileSuffix
        in doOpenDB args initDb stream replayGoal
 
 {-------------------------------------------------------------------------------

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

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

@@ -19,7 +19,6 @@
 -- module will be gone.
 module Ouroboros.Consensus.Storage.LedgerDB.V1 (mkInitDb) where
 
-import Cardano.Ledger.BaseTypes.NonZero (NonZero (..))
 import Control.Arrow ((>>>))
 import Control.Monad
 import Control.Monad.Except
@@ -69,6 +68,7 @@ import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.CallStack
 import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Network.AnchoredSeq (AnchoredSeq)
 import qualified Ouroboros.Network.AnchoredSeq as AS
 import Ouroboros.Network.Protocol.LocalStateQuery.Type
 import System.FS.API
@@ -84,8 +84,9 @@ mkInitDb ::
   Complete LedgerDbArgs m blk ->
   Complete V1.LedgerDbFlavorArgs m ->
   ResolveBlock m blk ->
+  GetVolatileSuffix m blk ->
   InitDB (DbChangelog' blk, ResourceKey m, BackingStore' m blk) m blk
-mkInitDb args bss getBlock =
+mkInitDb args bss getBlock getVolatileSuffix =
   InitDB
     { initFromGenesis = do
         st <- lgrGenesis
@@ -143,6 +144,7 @@ mkInitDb args bss getBlock =
                 , ldbShouldFlush = shouldFlush flushFreq
                 , ldbQueryBatchSize = lgrQueryBatchSize
                 , ldbResolveBlock = getBlock
+                , ldbGetVolatileSuffix = getVolatileSuffix
                 }
         h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
         pure $ implMkLedgerDb h
@@ -204,10 +206,11 @@ implGetImmutableTip ::
   (MonadSTM m, GetTip l) =>
   LedgerDBEnv m l blk ->
   STM m (l EmptyMK)
-implGetImmutableTip env =
+implGetImmutableTip env = do
+  volSuffix <- getVolatileSuffix $ ldbGetVolatileSuffix env
   -- The DbChangelog might contain more than k states if they have not yet
   -- been garbage-collected.
-  fmap (AS.anchor . AS.anchorNewest (envMaxRollbacks env) . changelogStates)
+  fmap (AS.anchor . volSuffix . changelogStates)
     . readTVar
     $ ldbChangelog env
 
@@ -220,7 +223,8 @@ implGetPastLedgerState ::
   , HeaderHash l ~ HeaderHash blk
   ) =>
   LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
-implGetPastLedgerState env point =
+implGetPastLedgerState env point = do
+  volSuffix <- getVolatileSuffix $ ldbGetVolatileSuffix env
   readTVar (ldbChangelog env) <&> \chlog -> do
     -- The DbChangelog might contain more than k states if they have not yet
     -- been garbage-collected, so make sure that the point is volatile (or the
@@ -229,7 +233,7 @@ implGetPastLedgerState env point =
       AS.withinBounds
         (pointSlot point)
         ((point ==) . castPoint . either getTip getTip)
-        (AS.anchorNewest (envMaxRollbacks env) (changelogStates chlog))
+        (volSuffix (changelogStates chlog))
     getPastLedgerAt point chlog
 
 implGetHeaderStateHistory ::
@@ -242,6 +246,7 @@ implGetHeaderStateHistory ::
   LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
 implGetHeaderStateHistory env = do
   ldb <- readTVar (ldbChangelog env)
+  volSuffix <- getVolatileSuffix $ ldbGetVolatileSuffix env
   let currentLedgerState = ledgerState $ current ldb
       -- This summary can convert all tip slots of the ledger states in the
       -- @ledgerDb@ as these are not newer than the tip slot of the current
@@ -255,7 +260,7 @@ implGetHeaderStateHistory env = do
     . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime'
     -- The DbChangelog might contain more than k states if they have not yet
     -- been garbage-collected, so only take the corresponding suffix.
-    . AS.anchorNewest (envMaxRollbacks env)
+    . volSuffix
     $ changelogStates ldb
 
 implValidate ::
@@ -571,6 +576,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv
   -- frequency that was provided when opening the LedgerDB.
   , ldbQueryBatchSize :: !QueryBatchSize
   , ldbResolveBlock :: !(ResolveBlock m blk)
+  , ldbGetVolatileSuffix :: !(GetVolatileSuffix m blk)
   }
   deriving Generic
 
@@ -584,10 +590,6 @@ deriving instance
   ) =>
   NoThunks (LedgerDBEnv m l blk)
 
--- | Return the security parameter @k@. Convenience function.
-envMaxRollbacks :: LedgerDBEnv m l blk -> Word64
-envMaxRollbacks = unNonZero . maxRollbacks . ledgerDbCfgSecParam . ldbCfg
-
 -- | Check if the LedgerDB is open, if so, executing the given function on the
 -- 'LedgerDBEnv', otherwise, throw a 'CloseDBError'.
 getEnv ::
@@ -759,10 +761,16 @@ acquireAtTarget ::
   ReadLocked m (Either GetForkerError (DbChangelog l))
 acquireAtTarget ldbEnv target = readLocked $ runExceptT $ do
   dblog <- lift $ readTVarIO (ldbChangelog ldbEnv)
+  volSuffix <- lift $ atomically $ getVolatileSuffix $ ldbGetVolatileSuffix env
   -- The DbChangelog might contain more than k states if they have not yet
   -- been garbage-collected.
-  let immTip :: Point blk
-      immTip = castPoint $ getTip $ AS.anchor $ AS.anchorNewest k $ changelogStates dblog
+  let volStates = volSuffix $ changelogStates dblog
+
+      immTip :: Point blk
+      immTip = castPoint $ getTip $ AS.anchor volStates
+
+      rollbackMax :: Word64
+      rollbackMax = fromIntegral $ AS.length volStates
 
       rollbackTo pt
         | pointSlot pt < pointSlot immTip = throwError $ PointTooOld Nothing
@@ -775,7 +783,6 @@ acquireAtTarget ldbEnv target = readLocked $ runExceptT $ do
     Right ImmutableTip -> rollbackTo immTip
     Right (SpecificPoint pt) -> rollbackTo pt
     Left n -> do
-      let rollbackMax = maxRollback dblog `min` k
       when (n > rollbackMax) $
         throwError $
           PointTooOld $
@@ -787,8 +794,6 @@ acquireAtTarget ldbEnv target = readLocked $ runExceptT $ do
       case rollbackN n dblog of
         Nothing -> error "unreachable"
         Just dblog' -> pure dblog'
- where
-  k = envMaxRollbacks ldbEnv
 
 {-------------------------------------------------------------------------------
   Make forkers from consistent views

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

@@ -16,7 +16,6 @@
 
 module Ouroboros.Consensus.Storage.LedgerDB.V2 (mkInitDb) where
 
-import Cardano.Ledger.BaseTypes (unNonZero)
 import Control.Arrow ((>>>))
 import Control.Monad (join)
 import qualified Control.Monad as Monad (void, (>=>))
@@ -79,8 +78,9 @@ mkInitDb ::
   Complete LedgerDbArgs m blk ->
   Complete V2.LedgerDbFlavorArgs m ->
   ResolveBlock m blk ->
+  GetVolatileSuffix m blk ->
   InitDB (LedgerSeq' m blk) m blk
-mkInitDb args flavArgs getBlock =
+mkInitDb args flavArgs getBlock getVolatileSuffix =
   InitDB
     { initFromGenesis = emptyF =<< lgrGenesis
     , initFromSnapshot =
@@ -110,6 +110,7 @@ mkInitDb args flavArgs getBlock =
                 , ldbResolveBlock = getBlock
                 , ldbQueryBatchSize = lgrQueryBatchSize
                 , ldbOpenHandlesLock = lock
+                , ldbGetVolatileSuffix = getVolatileSuffix
                 }
         h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
         pure $ implMkLedgerDb h bss
@@ -486,6 +487,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv
   --
   --  * Modify 'ldbSeq' while holding a write lock, and then close the removed
   --    handles without any locking. See e.g. 'implGarbageCollect'.
+  , ldbGetVolatileSuffix :: !(GetVolatileSuffix m blk)
   }
   deriving Generic
 
@@ -579,11 +581,11 @@ getEnvSTM (LDBHandle varState) f =
 -- 'LedgerSeq' can contain more than @k@ states if we adopted new blocks, but
 -- garbage collection has not yet been run.
 getVolatileLedgerSeq ::
-  (MonadSTM m, GetTip l) => LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
-getVolatileLedgerSeq env =
-  LedgerSeq . AS.anchorNewest k . getLedgerSeq <$> readTVar (ldbSeq env)
- where
-  k = unNonZero $ maxRollbacks $ ledgerDbCfgSecParam $ ldbCfg env
+  (MonadSTM m, GetTip l) =>
+  LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
+getVolatileLedgerSeq env = do
+  volSuffix <- getVolatileSuffix (ldbGetVolatileSuffix env)
+  LedgerSeq . volSuffix . getLedgerSeq <$> readTVar (ldbSeq env)
 
 -- | Get a 'StateRef' from the 'LedgerSeq' (via 'getVolatileLedgerSeq') in the
 -- 'LedgerDBEnv', with the 'LedgerTablesHandle' having been duplicated (such

ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs

@@ -244,6 +244,7 @@ initLedgerDB s c = do
         streamAPI
         (Chain.headPoint c)
         (\rpt -> pure $ fromMaybe (error "impossible") $ Chain.findBlock ((rpt ==) . blockRealPoint) c)
+        (LedgerDB.praosGetVolatileSuffix s)
 
   result <-
     LedgerDB.validateFork

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs

@@ -504,13 +504,15 @@ openLedgerDB flavArgs env cfg fs = do
               args
               bss
               getBlock
+              (praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg)
        in openDBInternal args initDb stream replayGoal
     LedgerDbFlavorArgsV2 bss ->
       let initDb =
             V2.mkInitDb
               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)