Skip to content

Commit cafdd04

Browse files
jasagredojasagredo
committed
Implement non-native snapshots
1 parent 0a5150b commit cafdd04

File tree

14 files changed

+249
-38
lines changed

14 files changed

+249
-38
lines changed

‎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
@@ -98,6 +98,11 @@ openLedgerDB args = do
9898
(configCodec . getExtLedgerCfg . LedgerDB.ledgerDbCfg $ LedgerDB.lgrConfig args)
9999
(LedgerDBSnapshotEvent >$< LedgerDB.lgrTracer args)
100100
(LedgerDB.lgrHasFS args)
101+
( flip
102+
LedgerDB.V2.NonNativeSnapshotsFS
103+
(LedgerDB.lgrHasFS args)
104+
<$> LedgerDB.lgrNonNativeSnapshotsFS args
105+
)
101106
let initDb = LedgerDB.V2.mkInitDb args (\_ -> pure (error "no stream")) snapManager res
102107
LedgerDB.openDBInternal args initDb snapManager emptyStream genesisPoint
103108
pure (ldb, od)

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -952,3 +952,6 @@ mkLMDBSinkArgs fp limits hint reg = do
952952
)
953953
bsClose
954954
pure $ SinkLMDB 1000 (bsWrite bs) (\h -> bsCopy bs h (FS.mkFsPath [snapName, "tables"]))
955+
956+
instance (Ord (TxIn l), GetTip l, Monad m) => StreamingBackendV1 m LMDB l where
957+
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
@@ -76,17 +76,19 @@ import Ouroboros.Consensus.Storage.LedgerDB.API
7676
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
7777
import Ouroboros.Consensus.Storage.LedgerDB.V2
7878
import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend
79+
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
7980
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
8081
import Ouroboros.Consensus.Util (chunks)
8182
import Ouroboros.Consensus.Util.CRC
8283
import Ouroboros.Consensus.Util.Enclose
83-
import Ouroboros.Consensus.Util.IOLike
84+
import Ouroboros.Consensus.Util.IOLike hiding (yield)
8485
import Ouroboros.Consensus.Util.IndexedMemPack
8586
import qualified Streaming as S
8687
import qualified Streaming.Prelude as S
8788
import System.FS.API
8889
import qualified System.FS.BlockIO.API as BIO
8990
import System.FS.BlockIO.IO
91+
import System.FS.CRC
9092
import System.FilePath (splitDirectories, splitFileName)
9193
import System.Random
9294
import Prelude hiding (read)
@@ -203,12 +205,13 @@ snapshotManager ::
203205
CodecConfig blk ->
204206
Tracer m (TraceSnapshotEvent blk) ->
205207
SomeHasFS m ->
208+
Maybe (NonNativeSnapshotsFS m) ->
206209
SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
207-
snapshotManager session ccfg tracer fs =
210+
snapshotManager session ccfg tracer fs mNonNative =
208211
SnapshotManager
209212
{ listSnapshots = defaultListSnapshots fs
210213
, deleteSnapshot = implDeleteSnapshot session fs tracer
211-
, takeSnapshot = implTakeSnapshot ccfg tracer fs
214+
, takeSnapshot = implTakeSnapshot ccfg tracer fs mNonNative
212215
}
213216

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

349365
writeSnapshot ::
350366
MonadThrow m =>
351367
SomeHasFS m ->
352368
(ExtLedgerState blk EmptyMK -> Encoding) ->
353369
DiskSnapshot ->
354370
StateRef m (ExtLedgerState blk) ->
355-
m ()
371+
m CRC
356372
writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
357373
createDirectoryIfMissing hasFs True $ snapshotToDirPath ds
358374
crc1 <- writeExtLedgerState fs encLedger (snapshotToStatePath ds) $ state st
@@ -363,6 +379,7 @@ writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
363379
, snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2
364380
, snapshotTablesCodecVersion = TablesCodecVersion1
365381
}
382+
pure crc1
366383

367384
-- | Delete snapshot from disk and also from the LSM tree database.
368385
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
@@ -68,7 +68,10 @@ openDB
6868
getBlock =
6969
case lgrBackendArgs args of
7070
LedgerDbBackendArgsV1 bss ->
71-
let snapManager = V1.snapshotManager args
71+
let snapManager =
72+
V1.snapshotManager
73+
args
74+
bss
7275
initDb =
7376
V1.mkInitDb
7477
args
@@ -91,6 +94,7 @@ openDB
9194
(configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args)
9295
(LedgerDBSnapshotEvent >$< lgrTracer args)
9396
(lgrHasFS args)
97+
(flip NonNativeSnapshotsFS (lgrHasFS args) <$> lgrNonNativeSnapshotsFS args)
9498
let initDb = V2.mkInitDb args getBlock snapManager res
9599
doOpenDB args initDb snapManager stream replayGoal
96100

‎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
@@ -51,6 +51,8 @@ data LedgerDbArgs f m blk = LedgerDbArgs
5151
, lgrTracer :: Tracer m (TraceEvent blk)
5252
, lgrBackendArgs :: LedgerDbBackendArgs m blk
5353
, lgrRegistry :: HKD f (ResourceRegistry m)
54+
, lgrNonNativeSnapshotsFS :: Maybe (SomeHasFS m)
55+
-- ^ If Just, enable non-native snapshots.
5456
, lgrQueryBatchSize :: QueryBatchSize
5557
, lgrStartSnapshot :: Maybe DiskSnapshot
5658
-- ^ If provided, the ledgerdb will start using said snapshot and fallback
@@ -79,6 +81,7 @@ defaultArgs =
7981
lgrBackendArgs = LedgerDbBackendArgsV2 $ V2.SomeBackendArgs InMemArgs
8082
, lgrRegistry = NoDefault
8183
, lgrStartSnapshot = Nothing
84+
, lgrNonNativeSnapshotsFS = Nothing
8285
}
8386

8487
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
@@ -365,3 +366,12 @@ instance
365366
newBackingStoreInitialiser trcr InMemArgs =
366367
newInMemoryBackingStore
367368
(SomeBackendTrace . InMemoryBackingStoreTrace >$< trcr)
369+
370+
instance StreamingBackend m Mem l where
371+
data SinkArgs m Mem l = SinkArgs Void
372+
data YieldArgs m Mem l = YieldArgs Void
373+
yield _ (YieldArgs x) = absurd x
374+
sink _ (SinkArgs x) = absurd x
375+
376+
instance StreamingBackendV1 m Mem l where
377+
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

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

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@
99
module Ouroboros.Consensus.Storage.LedgerDB.V2.Backend
1010
( -- * Backend API
1111
Backend (..)
12+
, NonNativeSnapshotsFS (..)
1213

1314
-- * Existentials
1415
, SomeBackendTrace (..)
@@ -82,8 +83,17 @@ class NoThunks (Resources m backend) => Backend m backend blk where
8283
CodecConfig blk ->
8384
Tracer m (TraceSnapshotEvent blk) ->
8485
SomeHasFS m ->
86+
Maybe (NonNativeSnapshotsFS m) ->
8587
SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
8688

89+
-- | Arguments required if non-native snapshots are enabled.
90+
data NonNativeSnapshotsFS m = NonNativeSnapshotsFS
91+
{ nnNonNativeHasFS :: SomeHasFS m
92+
-- ^ The FS on which non-native snapshots are stored
93+
, nnNativeHasFS :: SomeHasFS m
94+
-- ^ The FS on which native snapshots are stored
95+
}
96+
8797
{-------------------------------------------------------------------------------
8898
Existentials
8999
-------------------------------------------------------------------------------}

0 commit comments

Comments
 (0)