From 1940d683c33d861bfdb8798df032a83b787d7c70 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 25 Aug 2025 12:18:53 +0200 Subject: [PATCH 1/3] Rework LedgerDB arguments in preparation for LSM trees --- .../Consensus/Storage/LedgerDB/V2/Args.hs | 31 ++++++++++--------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs index 99eaad0d28..068d64d529 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs @@ -1,29 +1,32 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Storage.LedgerDB.V2.Args ( FlavorImplSpecificTrace (..) , HandleArgs (..) + , HandleEnv (..) , LedgerDbFlavorArgs (..) + , LSMHandleArgs (..) ) where -import Data.Void (Void) -import GHC.Generics -import NoThunks.Class +import Data.Void -data LedgerDbFlavorArgs f m = V2Args HandleArgs +data LedgerDbFlavorArgs f m = V2Args (HandleArgs f m) -data HandleArgs +-- | The arguments that are needed to create a 'HandleEnv' for the different +-- backends. +data HandleArgs f m = InMemoryHandleArgs - | LSMHandleArgs Void - deriving (Generic, NoThunks) + | LSMHandleArgs (LSMHandleArgs f m) + +data LSMHandleArgs f m = LSMArgs Void + +-- | The environment used to create new handles +data HandleEnv m + = InMemoryHandleEnv + | -- | The environment for creating LSM handles. It carries the 'Session' + -- together with its resource key and the resource key of the 'HasBlockIO'. + LSMHandleEnv !Void data FlavorImplSpecificTrace = -- | Created a new 'LedgerTablesHandle', potentially by duplicating an From b186845d8faa1021bdb5bc2d0f38b39a45c7bb35 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 25 Aug 2025 12:19:26 +0200 Subject: [PATCH 2/3] Return a Maybe CRC when taking a V2 snapshot in preparation for LSM --- .../Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs | 2 +- .../Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs index 0413a06af6..1a6751f4d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs @@ -139,7 +139,7 @@ newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do guardClosed h $ \values -> withFile hasFS (mkFsPath [snapshotName, "tables", "tvar"]) (WriteMode MustBeNew) $ \hf -> - fmap snd $ + fmap (Just . snd) $ hPutAllCRC hasFS hf $ CBOR.toLazyByteString $ valuesMKEncoder hint values 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 52719cc453..6768a6d44b 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 @@ -95,7 +95,7 @@ data LedgerTablesHandle m l = LedgerTablesHandle -- The first argument has to be the ledger state before applying -- the block, the second argument should be the ledger state after -- applying a block. See 'CanUpgradeLedgerTables'. - , takeHandleSnapshot :: !(l EmptyMK -> String -> m CRC) + , takeHandleSnapshot :: !(l EmptyMK -> String -> m (Maybe CRC)) , tablesSize :: !(m (Maybe Int)) -- ^ Consult the size of the ledger tables in the database. This will return -- 'Nothing' in backends that do not support this operation. From 66c3d485da54174de45c2d053b1e81c4e91ac3c9 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 25 Aug 2025 12:20:33 +0200 Subject: [PATCH 3/3] Define SnapshotManager Different LedgerDB backends will manage snapshots in different ways. In particular, before LSM trees each snapshot was fully contained in a directory in the ledger folder of the ChainDB. However LSM trees store part of the snapshot in the LSM database, which might be somewhere else. The SnapshotManagement record of functions provide a common interface for managing the snapshots. --- .../app/snapshot-converter.hs | 4 +- .../Cardano/Tools/DBAnalyser/Run.hs | 13 +- ..._170621_javier.sagredo_snapshot_manager.md | 22 +++ .../Ouroboros/Consensus/Storage/LedgerDB.hs | 36 ++-- .../Consensus/Storage/LedgerDB/API.hs | 23 ++- .../Consensus/Storage/LedgerDB/Snapshots.hs | 69 ++++---- .../Consensus/Storage/LedgerDB/V1.hs | 61 +++---- .../Storage/LedgerDB/V1/Snapshots.hs | 49 +++++- .../Consensus/Storage/LedgerDB/V2.hs | 158 ++++++++---------- .../Consensus/Storage/LedgerDB/V2/InMemory.hs | 50 +++++- .../Storage/LedgerDB/StateMachine.hs | 19 ++- 11 files changed, 311 insertions(+), 193 deletions(-) create mode 100644 ouroboros-consensus/changelog.d/20250825_170621_javier.sagredo_snapshot_manager.md diff --git a/ouroboros-consensus-cardano/app/snapshot-converter.hs b/ouroboros-consensus-cardano/app/snapshot-converter.hs index 2dce04b5a6..909ae11bff 100644 --- a/ouroboros-consensus-cardano/app/snapshot-converter.hs +++ b/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 () 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..38f64cb447 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 @@ -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,6 +67,7 @@ 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 @@ -71,19 +75,26 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.L 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) diff --git a/ouroboros-consensus/changelog.d/20250825_170621_javier.sagredo_snapshot_manager.md b/ouroboros-consensus/changelog.d/20250825_170621_javier.sagredo_snapshot_manager.md new file mode 100644 index 0000000000..ce8fea39bd --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250825_170621_javier.sagredo_snapshot_manager.md @@ -0,0 +1,22 @@ + + + + +### Breaking + +- Group snapshot management functions in the new datatype `SnapshotManager`. 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..8119c94065 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/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,26 +70,32 @@ 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 @@ -92,11 +103,12 @@ doOpenDB :: ) => 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,20 +121,21 @@ 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) @@ -130,7 +143,6 @@ openDBInternal args@(LedgerDbArgs{lgrHasFS = SomeHasFS fs}) initDb stream replay LedgerDbArgs { lgrConfig , lgrTracer - , lgrHasFS , lgrStartSnapshot } = args 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 8db64c44bc..50fddfc221 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 @@ -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,7 +499,7 @@ 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 @@ -508,27 +507,27 @@ initialize :: ) => 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,7 +578,7 @@ 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 @@ -587,7 +586,7 @@ initialize 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) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs index 0148964163..76b4a29267 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs @@ -43,10 +43,11 @@ module Ouroboros.Consensus.Storage.LedgerDB.Snapshots , snapshotToMetadataPath -- * Management - , deleteSnapshot - , listSnapshots - , loadSnapshotMetadata + , SnapshotManager (..) + , defaultDeleteSnapshot + , defaultListSnapshots , trimSnapshots + , loadSnapshotMetadata , writeSnapshotMetadata -- * Policy @@ -205,6 +206,25 @@ data MetadataErr MetadataBackendMismatch deriving (Eq, Show) +-- | Management of snapshots for the different LedgerDB backends. +-- +-- The LedgerDB V1 takes snapshots in @ReadLocked m@, hence the two different +-- @m@ and @n@ monad types. +data SnapshotManager m n blk st = SnapshotManager + { listSnapshots :: m [DiskSnapshot] + , deleteSnapshot :: DiskSnapshot -> m () + , takeSnapshot :: + Maybe String -> + -- \^ The (possibly empty) suffix for the snapshot name + st -> + -- \^ The state needed for taking the snapshot: + -- - In V1: this will be the DbChangelog and the Backing store + -- - In V2: this will be a StateRef + n (Maybe (DiskSnapshot, RealPoint blk)) + -- \^ If a Snapshot was taken, its information and the point at which it + -- was taken. + } + -- | Named snapshot are permanent, they will never be deleted even if failing to -- deserialize. diskSnapshotIsPermanent :: DiskSnapshot -> Bool @@ -228,19 +248,21 @@ snapshotFromPath fileName = do _ : str -> Just str -- | List on-disk snapshots, highest number first. -listSnapshots :: Monad m => SomeHasFS m -> m [DiskSnapshot] -listSnapshots (SomeHasFS HasFS{listDirectory}) = +defaultListSnapshots :: Monad m => SomeHasFS m -> m [DiskSnapshot] +defaultListSnapshots (SomeHasFS HasFS{listDirectory}) = aux <$> listDirectory (mkFsPath []) where aux :: Set String -> [DiskSnapshot] aux = List.sortOn (Down . dsNumber) . mapMaybe snapshotFromPath . Set.toList -- | Delete snapshot from disk -deleteSnapshot :: (Monad m, HasCallStack) => SomeHasFS m -> DiskSnapshot -> m () -deleteSnapshot (SomeHasFS HasFS{doesDirectoryExist, removeDirectoryRecursive}) ss = do +defaultDeleteSnapshot :: + (Monad m, HasCallStack) => SomeHasFS m -> Tracer m (TraceSnapshotEvent blk) -> DiskSnapshot -> m () +defaultDeleteSnapshot (SomeHasFS HasFS{doesDirectoryExist, removeDirectoryRecursive}) tracer ss = do let p = snapshotToDirPath ss exists <- doesDirectoryExist p when exists (removeDirectoryRecursive p) + traceWith tracer (DeletedSnapshot ss) -- | Write a snapshot metadata JSON file. writeSnapshotMetadata :: @@ -276,25 +298,16 @@ loadSnapshotMetadata (SomeHasFS hasFS) ds = ExceptT $ do Left decodeErr -> pure $ Left $ MetadataInvalid decodeErr Right meta -> pure $ Right meta -snapshotsMapM_ :: Monad m => SomeHasFS m -> (FilePath -> m a) -> m () -snapshotsMapM_ (SomeHasFS fs) f = do - mapM_ f - =<< Set.lookupMax . Set.filter (isJust . snapshotFromPath) <$> listDirectory fs (mkFsPath []) +snapshotsMapM_ :: Monad m => SnapshotManager m n blk st -> (DiskSnapshot -> m a) -> m () +snapshotsMapM_ snapManager f = + mapM_ f =<< listSnapshots snapManager -- | Testing only! Destroy all snapshots in the DB. -destroySnapshots :: Monad m => SomeHasFS m -> m () -destroySnapshots sfs@(SomeHasFS fs) = do +destroySnapshots :: Monad m => SnapshotManager m n blk st -> m () +destroySnapshots snapManager = snapshotsMapM_ - sfs - ( ( \d -> do - isDir <- doesDirectoryExist fs d - if isDir - then removeDirectoryRecursive fs d - else removeFile fs d - ) - . mkFsPath - . (: []) - ) + snapManager + (deleteSnapshot snapManager) -- | Read an extended ledger state from disk readExtLedgerState :: @@ -336,20 +349,18 @@ writeExtLedgerState (SomeHasFS hasFS) encLedger path cs = do -- The deleted snapshots are returned. trimSnapshots :: Monad m => - Tracer m (TraceSnapshotEvent r) -> - SomeHasFS m -> + SnapshotManager m n blk st -> SnapshotPolicy -> m [DiskSnapshot] -trimSnapshots tracer fs SnapshotPolicy{onDiskNumSnapshots} = do +trimSnapshots snapManager SnapshotPolicy{onDiskNumSnapshots} = do -- We only trim temporary snapshots - ss <- filter diskSnapshotIsTemporary <$> listSnapshots fs + ss <- filter diskSnapshotIsTemporary <$> listSnapshots snapManager -- The snapshot are most recent first, so we can simply drop from the -- front to get the snapshots that are "too" old. let ssTooOld = drop (fromIntegral onDiskNumSnapshots) ss mapM ( \s -> do - deleteSnapshot fs s - traceWith tracer $ DeletedSnapshot s + deleteSnapshot snapManager s pure s ) ssTooOld 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 d03775f0a6..85e936f736 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 @@ -73,6 +73,9 @@ import qualified Ouroboros.Network.AnchoredSeq as AS import Ouroboros.Network.Protocol.LocalStateQuery.Type import System.FS.API +type SnapshotManagerV1 m blk = + SnapshotManager m (ReadLocked m) blk (StrictTVar m (DbChangelog' blk), BackingStore' m blk) + mkInitDb :: forall m blk. ( LedgerSupportsProtocol blk @@ -84,8 +87,9 @@ mkInitDb :: Complete LedgerDbArgs m blk -> Complete V1.LedgerDbFlavorArgs m -> ResolveBlock m blk -> + SnapshotManagerV1 m blk -> InitDB (DbChangelog' blk, ResourceKey m, BackingStore' m blk) m blk -mkInitDb args bss getBlock = +mkInitDb args bss getBlock snapManager = InitDB { initFromGenesis = do st <- lgrGenesis @@ -105,7 +109,7 @@ mkInitDb args bss getBlock = (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig) lgrHasFS' lgrRegistry - , closeDb = \(_, r, _) -> void $ release r + , abortLedgerDbInit = \(_, r, _) -> void $ release r , initReapplyBlock = \cfg blk (chlog, r, bstore) -> do !chlog' <- reapplyThenPush cfg blk (readKeySets bstore) chlog -- It's OK to flush without a lock here, since the `LedgerDB` has not @@ -145,7 +149,7 @@ mkInitDb args bss getBlock = , ldbResolveBlock = getBlock } h <- LDBHandle <$> newTVarIO (LedgerDBOpen env) - pure $ implMkLedgerDb h + pure $ implMkLedgerDb h snapManager } where bsTracer = LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV1 >$< lgrTracer @@ -176,8 +180,9 @@ implMkLedgerDb :: , HasHardForkHistory blk ) => LedgerDBHandle m l blk -> + SnapshotManagerV1 m blk -> (LedgerDB' m blk, TestInternals' m blk) -implMkLedgerDb h = +implMkLedgerDb h snapManager = ( LedgerDB { getVolatileTip = getEnvSTM h implGetVolatileTip , getImmutableTip = getEnvSTM h implGetImmutableTip @@ -187,11 +192,11 @@ implMkLedgerDb h = , validateFork = getEnv5 h (implValidate h) , getPrevApplied = getEnvSTM h implGetPrevApplied , garbageCollect = getEnv1 h implGarbageCollect - , tryTakeSnapshot = getEnv2 h implTryTakeSnapshot + , tryTakeSnapshot = getEnv2 h (implTryTakeSnapshot snapManager) , tryFlush = getEnv h implTryFlush , closeDB = implCloseDB h } - , mkInternals h + , mkInternals h snapManager ) implGetVolatileTip :: @@ -310,28 +315,26 @@ implGarbageCollect env slotNo = atomically $ do implTryTakeSnapshot :: ( l ~ ExtLedgerState blk , IOLike m - , LedgerDbSerialiseConstraints blk - , LedgerSupportsProtocol blk ) => - LedgerDBEnv m l blk -> Maybe (Time, Time) -> Word64 -> m SnapCounters -implTryTakeSnapshot env mTime nrBlocks = + SnapshotManagerV1 m blk -> + LedgerDBEnv m l blk -> + Maybe (Time, Time) -> + Word64 -> + m SnapCounters +implTryTakeSnapshot snapManager env mTime nrBlocks = if onDiskShouldTakeSnapshot (ldbSnapshotPolicy env) (uncurry (flip diffTime) <$> mTime) nrBlocks then do void $ withReadLock (ldbLock env) ( takeSnapshot - (ldbChangelog env) - (configCodec . getExtLedgerCfg . ledgerDbCfg $ ldbCfg env) - (LedgerDBSnapshotEvent >$< ldbTracer env) - (ldbHasFS env) - (ldbBackingStore env) + snapManager Nothing + (ldbChangelog env, ldbBackingStore env) ) void $ trimSnapshots - (LedgerDBSnapshotEvent >$< ldbTracer env) - (snapshotsFs $ ldbHasFS env) + snapManager (ldbSnapshotPolicy env) (`SnapCounters` 0) . Just <$> maybe getMonotonicTime (pure . snd) mTime else @@ -376,15 +379,16 @@ mkInternals :: , ApplyBlock (ExtLedgerState blk) blk ) => LedgerDBHandle m (ExtLedgerState blk) blk -> + SnapshotManagerV1 m blk -> TestInternals' m blk -mkInternals h = +mkInternals h snapManager = TestInternals - { takeSnapshotNOW = getEnv2 h implIntTakeSnapshot + { takeSnapshotNOW = getEnv2 h (implIntTakeSnapshot snapManager) + , wipeLedgerDB = void $ destroySnapshots snapManager + , truncateSnapshots = getEnv h $ void . implIntTruncateSnapshots . ldbHasFS , push = getEnv1 h implIntPush , reapplyThenPushNOW = getEnv1 h implIntReapplyThenPush - , wipeLedgerDB = getEnv h $ void . destroySnapshots . snapshotsFs . ldbHasFS , closeLedgerDB = getEnv h $ void . release . ldbBackingStoreKey - , truncateSnapshots = getEnv h $ void . implIntTruncateSnapshots . ldbHasFS , getNumLedgerTablesHandles = pure 0 } @@ -412,8 +416,12 @@ implIntTakeSnapshot :: , LedgerSupportsProtocol blk , l ~ ExtLedgerState blk ) => - LedgerDBEnv m l blk -> WhereToTakeSnapshot -> Maybe String -> m () -implIntTakeSnapshot env whereTo suffix = do + SnapshotManagerV1 m blk -> + LedgerDBEnv m l blk -> + WhereToTakeSnapshot -> + Maybe String -> + m () +implIntTakeSnapshot snapManager env whereTo suffix = do when (whereTo == TakeAtVolatileTip) $ atomically $ modifyTVar (ldbChangelog env) pruneToImmTipOnly withWriteLock (ldbLock env) @@ -421,12 +429,9 @@ implIntTakeSnapshot env whereTo suffix = do void $ withReadLock (ldbLock env) $ takeSnapshot - (ldbChangelog env) - (configCodec . getExtLedgerCfg . ledgerDbCfg $ ldbCfg env) - (LedgerDBSnapshotEvent >$< ldbTracer env) - (ldbHasFS env) - (ldbBackingStore env) + snapManager suffix + (ldbChangelog env, ldbBackingStore env) implIntPush :: ( IOLike m diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs index 64f0840551..f4e27927b2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs @@ -129,12 +129,11 @@ -- -- ------------------------------------------------------------------------------ module Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots - ( loadSnapshot - , takeSnapshot + ( snapshotManager + , loadSnapshot - -- * Testing - , snapshotToStatePath - , snapshotToTablesPath + -- * snapshot-converter + , implTakeSnapshot ) where import Codec.CBOR.Encoding @@ -147,11 +146,14 @@ import Control.Tracer import Data.Functor.Contravariant ((>$<)) import qualified Data.List as List import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Storage.LedgerDB.API +import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent import Ouroboros.Consensus.Storage.LedgerDB.V1.Args import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 @@ -162,6 +164,35 @@ import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike import System.FS.API +snapshotManager :: + ( IOLike m + , LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + ) => + Complete LedgerDbArgs m blk -> + SnapshotManager m (ReadLocked m) blk (StrictTVar m (DbChangelog' blk), BackingStore' m blk) +snapshotManager args = + snapshotManager' + (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args) + (LedgerDBSnapshotEvent >$< lgrTracer args) + (SnapshotsFS (lgrHasFS args)) + +snapshotManager' :: + ( IOLike m + , LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + ) => + CodecConfig blk -> + Tracer m (TraceSnapshotEvent blk) -> + SnapshotsFS m -> + SnapshotManager m (ReadLocked m) blk (StrictTVar m (DbChangelog' blk), BackingStore' m blk) +snapshotManager' ccfg tracer sfs@(SnapshotsFS fs) = + SnapshotManager + { listSnapshots = defaultListSnapshots fs + , deleteSnapshot = defaultDeleteSnapshot fs tracer + , takeSnapshot = \suff (ldbVar, bs) -> implTakeSnapshot ldbVar ccfg tracer sfs bs suff + } + -- | Try to take a snapshot of the /oldest ledger state/ in the ledger DB -- -- We write the /oldest/ ledger state to disk because the intention is to only @@ -181,7 +212,7 @@ import System.FS.API -- whether this snapshot corresponds to a state that is more than @k@ back. -- -- TODO: Should we delete the file if an error occurs during writing? -takeSnapshot :: +implTakeSnapshot :: ( IOLike m , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk @@ -194,7 +225,7 @@ takeSnapshot :: -- | Override for snapshot numbering Maybe String -> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk)) -takeSnapshot ldbvar ccfg tracer (SnapshotsFS hasFS') backingStore suffix = readLocked $ do +implTakeSnapshot ldbvar ccfg tracer (SnapshotsFS hasFS) backingStore suffix = readLocked $ do state <- changelogLastFlushedState <$> readTVarIO ldbvar case pointToWithOriginRealPoint (castPoint (getTip state)) of Origin -> @@ -202,13 +233,13 @@ takeSnapshot ldbvar ccfg tracer (SnapshotsFS hasFS') backingStore suffix = readL NotOrigin t -> do let number = unSlotNo (realPointSlot t) snapshot = DiskSnapshot number suffix - diskSnapshots <- listSnapshots hasFS' + diskSnapshots <- defaultListSnapshots hasFS if List.any (== DiskSnapshot number suffix) diskSnapshots then return Nothing else do encloseTimedWith (TookSnapshot snapshot t >$< tracer) $ - writeSnapshot hasFS' backingStore (encodeDiskExtLedgerState ccfg) snapshot state + writeSnapshot hasFS backingStore (encodeDiskExtLedgerState ccfg) snapshot state return $ Just (snapshot, t) -- | Write snapshot to disk 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 e2b196d8af..dfd607077d 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 @@ -33,7 +33,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Traversable (for) import Data.Tuple (Solo (..)) -import Data.Void import Data.Word import GHC.Generics import NoThunks.Class @@ -57,6 +56,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 import Ouroboros.Consensus.Storage.LedgerDB.V2.Forker import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq +import Ouroboros.Consensus.Util (whenJust) import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike @@ -66,6 +66,8 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type import System.FS.API import Prelude hiding (read) +type SnapshotManagerV2 m blk = SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) + mkInitDb :: forall m blk. ( LedgerSupportsProtocol blk @@ -75,15 +77,19 @@ mkInitDb :: , LedgerSupportsInMemoryLedgerDB blk ) => Complete LedgerDbArgs m blk -> - Complete V2.LedgerDbFlavorArgs m -> + HandleEnv m -> ResolveBlock m blk -> + SnapshotManagerV2 m blk -> InitDB (LedgerSeq' m blk) m blk -mkInitDb args flavArgs getBlock = +mkInitDb args bss getBlock snapManager = InitDB { initFromGenesis = emptyF =<< lgrGenesis , initFromSnapshot = loadSnapshot (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig) lgrHasFS - , closeDb = closeLedgerSeq + , abortLedgerDbInit = \ls -> do + closeLedgerSeq ls + flip whenJust releaseLedgerDBResources $ case bss of + InMemoryHandleEnv -> Nothing , initReapplyBlock = \a b c -> do (x, y) <- reapplyThenPush lgrRegistry a b c x @@ -108,9 +114,11 @@ mkInitDb args flavArgs getBlock = , ldbResolveBlock = getBlock , ldbQueryBatchSize = lgrQueryBatchSize , ldbOpenHandlesLock = lock + , ldbResourceKeys = case bss of + InMemoryHandleEnv -> Nothing } h <- LDBHandle <$> newTVarIO (LedgerDBOpen env) - pure $ implMkLedgerDb h bss + pure $ implMkLedgerDb h snapManager } where LedgerDbArgs @@ -123,8 +131,6 @@ mkInitDb args flavArgs getBlock = , lgrRegistry } = args - bss = case flavArgs of V2Args bss0 -> bss0 - v2Tracer :: Tracer m V2.FlavorImplSpecificTrace v2Tracer = LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 >$< lgrTracer @@ -133,8 +139,7 @@ mkInitDb args flavArgs getBlock = m (LedgerSeq' m blk) emptyF st = empty' st $ case bss of - InMemoryHandleArgs -> InMemory.newInMemoryLedgerTablesHandle v2Tracer lgrHasFS - LSMHandleArgs x -> absurd x + InMemoryHandleEnv -> InMemory.newInMemoryLedgerTablesHandle v2Tracer lgrHasFS loadSnapshot :: CodecConfig blk -> @@ -142,8 +147,7 @@ mkInitDb args flavArgs getBlock = DiskSnapshot -> m (Either (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk)) loadSnapshot ccfg fs ds = case bss of - InMemoryHandleArgs -> runExceptT $ InMemory.loadSnapshot v2Tracer lgrRegistry ccfg fs ds - LSMHandleArgs x -> absurd x + InMemoryHandleEnv -> runExceptT $ InMemory.loadSnapshot v2Tracer lgrRegistry ccfg fs ds implMkLedgerDb :: forall m l blk. @@ -154,13 +158,12 @@ implMkLedgerDb :: , StandardHash l , HasLedgerTables l , LedgerSupportsProtocol blk - , LedgerDbSerialiseConstraints blk , HasHardForkHistory blk ) => LedgerDBHandle m l blk -> - HandleArgs -> + SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -> (LedgerDB m l blk, TestInternals m l blk) -implMkLedgerDb h bss = +implMkLedgerDb h snapManager = ( LedgerDB { getVolatileTip = getEnvSTM h implGetVolatileTip , getImmutableTip = getEnvSTM h implGetImmutableTip @@ -170,24 +173,23 @@ implMkLedgerDb h bss = , validateFork = getEnv5 h (implValidate h) , getPrevApplied = getEnvSTM h implGetPrevApplied , garbageCollect = \s -> getEnv h (flip implGarbageCollect s) - , tryTakeSnapshot = getEnv2 h (implTryTakeSnapshot bss) + , tryTakeSnapshot = getEnv2 h (implTryTakeSnapshot snapManager) , tryFlush = getEnv h implTryFlush , closeDB = implCloseDB h } - , mkInternals bss h + , mkInternals h snapManager ) mkInternals :: forall m blk. ( IOLike m - , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk , ApplyBlock (ExtLedgerState blk) blk ) => - HandleArgs -> LedgerDBHandle m (ExtLedgerState blk) blk -> + SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -> TestInternals' m blk -mkInternals bss h = +mkInternals h snapManager = TestInternals { takeSnapshotNOW = \whereTo suff -> getEnv h $ \env -> do let selectWhereTo = case whereTo of @@ -196,11 +198,11 @@ mkInternals bss h = withStateRef env (MkSolo . selectWhereTo) $ \(MkSolo (st, _)) -> Monad.void $ takeSnapshot - (configCodec . getExtLedgerCfg . ledgerDbCfg $ ldbCfg env) - (LedgerDBSnapshotEvent >$< ldbTracer env) - (ldbHasFS env) + snapManager suff st + , wipeLedgerDB = destroySnapshots snapManager + , truncateSnapshots = getEnv h $ implIntTruncateSnapshots snapManager . ldbHasFS , push = \st -> withRegistry $ \reg -> do eFrk <- newForkerAtTarget h reg VolatileTip case eFrk of @@ -223,48 +225,29 @@ mkInternals bss h = (st `withLedgerTables` tables) forkerPush frk st' >> atomically (forkerCommit frk) >> forkerClose frk pruneLedgerSeq env - , wipeLedgerDB = getEnv h $ destroySnapshots . ldbHasFS - , closeLedgerDB = + , closeLedgerDB = do let LDBHandle tvar = h - in atomically (writeTVar tvar LedgerDBClosed) - , truncateSnapshots = getEnv h $ implIntTruncateSnapshots . ldbHasFS + getEnv h $ \env -> + whenJust (ldbResourceKeys env) releaseLedgerDBResources + atomically (writeTVar tvar LedgerDBClosed) , getNumLedgerTablesHandles = getEnv h $ \env -> do l <- readTVarIO (ldbSeq env) -- We always have a state at the anchor. pure $ 1 + maxRollback l } where - takeSnapshot :: - CodecConfig blk -> - Tracer m (TraceSnapshotEvent blk) -> - SomeHasFS m -> - Maybe String -> - StateRef m (ExtLedgerState blk) -> - m (Maybe (DiskSnapshot, RealPoint blk)) - takeSnapshot = case bss of - InMemoryHandleArgs -> InMemory.takeSnapshot - LSMHandleArgs x -> absurd x - pruneLedgerSeq :: LedgerDBEnv m (ExtLedgerState blk) blk -> m () pruneLedgerSeq env = Monad.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 - snapshotsMapM_ sfs (truncateRecursively . (: [])) - where - truncateRecursively pre = do - dirs <- listDirectory fs (mkFsPath pre) - mapM_ - ( \d -> do - let d' = pre ++ [d] - isDir <- doesDirectoryExist fs $ mkFsPath d' - if isDir - then truncateRecursively d' - else withFile fs (mkFsPath d') (AppendMode AllowExisting) $ \h -> hTruncate fs h 0 - ) - dirs +-- | Testing only! Truncate all snapshots in the DB. We only truncate the state +-- file because it is unclear how to truncate the LSM database without +-- corrupting it. +implIntTruncateSnapshots :: MonadThrow m => SnapshotManager m m blk st -> SomeHasFS m -> m () +implIntTruncateSnapshots snapManager (SomeHasFS fs) = do + snapshotsMapM_ snapManager $ + \pre -> withFile fs (InMemory.snapshotToStatePath pre) (AppendMode AllowExisting) $ + \h -> hTruncate fs h 0 implGetVolatileTip :: (MonadSTM m, GetTip l) => @@ -366,48 +349,29 @@ implTryTakeSnapshot :: forall m l blk. ( l ~ ExtLedgerState blk , IOLike m - , LedgerSupportsProtocol blk - , LedgerDbSerialiseConstraints blk + , GetTip l ) => - HandleArgs -> + SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -> LedgerDBEnv m l blk -> Maybe (Time, Time) -> Word64 -> m SnapCounters -implTryTakeSnapshot bss env mTime nrBlocks = +implTryTakeSnapshot snapManager env mTime nrBlocks = if onDiskShouldTakeSnapshot (ldbSnapshotPolicy env) (uncurry (flip diffTime) <$> mTime) nrBlocks then do withStateRef env (MkSolo . anchorHandle) $ \(MkSolo (st, _)) -> Monad.void $ takeSnapshot - (configCodec . getExtLedgerCfg . ledgerDbCfg $ ldbCfg env) - (LedgerDBSnapshotEvent >$< ldbTracer env) - (ldbHasFS env) + snapManager + Nothing st Monad.void $ trimSnapshots - (LedgerDBSnapshotEvent >$< ldbTracer env) - (ldbHasFS env) + snapManager (ldbSnapshotPolicy env) (`SnapCounters` 0) . Just <$> maybe getMonotonicTime (pure . snd) mTime else pure $ SnapCounters (fst <$> mTime) nrBlocks - where - takeSnapshot :: - CodecConfig blk -> - Tracer m (TraceSnapshotEvent blk) -> - SomeHasFS m -> - StateRef m (ExtLedgerState blk) -> - m (Maybe (DiskSnapshot, RealPoint blk)) - takeSnapshot config trcr fs ref = case bss of - InMemoryHandleArgs -> - InMemory.takeSnapshot - config - trcr - fs - Nothing - ref - LSMHandleArgs x -> absurd x -- In the first version of the LedgerDB for UTxO-HD, there is a need to -- periodically flush the accumulated differences to the disk. However, in the @@ -417,14 +381,17 @@ implTryFlush :: Applicative m => LedgerDBEnv m l blk -> m () implTryFlush _ = pure () implCloseDB :: IOLike m => LedgerDBHandle m l blk -> m () -implCloseDB (LDBHandle varState) = - atomically $ - readTVar varState >>= \case - -- Idempotent - LedgerDBClosed -> pure () - LedgerDBOpen env -> do - writeTVar (ldbForkers env) Map.empty - writeTVar varState LedgerDBClosed +implCloseDB (LDBHandle varState) = do + res <- + atomically $ + readTVar varState >>= \case + -- Idempotent + LedgerDBClosed -> pure Nothing + LedgerDBOpen env -> do + writeTVar (ldbForkers env) Map.empty + writeTVar varState LedgerDBClosed + pure (ldbResourceKeys env) + whenJust res releaseLedgerDBResources {------------------------------------------------------------------------------- The LedgerDBEnv @@ -484,6 +451,10 @@ 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'. + , ldbResourceKeys :: !(Maybe (LedgerDBResourceKeys m)) + -- ^ Resource keys used in the LSM backend so that the closing function used + -- in tests can release such resources. These are the resource keys for the + -- LSM session and the resource key for the BlockIO interface. } deriving Generic @@ -497,6 +468,21 @@ deriving instance ) => NoThunks (LedgerDBEnv m l blk) +data LedgerDBResourceKeys m = LedgerDBResourceKeys + { sessionResourceKey :: ResourceKey m + , blockIOResourceKey :: ResourceKey m + } + deriving Generic + +deriving instance + IOLike m => + NoThunks (LedgerDBResourceKeys m) + +releaseLedgerDBResources :: IOLike m => LedgerDBResourceKeys m -> m () +releaseLedgerDBResources l = do + Monad.void . release . sessionResourceKey $ l + Monad.void . release . blockIOResourceKey $ l + {------------------------------------------------------------------------------- The LedgerDBHandle -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs index 1a6751f4d6..b065142210 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs @@ -23,9 +23,11 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory -- * Snapshots , loadSnapshot + , snapshotManager , snapshotToStatePath - , snapshotToTablePath - , takeSnapshot + + -- * snapshot-converter + , implTakeSnapshot ) where import Cardano.Binary as CBOR @@ -45,14 +47,18 @@ import Data.String (fromString) import GHC.Generics import NoThunks.Class import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended 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.Snapshots +import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq +import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CBOR (readIncremental) import Ouroboros.Consensus.Util.CRC import Ouroboros.Consensus.Util.Enclose @@ -152,14 +158,40 @@ newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do Snapshots -------------------------------------------------------------------------------} +snapshotManager :: + ( IOLike m + , LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + ) => + Complete LedgerDbArgs m blk -> + SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) +snapshotManager args = + snapshotManager' + (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args) + (LedgerDBSnapshotEvent >$< lgrTracer args) + (lgrHasFS args) + +snapshotManager' :: + ( IOLike m + , LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + ) => + CodecConfig blk -> + Tracer m (TraceSnapshotEvent blk) -> + SomeHasFS m -> + SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) +snapshotManager' ccfg tracer fs = + SnapshotManager + { listSnapshots = defaultListSnapshots fs + , deleteSnapshot = defaultDeleteSnapshot fs tracer + , takeSnapshot = implTakeSnapshot ccfg tracer fs + } + -- | The path within the LedgerDB's filesystem to the file that contains the -- snapshot's serialized ledger state snapshotToStatePath :: DiskSnapshot -> FsPath snapshotToStatePath = mkFsPath . (\x -> [x, "state"]) . snapshotToDirName -snapshotToTablePath :: DiskSnapshot -> FsPath -snapshotToTablePath = mkFsPath . (\x -> [x, "tables", "tvar"]) . snapshotToDirName - writeSnapshot :: MonadThrow m => SomeHasFS m -> @@ -174,10 +206,10 @@ writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do writeSnapshotMetadata fs ds $ SnapshotMetadata { snapshotBackend = UTxOHDMemSnapshot - , snapshotChecksum = crcOfConcat crc1 crc2 + , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2 } -takeSnapshot :: +implTakeSnapshot :: ( IOLike m , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk @@ -188,13 +220,13 @@ takeSnapshot :: Maybe String -> StateRef m (ExtLedgerState blk) -> m (Maybe (DiskSnapshot, RealPoint blk)) -takeSnapshot ccfg tracer hasFS suffix st = do +implTakeSnapshot ccfg tracer hasFS suffix st = do case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of Origin -> return Nothing NotOrigin t -> do let number = unSlotNo (realPointSlot t) snapshot = DiskSnapshot number suffix - diskSnapshots <- listSnapshots hasFS + diskSnapshots <- defaultListSnapshots hasFS if List.any (== DiskSnapshot number suffix) diskSnapshots then return Nothing 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 e4a3d2ca83..786951c7ea 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 @@ -48,6 +48,7 @@ import qualified Data.List as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.SOP.Dict as Dict +import Data.Void import Data.Word import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -63,11 +64,13 @@ import Ouroboros.Consensus.Storage.LedgerDB.V1 as V1 import Ouroboros.Consensus.Storage.LedgerDB.V1.Args hiding ( LedgerDbFlavorArgs ) +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1 import Ouroboros.Consensus.Storage.LedgerDB.V2 as V2 import Ouroboros.Consensus.Storage.LedgerDB.V2.Args hiding ( LedgerDbFlavorArgs ) import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory import Ouroboros.Consensus.Util hiding (Some) import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike @@ -506,19 +509,25 @@ openLedgerDB flavArgs env cfg fs = do Nothing (ldb, _, od) <- case flavArgs of LedgerDbFlavorArgsV1 bss -> - let initDb = + let snapManager = V1.snapshotManager args + initDb = V1.mkInitDb args bss getBlock - in openDBInternal args initDb stream replayGoal - LedgerDbFlavorArgsV2 bss -> + snapManager + in openDBInternal 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 openDBInternal args initDb stream replayGoal + snapManager + openDBInternal args initDb snapManager stream replayGoal withRegistry $ \reg -> do vr <- validateFork ldb reg (const $ pure ()) BlockCache.empty 0 (map getHeader volBlocks) case vr of