Skip to content

Commit 0427df1

Browse files
jasagredojasagredo
committed
Implement non-native snapshots
1 parent 6108d83 commit 0427df1

File tree

15 files changed

+253
-42
lines changed

15 files changed

+253
-42
lines changed

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -365,7 +365,7 @@ main = withStdTerminalHandles $ do
365365
InEnv
366366
st
367367
fp
368-
(\a b -> SomeBackend <$> mkInMemYieldArgs (fp F.</> "tables" F.</> "tvar") a b)
368+
(\a b -> SomeBackend <$> mkInMemYieldArgs (fp F.</> "tables") a b)
369369
("InMemory@[" <> fp <> "]")
370370
c
371371
mtd
@@ -423,7 +423,7 @@ main = withStdTerminalHandles $ do
423423
pure $
424424
OutEnv
425425
fp
426-
(\a b -> SomeBackend <$> mkInMemSinkArgs (fp F.</> "tables" F.</> "tvar") a b)
426+
(\a b -> SomeBackend <$> mkInMemSinkArgs (fp F.</> "tables") a b)
427427
(Just "tables")
428428
(Nothing)
429429
("InMemory@[" <> fp <> "]")

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

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -75,7 +75,7 @@ openLedgerDB ::
7575
openLedgerDB args = do
7676
(ldb, _, od) <- case LedgerDB.lgrBackendArgs args of
7777
LedgerDB.LedgerDbBackendArgsV1 bss ->
78-
let snapManager = LedgerDB.V1.snapshotManager args
78+
let snapManager = LedgerDB.V1.snapshotManager args bss
7979
initDb =
8080
LedgerDB.V1.mkInitDb
8181
args
@@ -99,6 +99,11 @@ openLedgerDB args = do
9999
(configCodec . getExtLedgerCfg . LedgerDB.ledgerDbCfg $ LedgerDB.lgrConfig args)
100100
(LedgerDBSnapshotEvent >$< LedgerDB.lgrTracer args)
101101
(LedgerDB.lgrHasFS args)
102+
( flip
103+
LedgerDB.V2.NonNativeSnapshotsFS
104+
(LedgerDB.lgrHasFS args)
105+
<$> LedgerDB.lgrNonNativeSnapshotsFS args
106+
)
102107
let initDb =
103108
LedgerDB.V2.mkInitDb
104109
args

‎ouroboros-consensus/src/ouroboros-consensus-lmdb/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -850,6 +850,7 @@ mkLMDBArgs ::
850850
( MonadIOPrim m
851851
, HasLedgerTables (LedgerState blk)
852852
, IOLike m
853+
, IsLedger (LedgerState blk)
853854
) =>
854855
V1.FlushFrequency -> FilePath -> LMDBLimits -> a -> (LedgerDbBackendArgs m blk, a)
855856
mkLMDBArgs flushing lmdbPath limits =
@@ -998,3 +999,6 @@ mkLMDBSinkArgs fp limits hint reg = do
998999
)
9991000
bsClose
10001001
pure $ SinkLMDB 1000 (bsWrite bs) (\h -> bsCopy bs h (FS.mkFsPath [snapName, "tables"]))
1002+
1003+
instance (Ord (TxIn l), GetTip l, Monad m) => StreamingBackendV1 m LMDB l where
1004+
yieldV1 _ vh = yield (Proxy @LMDB) (YieldLMDB 1000 vh)

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

