Skip to content

Commit b1cbe0c

Browse files
jasagredojasagredo
committed
Implement non-native snapshots
1 parent ec5e761 commit b1cbe0c

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
@@ -969,3 +969,6 @@ mkLMDBSinkArgs fp limits hint reg = do
969969
)
970970
bsClose
971971
pure $ SinkLMDB 1000 (bsWrite bs) (\h -> bsCopy bs h (FS.mkFsPath [snapName, "tables"]))
972+
973+
instance (Ord (TxIn l), GetTip l, Monad m) => StreamingBackendV1 m LMDB l where
974+
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
@@ -80,17 +80,19 @@ import Ouroboros.Consensus.Storage.LedgerDB.Args
8080
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
8181
import Ouroboros.Consensus.Storage.LedgerDB.V2
8282
import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend
83+
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
8384
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
8485
import Ouroboros.Consensus.Util (chunks)
8586
import Ouroboros.Consensus.Util.CRC
8687
import Ouroboros.Consensus.Util.Enclose
87-
import Ouroboros.Consensus.Util.IOLike
88+
import Ouroboros.Consensus.Util.IOLike hiding (yield)
8889
import Ouroboros.Consensus.Util.IndexedMemPack
8990
import qualified Streaming as S
9091
import qualified Streaming.Prelude as S
9192
import System.FS.API
9293
import qualified System.FS.BlockIO.API as BIO
9394
import System.FS.BlockIO.IO
95+
import System.FS.CRC
9496
import System.FilePath (splitDirectories, splitFileName)
9597
import System.Random
9698
import Prelude hiding (read)
@@ -231,12 +233,13 @@ snapshotManager ::
231233
CodecConfig blk ->
232234
Tracer m (TraceSnapshotEvent blk) ->
233235
SomeHasFS m ->
236+
Maybe (NonNativeSnapshotsFS m) ->
234237
SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
235-
snapshotManager session ccfg tracer fs =
238+
snapshotManager session ccfg tracer fs mNonNative =
236239
SnapshotManager
237240
{ listSnapshots = defaultListSnapshots fs
238241
, deleteSnapshot = implDeleteSnapshot session fs tracer
239-
, takeSnapshot = implTakeSnapshot ccfg tracer fs
242+
, takeSnapshot = implTakeSnapshot ccfg tracer fs mNonNative
240243
}
241244

242245
newLSMLedgerTablesHandle ::
@@ -357,30 +360,43 @@ implTakeSnapshot ::
357360
CodecConfig blk ->
358361
Tracer m (TraceSnapshotEvent blk) ->
359362
SomeHasFS m ->
363+
Maybe (NonNativeSnapshotsFS m) ->
360364
Maybe String ->
361365
StateRef m (ExtLedgerState blk) ->
362366
m (Maybe (DiskSnapshot, RealPoint blk))
363-
implTakeSnapshot ccfg tracer hasFS suffix st = case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of
364-
Origin -> return Nothing
365-
NotOrigin t -> do
366-
let number = unSlotNo (realPointSlot t)
367-
snapshot = DiskSnapshot number suffix
368-
diskSnapshots <- defaultListSnapshots hasFS
369-
if List.any (== DiskSnapshot number suffix) diskSnapshots
370-
then
371-
return Nothing
372-
else do
373-
encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
374-
writeSnapshot hasFS (encodeDiskExtLedgerState ccfg) snapshot st
375-
return $ Just (snapshot, t)
367+
implTakeSnapshot ccfg tracer shfs mNonNativeFS suffix st =
368+
case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of
369+
Origin -> return Nothing
370+
NotOrigin t -> do
371+
let number = unSlotNo (realPointSlot t)
372+
snapshot = DiskSnapshot number suffix
373+
diskSnapshots <- defaultListSnapshots shfs
374+
if List.any (== DiskSnapshot number suffix) diskSnapshots
375+
then
376+
return Nothing
377+
else do
378+
stateCRC <-
379+
encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
380+
writeSnapshot shfs (encodeDiskExtLedgerState ccfg) snapshot st
381+
takeNonNativeSnapshot
382+
(($ t) >$< tracer)
383+
snapshot
384+
(duplicate (tables st))
385+
close
386+
(\hdl -> yield (Proxy @LSM) (YieldLSM 1000 hdl) (state st))
387+
(state st)
388+
stateCRC
389+
mNonNativeFS
390+
391+
return $ Just (snapshot, t)
376392

377393
writeSnapshot ::
378394
MonadThrow m =>
379395
SomeHasFS m ->
380396
(ExtLedgerState blk EmptyMK -> Encoding) ->
381397
DiskSnapshot ->
382398
StateRef m (ExtLedgerState blk) ->
383-
m ()
399+
m CRC
384400
writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
385401
createDirectoryIfMissing hasFs True $ snapshotToDirPath ds
386402
crc1 <- writeExtLedgerState fs encLedger (snapshotToStatePath ds) $ state st
@@ -391,6 +407,7 @@ writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
391407
, snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2
392408
, snapshotTablesCodecVersion = TablesCodecVersion1
393409
}
410+
pure crc1
394411

395412
-- | Delete snapshot from disk and also from the LSM tree database.
396413
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
@@ -48,6 +48,8 @@ data LedgerDbArgs f m blk = LedgerDbArgs
4848
, lgrTracer :: Tracer m (TraceEvent blk)
4949
, lgrBackendArgs :: LedgerDbBackendArgs m blk
5050
, lgrRegistry :: HKD f (ResourceRegistry m)
51+
, lgrNonNativeSnapshotsFS :: Maybe (SomeHasFS m)
52+
-- ^ If Just, enable non-native snapshots.
5153
, lgrQueryBatchSize :: QueryBatchSize
5254
, lgrStartSnapshot :: Maybe DiskSnapshot
5355
-- ^ If provided, the ledgerdb will start using said snapshot and fallback
@@ -73,6 +75,7 @@ defaultArgs backendArgs =
7375
lgrBackendArgs = LedgerDbBackendArgsV2 backendArgs
7476
, lgrRegistry = NoDefault
7577
, lgrStartSnapshot = Nothing
78+
, lgrNonNativeSnapshotsFS = Nothing
7679
}
7780

7881
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)