Skip to content

Commit 1db44ca

Browse files
jasagredojasagredo
committed
Snapshot manager
1 parent b1714e2 commit 1db44ca

File tree

13 files changed

+336
-273
lines changed

13 files changed

+336
-273
lines changed

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB
3838
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as V1
3939
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Lock as V1
4040
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
41+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
4142
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2
4243
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq as V2
4344
import Ouroboros.Consensus.Util.CRC
@@ -240,7 +241,7 @@ store config@Config{outpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS),
240241
Mem -> do
241242
lseq <- V2.empty state tbs $ V2.newInMemoryLedgerTablesHandle nullTracer fs
242243
let h = V2.currentHandle lseq
243-
Monad.void $ V2.takeSnapshot ccfg nullTracer fs suffix h
244+
Monad.void $ InMemory.implTakeSnapshot ccfg nullTracer fs suffix h
244245
LMDB -> do
245246
chlog <- newTVarIO (V1.empty state)
246247
lock <- V1.mkLedgerDBLock
@@ -252,7 +253,7 @@ store config@Config{outpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS),
252253
(V1.SnapshotsFS fs)
253254
(V1.InitFromValues (pointSlot $ getTip state) state tbs)
254255
Monad.void $ V1.withReadLock lock $ do
255-
V1.takeSnapshot chlog ccfg nullTracer (V1.SnapshotsFS fs) bs suffix
256+
V1.implTakeSnapshot chlog ccfg nullTracer (V1.SnapshotsFS fs) bs suffix
256257
store _ _ _ _ = error "Malformed output path!"
257258

258259
main :: IO ()

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

Lines changed: 10 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -37,13 +37,14 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
3737
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB
3838
import Ouroboros.Consensus.Storage.LedgerDB (TraceEvent (..))
3939
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
40-
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (defaultDeleteSnapshot)
4140
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as LedgerDB.V1
4241
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1
4342
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
43+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
4444
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2
4545
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB.V2
4646
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
47+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
4748
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
4849
import Ouroboros.Consensus.Util.Args
4950
import Ouroboros.Consensus.Util.IOLike
@@ -69,21 +70,23 @@ openLedgerDB ::
6970
, LedgerDB.TestInternals' IO blk
7071
)
7172
openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV1 bss} = do
73+
let snapManager = V1.snapshotManagement lgrDbArgs
7274
(ledgerDB, _, intLedgerDB) <-
7375
LedgerDB.openDBInternal
7476
lgrDbArgs
75-
defaultDeleteSnapshot
7677
( LedgerDB.V1.mkInitDb
7778
lgrDbArgs
7879
bss
7980
(\_ -> error "no replay")
81+
snapManager
8082
)
83+
snapManager
8184
emptyStream
8285
genesisPoint
8386
pure (ledgerDB, intLedgerDB)
8487
openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV2 args} = do
85-
(ds, bss') <- case args of
86-
V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv)
88+
(snapManager, bss') <- case args of
89+
V2.V2Args V2.InMemoryHandleArgs -> pure (InMemory.snapshotManagement lgrDbArgs, V2.InMemoryHandleEnv)
8790
V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do
8891
(rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (LedgerDB.lgrRegistry lgrDbArgs) "lsm"
8992
session <-
@@ -101,16 +104,17 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.L
101104
(mkFsPath [path])
102105
)
103106
LSM.closeSession
104-
pure (LSM.deleteSnapshot (snd session), V2.LSMHandleEnv session rk1)
107+
pure (LSM.snapshotManagement (snd session) lgrDbArgs, V2.LSMHandleEnv session rk1)
105108
(ledgerDB, _, intLedgerDB) <-
106109
LedgerDB.openDBInternal
107110
lgrDbArgs
108-
ds
109111
( LedgerDB.V2.mkInitDb
110112
lgrDbArgs
111113
bss'
112114
(\_ -> error "no replay")
115+
snapManager
113116
)
117+
snapManager
114118
emptyStream
115119
genesisPoint
116120
pure (ledgerDB, intLedgerDB)

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

Lines changed: 18 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -31,8 +31,10 @@ import Ouroboros.Consensus.Storage.LedgerDB.Forker
3131
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
3232
import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
3333
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as V1
34+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
3435
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as V2
3536
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
37+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
3638
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
3739
import Ouroboros.Consensus.Util.Args
3840
import Ouroboros.Consensus.Util.CallStack
@@ -68,15 +70,17 @@ openDB
6870
replayGoal
6971
getBlock = case lgrFlavorArgs args of
7072
LedgerDbFlavorArgsV1 bss ->
71-
let initDb =
73+
let snapManager = V1.snapshotManagement args
74+
initDb =
7275
V1.mkInitDb
7376
args
7477
bss
7578
getBlock
76-
in doOpenDB args defaultDeleteSnapshot initDb stream replayGoal
79+
snapManager
80+
in doOpenDB args initDb snapManager stream replayGoal
7781
LedgerDbFlavorArgsV2 bss -> do
78-
(ds, bss') <- case bss of
79-
V2.V2Args V2.InMemoryHandleArgs -> pure (defaultDeleteSnapshot, V2.InMemoryHandleEnv)
82+
(snapManager, bss') <- case bss of
83+
V2.V2Args V2.InMemoryHandleArgs -> pure (InMemory.snapshotManagement args, V2.InMemoryHandleEnv)
8084
V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path genSalt mkFS)) -> do
8185
(rk1, V2.SomeHasFSAndBlockIO fs blockio) <- mkFS (lgrRegistry args) "lsm"
8286
session <-
@@ -92,33 +96,34 @@ openDB
9296
(mkFsPath [path])
9397
)
9498
LSM.closeSession
95-
pure (LSM.deleteSnapshot (snd session), V2.LSMHandleEnv session rk1)
99+
pure (LSM.snapshotManagement (snd session) args, V2.LSMHandleEnv session rk1)
96100
let initDb =
97101
V2.mkInitDb
98102
args
99103
bss'
100104
getBlock
101-
doOpenDB args ds initDb stream replayGoal
105+
snapManager
106+
doOpenDB args initDb snapManager stream replayGoal
102107

