LedgerDB: implement predictable snapshotting

Author: amesgen

ouroboros-consensus/changelog.d/20250630_100300_alexander.esgen_predictable_snapshots.md

@@ -0,0 +1,6 @@
+### Breaking
+
+- LedgerDB: implemented *predictable* snapshots, i.e. different nodes with the
+  same configuration will now create snapshots for the same slots.
+
+  See 'SnapshotPolicyArgs' for more details.

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

@@ -160,7 +160,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
   (chainDB, testing, env) <- lift $ do
     traceWith tracer $ TraceOpenEvent (OpenedVolatileDB maxSlot)
     traceWith tracer $ TraceOpenEvent StartedOpeningLgrDB
-    (lgrDB, replayed) <-
+    (lgrDB, _replayed) <-
       LedgerDB.openDB
         argsLgrDb
         (ImmutableDB.streamAPI immutableDB)
@@ -281,8 +281,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , 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
+            , intTryTakeSnapshot = getEnv h $ LedgerDB.tryTakeSnapshot . cdbLedgerDB
             , intAddBlockRunner = getEnv h (Background.addBlockRunner addBlockTestFuse)
             , intKillBgThreads = varKillBgThreads
             }
@@ -293,7 +292,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
           (castPoint $ AF.anchorPoint chain)
           (castPoint $ AF.headPoint chain)
 
-    when launchBgTasks $ Background.launchBgTasks env replayed
+    when launchBgTasks $ Background.launchBgTasks env
 
     return (chainDB, testing, env)
 

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

@@ -1,13 +1,11 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 
 -- | Background tasks:
 --
@@ -53,7 +51,6 @@ import Data.Sequence.Strict (StrictSeq (..))
 import qualified Data.Sequence.Strict as Seq
 import Data.Time.Clock
 import Data.Void (Void)
-import Data.Word
 import GHC.Generics (Generic)
 import GHC.Stack (HasCallStack)
 import Ouroboros.Consensus.Block
@@ -77,7 +74,7 @@ import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.Condense
 import Ouroboros.Consensus.Util.Enclose (Enclosing' (..))
 import Ouroboros.Consensus.Util.IOLike
-import Ouroboros.Consensus.Util.STM (Watcher (..), forkLinkedWatcher)
+import Ouroboros.Consensus.Util.STM (Watcher (..), blockUntilJust, forkLinkedWatcher)
 import Ouroboros.Network.AnchoredFragment (AnchoredSeq (..))
 import qualified Ouroboros.Network.AnchoredFragment as AF
 
@@ -94,15 +91,13 @@ launchBgTasks ::
   , HasHardForkHistory blk
   ) =>
   ChainDbEnv m blk ->
-  -- | Number of immutable blocks replayed on ledger DB startup
-  Word64 ->
   m ()
-launchBgTasks cdb@CDB{..} replayed = do
+launchBgTasks cdb@CDB{..} = do
   !addBlockThread <-
     launch "ChainDB.addBlockRunner" $
       addBlockRunner cdbChainSelFuse cdb
 
-  ledgerDbTasksTrigger <- newLedgerDbTasksTrigger replayed
+  ledgerDbTasksTrigger <- newLedgerDbTasksTrigger
   !ledgerDbMaintenaceThread <-
     forkLinkedWatcher cdbRegistry "ChainDB.ledgerDbTasksTasks" $
       ledgerDbTasksTasks cdb ledgerDbTasksTrigger
@@ -260,18 +255,17 @@ copyToImmutableDBRunner cdb@CDB{..} ledgerDbTasksTrigger gcSchedule fuse = do
   copyAndTrigger :: m ()
   copyAndTrigger = do
     -- Wait for the chain to grow larger than @k@
-    numToWrite <- atomically $ do
+    atomically $ do
       curChain <- icWithoutTime <$> readTVar cdbChain
       check $ fromIntegral (AF.length curChain) > unNonZero k
-      return $ fromIntegral (AF.length curChain) - unNonZero k
 
     -- Copy blocks to ImmutableDB
     --
     -- This is a synchronous operation: when it returns, the blocks have been
     -- copied to disk (though not flushed, necessarily).
     gcSlotNo <- withFuse fuse (copyToImmutableDB cdb)
 
