Define SnapshotManager (#1643)

Author: jasagredo

ouroboros-consensus-cardano/app/snapshot-converter.hs

@@ -242,7 +242,7 @@ store config@Config{outpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS),
     Mem -> do
       lseq <- V2.empty state tbs $ V2.newInMemoryLedgerTablesHandle nullTracer fs
       let h = V2.currentHandle lseq
-      Monad.void $ V2.takeSnapshot ccfg nullTracer fs suffix h
+      Monad.void $ V2.implTakeSnapshot ccfg nullTracer fs suffix h
     LMDB -> do
       chlog <- newTVarIO (V1.empty state)
       lock <- V1.mkLedgerDBLock
@@ -254,7 +254,7 @@ store config@Config{outpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS),
           (V1.SnapshotsFS fs)
           (V1.InitFromValues (pointSlot $ getTip state) state tbs)
       Monad.void $ V1.withReadLock lock $ do
-        V1.takeSnapshot chlog ccfg nullTracer (V1.SnapshotsFS fs) bs suffix
+        V1.implTakeSnapshot chlog ccfg nullTracer (V1.SnapshotsFS fs) bs suffix
 store _ _ _ _ = error "Malformed output path!"
 
 main :: IO ()

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

@@ -17,6 +17,7 @@ import Control.ResourceRegistry
 import Control.Tracer (Tracer (..), nullTracer)
 import qualified Data.SOP.Dict as Dict
 import Data.Singletons (Sing, SingI (..))
+import Data.Void
 import qualified Debug.Trace as Debug
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
@@ -38,8 +39,10 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as LedgerDB.V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as LedgerDB.V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB.V2
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.Orphans ()
@@ -64,26 +67,34 @@ openLedgerDB ::
     , LedgerDB.TestInternals' IO blk
     )
 openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV1 bss} = do
+  let snapManager = LedgerDB.V1.snapshotManager lgrDbArgs
   (ledgerDB, _, intLedgerDB) <-
     LedgerDB.openDBInternal
       lgrDbArgs
       ( LedgerDB.V1.mkInitDb
           lgrDbArgs
           bss
           (\_ -> error "no replay")
+          snapManager
       )
+      snapManager
       emptyStream
       genesisPoint
   pure (ledgerDB, intLedgerDB)
 openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV2 args} = do
+  (snapManager, bss') <- case args of
+    LedgerDB.V2.V2Args LedgerDB.V2.InMemoryHandleArgs -> pure (InMemory.snapshotManager lgrDbArgs, LedgerDB.V2.InMemoryHandleEnv)
+    LedgerDB.V2.V2Args (LedgerDB.V2.LSMHandleArgs (LedgerDB.V2.LSMArgs x)) -> absurd x
   (ledgerDB, _, intLedgerDB) <-
     LedgerDB.openDBInternal
       lgrDbArgs
       ( LedgerDB.V2.mkInitDb
           lgrDbArgs
-          args
+          bss'
           (\_ -> error "no replay")
+          snapManager
       )
+      snapManager
       emptyStream
       genesisPoint
   pure (ledgerDB, intLedgerDB)

ouroboros-consensus/changelog.d/20250825_170621_javier.sagredo_snapshot_manager.md

@@ -0,0 +1,22 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+### Breaking
+
+- Group snapshot management functions in the new datatype `SnapshotManager`.

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

@@ -18,6 +18,7 @@ module Ouroboros.Consensus.Storage.LedgerDB
   ) where
 
 import Data.Functor.Contravariant ((>$<))
+import Data.Void
 import Data.Word
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.HardFork.Abstract
@@ -27,9 +28,13 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Stream
 import Ouroboros.Consensus.Storage.LedgerDB.API
 import Ouroboros.Consensus.Storage.LedgerDB.Args
 import Ouroboros.Consensus.Storage.LedgerDB.Forker
+import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
 import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as V1
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as V2
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.CallStack
 import Ouroboros.Consensus.Util.IOLike