103108
{-------------------------------------------------------------------------------
104109
Opening a LedgerDB
105110
-------------------------------------------------------------------------------}
106111

107112
doOpenDB ::
108-
forall m blk db.
113+
forall m n blk db st.
109114
( IOLike m
110115
, LedgerSupportsProtocol blk
111116
, InspectLedger blk
112117
, HasCallStack
113118
) =>
114119
Complete LedgerDbArgs m blk ->
115-
(SomeHasFS m -> DiskSnapshot -> m ()) ->
116120
InitDB db m blk ->
121+
SnapshotManagement m n blk st ->
117122
StreamAPI m blk blk ->
118123
Point blk ->
119124
m (LedgerDB' m blk, Word64)
120-
doOpenDB args deleteSnapshot initDb stream replayGoal =
121-
f <$> openDBInternal args deleteSnapshot initDb stream replayGoal
125+
doOpenDB args initDb snapManager stream replayGoal =
126+
f <$> openDBInternal args initDb snapManager stream replayGoal
122127
where
123128
f (ldb, replayCounter, _) = (ldb, replayCounter)
124129

@@ -130,31 +135,29 @@ openDBInternal ::
130135
, HasCallStack
131136
) =>
132137
Complete LedgerDbArgs m blk ->
133-
(SomeHasFS m -> DiskSnapshot -> m ()) ->
134138
InitDB db m blk ->
139+
SnapshotManagement m n blk st ->
135140
StreamAPI m blk blk ->
136141
Point blk ->
137142
m (LedgerDB' m blk, Word64, TestInternals' m blk)
138-
openDBInternal args@(LedgerDbArgs{lgrHasFS = SomeHasFS fs}) deleteSnapshot initDb stream replayGoal = do
143+
openDBInternal args@(LedgerDbArgs{lgrHasFS = SomeHasFS fs}) initDb snapManager stream replayGoal = do
139144
createDirectoryIfMissing fs True (mkFsPath [])
140145
(_initLog, db, replayCounter) <-
141146
initialize
142147
replayTracer
143148
snapTracer
144-
lgrHasFS
145149
lgrConfig
146150
stream
147151
replayGoal
148152
initDb
153+
snapManager
149154
lgrStartSnapshot
150-
deleteSnapshot
151155
(ledgerDb, internal) <- mkLedgerDb initDb db
152156
return (ledgerDb, replayCounter, internal)
153157
where
154158
LedgerDbArgs
155159
{ lgrConfig
156160
, lgrTracer
157-
, lgrHasFS
158161
, lgrStartSnapshot
159162
} = args
160163

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