-    triggerLedgerDbTasks ledgerDbTasksTrigger gcSlotNo numToWrite
+    triggerLedgerDbTasks ledgerDbTasksTrigger gcSlotNo
     scheduleGC' gcSlotNo
 
   scheduleGC' :: WithOrigin SlotNo -> m ()
@@ -293,45 +287,20 @@ copyToImmutableDBRunner cdb@CDB{..} ledgerDbTasksTrigger gcSchedule fuse = do
 -- | 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)
+  = LedgerDbTasksTrigger (StrictTVar m (WithOrigin SlotNo))
 
-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
-      }
+newLedgerDbTasksTrigger :: IOLike m => m (LedgerDbTasksTrigger m)
+newLedgerDbTasksTrigger = LedgerDbTasksTrigger <$> newTVarIO Origin
 
 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
-      }
+triggerLedgerDbTasks (LedgerDbTasksTrigger varSt) =
+  atomically . writeTVar varSt
 
 -- | Run LedgerDB maintenance tasks when 'LedgerDbTasksTrigger' changes.
 --
@@ -343,38 +312,16 @@ ledgerDbTasksTasks ::
   IOLike m =>
   ChainDbEnv m blk ->
   LedgerDbTasksTrigger m ->
-  Watcher m LedgerDbTaskState (WithOrigin SlotNo)
+  Watcher m SlotNo SlotNo
 ledgerDbTasksTasks CDB{..} (LedgerDbTasksTrigger varSt) =
   Watcher
-    { wFingerprint = ldbtsImmTip
+    { wFingerprint = id
     , 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
+    , wReader = blockUntilJust $ withOriginToMaybe <$> readTVar varSt
+    , wNotify = \slotNo -> do
+        LedgerDB.tryFlush cdbLedgerDB
+        LedgerDB.tryTakeSnapshot cdbLedgerDB
+        LedgerDB.garbageCollect cdbLedgerDB slotNo
     }
 
 {-------------------------------------------------------------------------------

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

@@ -149,9 +149,6 @@ module Ouroboros.Consensus.Storage.LedgerDB.API
   , withPrivateTipForker
   , withTipForker
 
-    -- * Snapshots
-  , SnapCounters (..)
-
     -- * Testing
   , TestInternals (..)
   , TestInternals'
@@ -160,7 +157,6 @@ module Ouroboros.Consensus.Storage.LedgerDB.API
 
 import Codec.Serialise
 import qualified Control.Monad as Monad
-import Control.Monad.Class.MonadTime.SI
 import Control.Monad.Except
 import Control.ResourceRegistry
 import Control.Tracer
@@ -262,18 +258,12 @@ data LedgerDB m l blk = LedgerDB
   --  * The set of previously applied points.
   , tryTakeSnapshot ::
       l ~ ExtLedgerState blk =>
-      Maybe (Time, Time) ->
-      Word64 ->
-      m SnapCounters
+      m ()
   -- ^ If the provided arguments indicate so (based on the SnapshotPolicy with
   -- which this LedgerDB was opened), take a snapshot and delete stale ones.
   --
-  -- The arguments are:
-  --
-  -- - If a snapshot has been taken already, the time at which it was taken
-  --   and the current time.
-  --
-  -- - How many blocks have been processed since the last snapshot.
+  -- For V1, this must not be called concurrently with 'garbageCollect' and/or
+  -- 'tryFlush'.
   , tryFlush :: m ()
   -- ^ Flush V1 in-memory LedgerDB state to disk, if possible. This is a no-op
   -- for implementations that do not need an explicit flush function.
@@ -420,18 +410,6 @@ getReadOnlyForker ::
   m (Either GetForkerError (ReadOnlyForker m l blk))
 getReadOnlyForker ldb rr pt = fmap readOnlyForker <$> getForkerAtTarget ldb rr pt
 
-{-------------------------------------------------------------------------------
-  Snapshots
--------------------------------------------------------------------------------}
-
--- | Counters to keep track of when we made the last snapshot.
-data SnapCounters = SnapCounters
-  { prevSnapshotTime :: !(Maybe Time)
-  -- ^ When was the last time we made a snapshot
-  , ntBlocksSinceLastSnap :: !Word64
-  -- ^ How many blocks have we processed since the last snapshot
-  }
-
 {-------------------------------------------------------------------------------
   Initialization
 -------------------------------------------------------------------------------}