Lines changed: 34 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -75,17 +75,19 @@ import Ouroboros.Consensus.Storage.LedgerDB.Args
7575
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
7676
import Ouroboros.Consensus.Storage.LedgerDB.V2
7777
import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend
78+
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
7879
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
7980
import Ouroboros.Consensus.Util (chunks)
8081
import Ouroboros.Consensus.Util.CRC
8182
import Ouroboros.Consensus.Util.Enclose
82-
import Ouroboros.Consensus.Util.IOLike
83+
import Ouroboros.Consensus.Util.IOLike hiding (yield)
8384
import Ouroboros.Consensus.Util.IndexedMemPack
8485
import qualified Streaming as S
8586
import qualified Streaming.Prelude as S
8687
import System.FS.API
8788
import qualified System.FS.BlockIO.API as BIO
8889
import System.FS.BlockIO.IO
90+
import System.FS.CRC
8991
import System.FilePath (splitDirectories, splitFileName)
9092
import System.Random
9193
import Prelude hiding (read)
@@ -199,12 +201,13 @@ snapshotManager ::
199201
CodecConfig blk ->
200202
Tracer m (TraceSnapshotEvent blk) ->
201203
SomeHasFS m ->
204+
Maybe (NonNativeSnapshotsFS m) ->
202205
SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
203-
snapshotManager session ccfg tracer fs =
206+
snapshotManager session ccfg tracer fs mNonNative =
204207
SnapshotManager
205208
{ listSnapshots = defaultListSnapshots fs
206209
, deleteSnapshot = implDeleteSnapshot session fs tracer
207-
, takeSnapshot = implTakeSnapshot ccfg tracer fs
210+
, takeSnapshot = implTakeSnapshot ccfg tracer fs mNonNative
208211
}
209212

210213
newLSMLedgerTablesHandle ::
@@ -330,30 +333,43 @@ implTakeSnapshot ::
330333
CodecConfig blk ->
331334
Tracer m (TraceSnapshotEvent blk) ->
332335
SomeHasFS m ->
336+
Maybe (NonNativeSnapshotsFS m) ->
333337
Maybe String ->
334338
StateRef m (ExtLedgerState blk) ->
335339
m (Maybe (DiskSnapshot, RealPoint blk))
336-
implTakeSnapshot ccfg tracer hasFS suffix st = case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of
337-
Origin -> return Nothing
338-
NotOrigin t -> do
339-
let number = unSlotNo (realPointSlot t)
340-
snapshot = DiskSnapshot number suffix
341-
diskSnapshots <- defaultListSnapshots hasFS
342-
if List.any (== DiskSnapshot number suffix) diskSnapshots
343-
then
344-
return Nothing
345-
else do
346-
encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
347-
writeSnapshot hasFS (encodeDiskExtLedgerState ccfg) snapshot st
348-
return $ Just (snapshot, t)
340+
implTakeSnapshot ccfg tracer shfs mNonNativeFS suffix st =
341+
case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of
342+
Origin -> return Nothing
343+
NotOrigin t -> do
344+
let number = unSlotNo (realPointSlot t)
345+
snapshot = DiskSnapshot number suffix
346+
diskSnapshots <- defaultListSnapshots shfs
347+
if List.any (== DiskSnapshot number suffix) diskSnapshots
348+
then
349+
return Nothing
350+
else do
351+
stateCRC <-
352+
encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
353+
writeSnapshot shfs (encodeDiskExtLedgerState ccfg) snapshot st
354+
takeNonNativeSnapshot
355+
(($ t) >$< tracer)
356+
snapshot
357+
(duplicate (tables st))
358+
close
359+
(\hdl -> yield (Proxy @LSM) (YieldLSM 1000 hdl) (state st))
360+
(state st)
361+
stateCRC
362+
mNonNativeFS
363+
364+
return $ Just (snapshot, t)
349365

350366
writeSnapshot ::
351367
MonadThrow m =>
352368
SomeHasFS m ->
353369
(ExtLedgerState blk EmptyMK -> Encoding) ->
354370
DiskSnapshot ->
355371
StateRef m (ExtLedgerState blk) ->
356-
m ()
372+
m CRC
357373
writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
358374
createDirectoryIfMissing hasFs True $ snapshotToDirPath ds
359375
crc1 <- writeExtLedgerState fs encLedger (snapshotToStatePath ds) $ state st
@@ -364,6 +380,7 @@ writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
364380
, snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2
365381
, snapshotTablesCodecVersion = TablesCodecVersion1
366382
}
383+
pure crc1
367384