@@ -39,11 +44,11 @@ openDB ::
   forall m blk.
   ( IOLike m
   , LedgerSupportsProtocol blk
-  , LedgerDbSerialiseConstraints blk
   , InspectLedger blk
   , HasCallStack
   , HasHardForkHistory blk
   , LedgerSupportsLedgerDB blk
+  , LedgerDbSerialiseConstraints blk
   ) =>
   -- | Stateless initializaton arguments
   Complete LedgerDbArgs m blk ->
@@ -65,38 +70,45 @@ openDB
   replayGoal
   getBlock = case lgrFlavorArgs args of
     LedgerDbFlavorArgsV1 bss ->
-      let initDb =
+      let snapManager = V1.snapshotManager args
+          initDb =
             V1.mkInitDb
               args
               bss
               getBlock
-       in doOpenDB args initDb stream replayGoal
-    LedgerDbFlavorArgsV2 bss ->
+              snapManager
+       in doOpenDB args initDb snapManager stream replayGoal
+    LedgerDbFlavorArgsV2 bss -> do
+      (snapManager, bss') <- case bss of
+        V2.V2Args V2.InMemoryHandleArgs -> pure (InMemory.snapshotManager args, V2.InMemoryHandleEnv)
+        V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs x)) -> absurd x
       let initDb =
             V2.mkInitDb
               args
-              bss
+              bss'
               getBlock
-       in doOpenDB args initDb stream replayGoal
+              snapManager
+      doOpenDB args initDb snapManager stream replayGoal
 
 {-------------------------------------------------------------------------------
   Opening a LedgerDB
 -------------------------------------------------------------------------------}
 
 doOpenDB ::
-  forall m blk db.
+  forall m n blk db st.
   ( IOLike m
   , LedgerSupportsProtocol blk
   , InspectLedger blk
   , HasCallStack
   ) =>
   Complete LedgerDbArgs m blk ->
   InitDB db m blk ->
+  SnapshotManager m n blk st ->
   StreamAPI m blk blk ->
   Point blk ->
   m (LedgerDB' m blk, Word64)
-doOpenDB args initDb stream replayGoal =
-  f <$> openDBInternal args initDb stream replayGoal
+doOpenDB args initDb snapManager stream replayGoal =
+  f <$> openDBInternal args initDb snapManager stream replayGoal
  where
   f (ldb, replayCounter, _) = (ldb, replayCounter)
 
@@ -109,28 +121,28 @@ openDBInternal ::
   ) =>
   Complete LedgerDbArgs m blk ->
   InitDB db m blk ->
+  SnapshotManager m n blk st ->
   StreamAPI m blk blk ->
   Point blk ->
   m (LedgerDB' m blk, Word64, TestInternals' m blk)
-openDBInternal args@(LedgerDbArgs{lgrHasFS = SomeHasFS fs}) initDb stream replayGoal = do
+openDBInternal args@(LedgerDbArgs{lgrHasFS = SomeHasFS fs}) initDb snapManager stream replayGoal = do
   createDirectoryIfMissing fs True (mkFsPath [])
   (_initLog, db, replayCounter) <-
     initialize
       replayTracer
       snapTracer
-      lgrHasFS
       lgrConfig
       stream
       replayGoal
       initDb
+      snapManager
       lgrStartSnapshot
   (ledgerDb, internal) <- mkLedgerDb initDb db
   return (ledgerDb, replayCounter, internal)
  where
   LedgerDbArgs
     { lgrConfig
     , lgrTracer
-    , lgrHasFS
     , lgrStartSnapshot
     } = args
 

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

@@ -193,7 +193,6 @@ import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.IndexedMemPack
 import Ouroboros.Network.Block
 import Ouroboros.Network.Protocol.LocalStateQuery.Type