Lines changed: 35 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -119,6 +119,8 @@ module Ouroboros.Consensus.Storage.LedgerDB.API
119119
, LedgerSupportsLedgerDB
120120
, LedgerSupportsLMDBLedgerDB
121121
, LedgerSupportsLSMLedgerDB
122+
, LedgerSupportsV1LedgerDB
123+
, LedgerSupportsV2LedgerDB
122124
, LSMTxOut
123125
, HasLSMTxOut (..)
124126
, ResolveBlock
@@ -197,7 +199,6 @@ import Ouroboros.Consensus.Util.IOLike
197199
import Ouroboros.Consensus.Util.IndexedMemPack
198200
import Ouroboros.Network.Block
199201
import Ouroboros.Network.Protocol.LocalStateQuery.Type
200-
import System.FS.API
201202

202203
{-------------------------------------------------------------------------------
203204
Main API
@@ -299,15 +300,15 @@ currentPoint ldb = castPoint . getTip <$> getVolatileTip ldb
299300
data WhereToTakeSnapshot = TakeAtImmutableTip | TakeAtVolatileTip deriving Eq
300301

301302
data TestInternals m l blk = TestInternals
302-
{ wipeLedgerDB :: m ()
303-
, takeSnapshotNOW :: WhereToTakeSnapshot -> Maybe String -> m ()
304-
, push :: ExtLedgerState blk DiffMK -> m ()
303+
{ push :: ExtLedgerState blk DiffMK -> m ()
305304
, reapplyThenPushNOW :: blk -> m ()
306-
, truncateSnapshots :: m ()
307305
, closeLedgerDB :: m ()
308306
, getNumLedgerTablesHandles :: m Word64
309307
-- ^ Get the number of referenced 'LedgerTablesHandle's for V2. For V1, this
310308
-- always returns 0.
309+
, takeSnapshotNOW :: WhereToTakeSnapshot -> Maybe String -> m ()
310+
, truncateSnapshots :: m ()
311+
, wipeLedgerDB :: m ()
311312
}
312313
deriving NoThunks via OnlyCheckWhnfNamed "TestInternals" (TestInternals m l blk)
313314

@@ -492,34 +493,32 @@ data InitDB db m blk = InitDB
492493
-- obtained in this way will (hopefully) share much of their memory footprint
493494
-- with their predecessors.
494495
initialize ::
495-
forall m blk db.
496+
forall m n blk db st.
496497
( IOLike m
497498
, LedgerSupportsProtocol blk
498499
, InspectLedger blk
499500
, HasCallStack
500501
) =>
501502
Tracer m (TraceReplayEvent blk) ->
502503
Tracer m (TraceSnapshotEvent blk) ->
503-
SomeHasFS m ->
504504
LedgerDbCfg (ExtLedgerState blk) ->
505505
StreamAPI m blk blk ->
506506
Point blk ->
507507
InitDB db m blk ->
508+
SnapshotManagement m n blk st ->
508509
Maybe DiskSnapshot ->
509-
(SomeHasFS m -> DiskSnapshot -> m ()) ->
510510
m (InitLog blk, db, Word64)
511511
initialize
512512
replayTracer
513513
snapTracer
514-
hasFS
515514
cfg
516515
stream
517516
replayGoal
518517
dbIface
519-
fromSnapshot
520-
deleteSnapshot =
518+
snapManager
519+
fromSnapshot =
521520
case fromSnapshot of
522-
Nothing -> listSnapshots hasFS >>= tryNewestFirst id
521+
Nothing -> listSnapshots snapManager >>= tryNewestFirst id
523522
Just snap -> tryNewestFirst id [snap]
524523
where
525524
InitDB{initFromGenesis, initFromSnapshot, closeDb} = dbIface
@@ -579,15 +578,15 @@ initialize
579578
traceWith snapTracer $ InvalidSnapshot s err
580579
Monad.when (diskSnapshotIsTemporary s) $ do
581580
traceWith snapTracer $ DeletedSnapshot s
582-
deleteSnapshot hasFS s
581+
deleteSnapshot snapManager s
583582
tryNewestFirst (acc . InitFailure s err) ss
584583

585584
-- If we fail to use this snapshot for any other reason, delete it and
586585
-- try an older one
587586
Left err -> do
588587
Monad.when (diskSnapshotIsTemporary s || err == InitFailureGenesis) $ do
589588
traceWith snapTracer $ DeletedSnapshot s
590-
deleteSnapshot hasFS s
589+
deleteSnapshot snapManager s
591590
traceWith snapTracer . InvalidSnapshot s $ err
592591
tryNewestFirst (acc . InitFailure s err) ss
593592
Right (initDb, pt) -> do
@@ -606,7 +605,7 @@ initialize
606605
case eDB of
607606
Left err -> do
608607
traceWith snapTracer . InvalidSnapshot s $ err
609-
Monad.when (diskSnapshotIsTemporary s) $ deleteSnapshot hasFS s
608+
Monad.when (diskSnapshotIsTemporary s) $ deleteSnapshot snapManager s
610609
closeDb initDb
611610
tryNewestFirst (acc . InitFailure s err) ss
612611
Right (db, replayed) -> do
@@ -729,7 +728,11 @@ data TraceReplayProgressEvent blk
729728
Updating ledger tables
730729
-------------------------------------------------------------------------------}
731730

732-
type LedgerSupportsInMemoryLedgerDB blk = (CanUpgradeLedgerTables (LedgerState blk))
731+
type LedgerSupportsInMemoryLedgerDB l =
732+
(CanUpgradeLedgerTables l, SerializeTablesWithHint l)
733+
734+
type LedgerSupportsV1LedgerDB l =
735+
(LedgerSupportsInMemoryLedgerDB l, LedgerSupportsLMDBLedgerDB l)
733736

734737
-- | When pushing differences on InMemory Ledger DBs, we will sometimes need to
735738
-- update ledger tables to the latest era. For unary blocks this is a no-op, but
@@ -768,16 +771,19 @@ instance
768771
Supporting On-Disk backing stores
769772
-------------------------------------------------------------------------------}
770773