368385
-- | Delete snapshot from disk and also from the LSM tree database.
369386
implDeleteSnapshot ::

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

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,10 @@ openDB
7070
getVolatileSuffix =
7171
case lgrBackendArgs args of
7272
LedgerDbBackendArgsV1 bss ->
73-
let snapManager = V1.snapshotManager args
73+
let snapManager =
74+
V1.snapshotManager
75+
args
76+
bss
7477
initDb =
7578
V1.mkInitDb
7679
args
@@ -94,6 +97,7 @@ openDB
9497
(configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args)
9598
(LedgerDBSnapshotEvent >$< lgrTracer args)
9699
(lgrHasFS args)
100+
(flip NonNativeSnapshotsFS (lgrHasFS args) <$> lgrNonNativeSnapshotsFS args)
97101
let initDb = V2.mkInitDb args getBlock snapManager getVolatileSuffix res
98102
doOpenDB args initDb snapManager stream replayGoal
99103

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -60,6 +60,8 @@ data LedgerDbArgs f m blk = LedgerDbArgs
6060
, lgrTracer :: Tracer m (TraceEvent blk)
6161
, lgrBackendArgs :: LedgerDbBackendArgs m blk
6262
, lgrRegistry :: HKD f (ResourceRegistry m)
63+
, lgrNonNativeSnapshotsFS :: Maybe (SomeHasFS m)
64+
-- ^ If Just, enable non-native snapshots.
6365
, lgrQueryBatchSize :: QueryBatchSize
6466
, lgrStartSnapshot :: Maybe DiskSnapshot
6567
-- ^ If provided, the ledgerdb will start using said snapshot and fallback
@@ -85,6 +87,7 @@ defaultArgs backendArgs =
8587
lgrBackendArgs = LedgerDbBackendArgsV2 backendArgs
8688
, lgrRegistry = NoDefault
8789
, lgrStartSnapshot = Nothing
90+
, lgrNonNativeSnapshotsFS = Nothing
8891
}
8992

9093
data LedgerDbBackendArgs m blk

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -607,6 +607,8 @@ data TraceSnapshotEvent blk
607607
InvalidSnapshot DiskSnapshot (SnapshotFailure blk)
608608
| -- | A snapshot was written to disk.
609609
TookSnapshot DiskSnapshot (RealPoint blk) EnclosingTimed
610+
| -- | A non-native snapshot was written to disk.
611+
TookNonNativeSnapshot DiskSnapshot (RealPoint blk) EnclosingTimed
610612
| -- | An old or invalid on-disk snapshot was deleted
611613
DeletedSnapshot DiskSnapshot
612614
deriving (Generic, Eq, Show)

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

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore
2222
-- * Initialization
2323
, newBackingStore
2424
, restoreBackingStore
25+
, StreamingBackendV1 (..)
2526

2627
-- * Tracing
2728
, SomeBackendTrace (..)
@@ -33,6 +34,7 @@ import Cardano.Slotting.Slot
3334
import Control.Tracer
3435
import Data.Proxy
3536
import Ouroboros.Consensus.Ledger.Basics
37+
import Ouroboros.Consensus.Storage.LedgerDB.API
3638
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
3739
import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API
3840
import System.FS.API
@@ -64,7 +66,8 @@ newBackingStore trcr (SomeBackendArgs bArgs) fs st tables =
6466
newBackingStoreInitialiser trcr bArgs fs (InitFromValues Origin st tables)
6567

6668
data SomeBackendArgs m l where
67-
SomeBackendArgs :: Backend m backend l => Args m backend -> SomeBackendArgs m l
69+
SomeBackendArgs ::
70+
(StreamingBackendV1 m backend l, Backend m backend l) => Args m backend -> SomeBackendArgs m l
6871