-import System.FS.API
 
 {-------------------------------------------------------------------------------
   Main API
@@ -465,7 +464,7 @@ data InitDB db m blk = InitDB
   -- ^ Create a DB from the genesis state
   , initFromSnapshot :: !(DiskSnapshot -> m (Either (SnapshotFailure blk) (db, RealPoint blk)))
   -- ^ Create a DB from a Snapshot
-  , closeDb :: !(db -> m ())
+  , abortLedgerDbInit :: !(db -> m ())
   -- ^ Closing the database, to be reopened again with a different snapshot or
   -- with the genesis state.
   , initReapplyBlock :: !(LedgerDbCfg (ExtLedgerState blk) -> blk -> db -> m db)
@@ -500,35 +499,35 @@ data InitDB db m blk = InitDB
 -- obtained in this way will (hopefully) share much of their memory footprint
 -- with their predecessors.
 initialize ::
-  forall m blk db.
+  forall m n blk db st.
   ( IOLike m
   , LedgerSupportsProtocol blk
   , InspectLedger blk
   , HasCallStack
   ) =>
   Tracer m (TraceReplayEvent blk) ->
   Tracer m (TraceSnapshotEvent blk) ->
-  SomeHasFS m ->
   LedgerDbCfg (ExtLedgerState blk) ->
   StreamAPI m blk blk ->
   Point blk ->
   InitDB db m blk ->
+  SnapshotManager m n blk st ->
   Maybe DiskSnapshot ->
   m (InitLog blk, db, Word64)
 initialize
   replayTracer
   snapTracer
-  hasFS
   cfg
   stream
   replayGoal
   dbIface
+  snapManager
   fromSnapshot =
     case fromSnapshot of
-      Nothing -> listSnapshots hasFS >>= tryNewestFirst id
+      Nothing -> listSnapshots snapManager >>= tryNewestFirst id
       Just snap -> tryNewestFirst id [snap]
    where
-    InitDB{initFromGenesis, initFromSnapshot, closeDb} = dbIface
+    InitDB{initFromGenesis, initFromSnapshot, abortLedgerDbInit} = dbIface
 
     tryNewestFirst ::
       (InitLog blk -> InitLog blk) ->
@@ -555,7 +554,7 @@ initialize
 
       case eDB of
         Left err -> do
-          closeDb initDb
+          abortLedgerDbInit initDb
           error $ "Invariant violation: invalid immutable chain " <> show err
         Right (db, replayed) -> return (acc InitFromGenesis, db, replayed)
     tryNewestFirst acc (s : ss) = do
@@ -579,15 +578,15 @@ initialize
           traceWith snapTracer $ InvalidSnapshot s err
           Monad.when (diskSnapshotIsTemporary s) $ do
             traceWith snapTracer $ DeletedSnapshot s
-            deleteSnapshot hasFS s
+            deleteSnapshot snapManager s
           tryNewestFirst (acc . InitFailure s err) ss
 
         -- If we fail to use this snapshot for any other reason, delete it and
         -- try an older one
         Left err -> do
           Monad.when (diskSnapshotIsTemporary s || err == InitFailureGenesis) $ do
             traceWith snapTracer $ DeletedSnapshot s
-            deleteSnapshot hasFS s
+            deleteSnapshot snapManager s
           traceWith snapTracer . InvalidSnapshot s $ err
           tryNewestFirst (acc . InitFailure s err) ss
         Right (initDb, pt) -> do
@@ -606,8 +605,8 @@ initialize
           case eDB of
             Left err -> do
               traceWith snapTracer . InvalidSnapshot s $ err
-              Monad.when (diskSnapshotIsTemporary s) $ deleteSnapshot hasFS s
-              closeDb initDb
+              Monad.when (diskSnapshotIsTemporary s) $ deleteSnapshot snapManager s
+              abortLedgerDbInit initDb
               tryNewestFirst (acc . InitFailure s err) ss
             Right (db, replayed) -> return (acc (InitFromSnapshot s pt), db, replayed)