771-
type LedgerSupportsLMDBLedgerDB blk =
772-
(IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk)))
774+
type LedgerSupportsLMDBLedgerDB l =
775+
(IndexedMemPack (l EmptyMK) (TxOut l), MemPackIdx l EmptyMK ~ l EmptyMK)
773776

774-
type LedgerSupportsLSMLedgerDB blk =
775-
( LSM.SerialiseKey (TxIn (LedgerState blk))
776-
, LSM.SerialiseValue (LSMTxOut (LedgerState blk))
777-
, LSM.ResolveValue (LSMTxOut (LedgerState blk))
778-
, HasLSMTxOut (LedgerState blk)
777+
type LedgerSupportsLSMLedgerDB l =
778+
( LSM.SerialiseKey (TxIn l)
779+
, LSM.SerialiseValue (LSMTxOut l)
780+
, LSM.ResolveValue (LSMTxOut l)
781+
, HasLSMTxOut l
779782
)
780783

784+
type LedgerSupportsV2LedgerDB l =
785+
(LedgerSupportsInMemoryLedgerDB l, LedgerSupportsLSMLedgerDB l)
786+
781787
-- | LSM trees need to be able to serialize and deserialize values several
782788
-- times, without any context. Therefore the approach of using a ledger state to
783789
-- hint the era in which values need to be deserialized cannot work with LSM.
@@ -793,10 +799,12 @@ class HasLSMTxOut l where
793799
toLSMTxOut :: Proxy l -> TxOut l -> LSMTxOut l
794800
fromLSMTxOut :: l EmptyMK -> LSMTxOut l -> TxOut l
795801

796-
type LedgerSupportsLedgerDB blk =
797-
( LedgerSupportsLMDBLedgerDB blk
798-
, LedgerSupportsInMemoryLedgerDB blk
799-
, LedgerSupportsLSMLedgerDB blk
802+
type LedgerSupportsLedgerDB blk = LedgerSupportsLedgerDB' (LedgerState blk) blk
803+
804+
type LedgerSupportsLedgerDB' l blk =
805+
( LedgerSupportsLMDBLedgerDB l
806+
, LedgerSupportsInMemoryLedgerDB l
807+
, LedgerSupportsLSMLedgerDB l
800808
, LedgerDbSerialiseConstraints blk
801809
)
802810

0 commit comments

Comments
 (0)