6972
data SomeBackendTrace where
7073
SomeBackendTrace :: Show (Trace m backend) => Trace m backend -> SomeBackendTrace
@@ -88,3 +91,7 @@ class Backend m backend l where
8891
Args m backend ->
8992
SnapshotsFS m ->
9093
BackingStoreInitialiser m l
94+
95+
-- | A refinement of 'StreamingBackend' that produces a 'Yield' from a 'BackingStoreValueHandle'.
96+
class StreamingBackend m backend l => StreamingBackendV1 m backend l where
97+
yieldV1 :: Proxy backend -> LedgerBackingStoreValueHandle m l -> Yield m l

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ import Data.Functor.Contravariant
3535
import qualified Data.Map.Strict as Map
3636
import qualified Data.Set as Set
3737
import Data.String (fromString)
38+
import Data.Void
3839
import GHC.Generics
3940
import Ouroboros.Consensus.Ledger.Basics
4041
import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
@@ -370,3 +371,12 @@ instance
370371
newBackingStoreInitialiser trcr InMemArgs =
371372
newInMemoryBackingStore
372373
(SomeBackendTrace . InMemoryBackingStoreTrace >$< trcr)
374+
375+
instance StreamingBackend m Mem l where
376+
data SinkArgs m Mem l = SinkArgs Void
377+
data YieldArgs m Mem l = YieldArgs Void
378+
yield _ (YieldArgs x) = absurd x
379+
sink _ (SinkArgs x) = absurd x
380+
381+
instance StreamingBackendV1 m Mem l where
382+
yieldV1 _ _ = error "We do not support streaming non-native snapshots from a V1 InMemory backend"

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

Lines changed: 31 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -155,42 +155,51 @@ import Ouroboros.Consensus.Storage.LedgerDB.API
155155
import Ouroboros.Consensus.Storage.LedgerDB.Args
156156
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
157157
import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
158+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
158159
import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore
159160
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1
160161
import Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
161162
import Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
163+
import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend (NonNativeSnapshotsFS (..))
164+
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory hiding (Args, snapshotManager)
162165
import Ouroboros.Consensus.Util.Args (Complete)
163166
import Ouroboros.Consensus.Util.Enclose
164-
import Ouroboros.Consensus.Util.IOLike
167+
import Ouroboros.Consensus.Util.IOLike hiding (yield)
165168
import System.FS.API
169+
import System.FS.CRC
166170

167171
snapshotManager ::
168172
( IOLike m
169173
, LedgerDbSerialiseConstraints blk
170174
, LedgerSupportsProtocol blk
171175
) =>
172176
Complete LedgerDbArgs m blk ->
177+
V1.LedgerDbBackendArgs m (ExtLedgerState blk) ->
173178
SnapshotManager m (ReadLocked m) blk (StrictTVar m (DbChangelog' blk), BackingStore' m blk)
174-
snapshotManager args =
179+
snapshotManager args p =
175180
snapshotManager'
181+
p
176182
(configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args)
177183
(LedgerDBSnapshotEvent >$< lgrTracer args)
178184
(SnapshotsFS (lgrHasFS args))
185+
(flip NonNativeSnapshotsFS (lgrHasFS args) <$> lgrNonNativeSnapshotsFS args)
179186

180187
snapshotManager' ::
181188
( IOLike m
182189
, LedgerDbSerialiseConstraints blk
183190
, LedgerSupportsProtocol blk
184191
) =>
192+
V1.LedgerDbBackendArgs m (ExtLedgerState blk) ->
185193
CodecConfig blk ->
186194
Tracer m (TraceSnapshotEvent blk) ->
187195
SnapshotsFS m ->
196+
Maybe (NonNativeSnapshotsFS m) ->
188197
SnapshotManager m (ReadLocked m) blk (StrictTVar m (DbChangelog' blk), BackingStore' m blk)
189-
snapshotManager' ccfg tracer sfs@(SnapshotsFS fs) =
198+
snapshotManager' p ccfg tracer sfs@(SnapshotsFS fs) mNNFS =
190199
SnapshotManager
191200
{ listSnapshots = defaultListSnapshots fs
192201
, deleteSnapshot = defaultDeleteSnapshot fs tracer
193-
, takeSnapshot = \suff (ldbVar, bs) -> implTakeSnapshot ldbVar ccfg tracer sfs bs suff
202+
, takeSnapshot = \suff (ldbVar, bs) -> implTakeSnapshot p ldbVar ccfg tracer sfs mNNFS bs suff
194203
}
195204

196205
-- | Try to take a snapshot of the /oldest ledger state/ in the ledger DB
@@ -213,19 +222,22 @@ snapshotManager' ccfg tracer sfs@(SnapshotsFS fs) =
213222
--
214223
-- TODO: Should we delete the file if an error occurs during writing?
215224
implTakeSnapshot ::
225+
forall m blk.
216226
( IOLike m
217227
, LedgerDbSerialiseConstraints blk
218228
, LedgerSupportsProtocol blk
219229
) =>
230+
V1.LedgerDbBackendArgs m (ExtLedgerState blk) ->
220231
StrictTVar m (DbChangelog' blk) ->
221232
CodecConfig blk ->
222233
Tracer m (TraceSnapshotEvent blk) ->
223234
SnapshotsFS m ->
235+
Maybe (NonNativeSnapshotsFS m) ->
224236
BackingStore' m blk ->
225237
-- | Override for snapshot numbering
226238
Maybe String ->
227239
ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
228-
implTakeSnapshot ldbvar ccfg tracer (SnapshotsFS hasFS) backingStore suffix = readLocked $ do
240+
implTakeSnapshot (V1.V1Args _ (V1.SomeBackendArgs (_ :: V1.Args m backend))) ldbvar ccfg tracer (SnapshotsFS hasFS) mNonNativeFS backingStore suffix = readLocked $ do
229241
state <- changelogLastFlushedState <$> readTVarIO ldbvar
230242
case pointToWithOriginRealPoint (castPoint (getTip state)) of
231243
Origin ->
@@ -238,8 +250,18 @@ implTakeSnapshot ldbvar ccfg tracer (SnapshotsFS hasFS) backingStore suffix = re
238250
then
239251
return Nothing
240252
else do
241-
encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
242-
writeSnapshot hasFS backingStore (encodeDiskExtLedgerState ccfg) snapshot state
253+
stateCRC <-
254+
encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
255+
writeSnapshot hasFS backingStore (encodeDiskExtLedgerState ccfg) snapshot state
256+
takeNonNativeSnapshot
257+
(($ t) >$< tracer)
258+
snapshot
259+
(bsValueHandle backingStore)
260+
bsvhClose
261+
(\vh -> yieldV1 (Proxy @backend) vh state)
262+
state
263+
stateCRC
264+
mNonNativeFS
243265
return $ Just (snapshot, t)
244266

245267
-- | Write snapshot to disk
@@ -250,7 +272,7 @@ writeSnapshot ::
250272
(ExtLedgerState blk EmptyMK -> Encoding) ->
251273
DiskSnapshot ->
252274
ExtLedgerState blk EmptyMK ->
253-
m ()
275+
m CRC
254276
writeSnapshot fs@(SomeHasFS hasFS) backingStore encLedger snapshot cs = do
255277
createDirectory hasFS (snapshotToDirPath snapshot)
256278
crc <- writeExtLedgerState fs encLedger (snapshotToStatePath snapshot) cs
@@ -266,6 +288,7 @@ writeSnapshot fs@(SomeHasFS hasFS) backingStore encLedger snapshot cs = do
266288
backingStore
267289
cs
268290
(snapshotToTablesPath snapshot)
291+
pure crc
269292

270293
-- | The path within the LedgerDB's filesystem to the file that contains the
271294
-- snapshot's serialized ledger state

0 commit comments

Comments
 (0)