From 7af3e4dbc6b3c98a6c94a60c9bc99159e466f363 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 24 Nov 2025 16:21:10 +0100 Subject: [PATCH 1/5] Make forkers more observable --- ...4_165014_javier.sagredo_tracing_forkers.md | 23 +++++ .../Consensus/Storage/LedgerDB/Forker.hs | 20 ++-- .../Consensus/Storage/LedgerDB/V1.hs | 6 +- .../Consensus/Storage/LedgerDB/V1/Forker.hs | 94 +++++++++---------- .../Consensus/Storage/LedgerDB/V2.hs | 6 +- .../Consensus/Storage/LedgerDB/V2/Forker.hs | 70 +++++++------- 6 files changed, 126 insertions(+), 93 deletions(-) create mode 100644 ouroboros-consensus/changelog.d/20251124_165014_javier.sagredo_tracing_forkers.md diff --git a/ouroboros-consensus/changelog.d/20251124_165014_javier.sagredo_tracing_forkers.md b/ouroboros-consensus/changelog.d/20251124_165014_javier.sagredo_tracing_forkers.md new file mode 100644 index 0000000000..50798f401e --- /dev/null +++ b/ouroboros-consensus/changelog.d/20251124_165014_javier.sagredo_tracing_forkers.md @@ -0,0 +1,23 @@ + + +### Patch + +- Make forker tracers more informative, with enclosing times. + + + diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs index da373f93b9..d23b748edd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs @@ -39,6 +39,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Forker -- ** Tracing , TraceForkerEvent (..) , TraceForkerEventWithKey (..) + , ForkerWasCommitted (..) -- * Validation , AnnLedgerError (..) @@ -81,6 +82,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache import Ouroboros.Consensus.Util.CallStack +import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike {------------------------------------------------------------------------------- @@ -663,14 +665,14 @@ data TraceForkerEventWithKey data TraceForkerEvent = ForkerOpen - | ForkerCloseUncommitted - | ForkerCloseCommitted - | ForkerReadTablesStart - | ForkerReadTablesEnd - | ForkerRangeReadTablesStart - | ForkerRangeReadTablesEnd + | ForkerReadTables EnclosingTimed + | ForkerRangeReadTables EnclosingTimed | ForkerReadStatistics - | ForkerPushStart - | ForkerPushEnd - | DanglingForkerClosed + | ForkerPush EnclosingTimed + | ForkerClose ForkerWasCommitted deriving (Show, Eq) + +data ForkerWasCommitted + = ForkerWasCommitted + | ForkerWasUncommitted + deriving (Eq, Show) 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 1e81a8b9f7..e1264ab257 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 @@ -852,6 +852,7 @@ newForker h ldbEnv (rk, releaseVar) rr dblog = dblogVar <- newTVarIO dblog forkerKey <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \r -> (r, r + 1) forkerMVar <- newMVar $ Left (ldbLock ldbEnv, ldbBackingStore ldbEnv, rr) + forkerCommitted <- newTVarIO False let forkerEnv = ForkerEnv { foeBackingStoreValueHandle = forkerMVar @@ -859,6 +860,7 @@ newForker h ldbEnv (rk, releaseVar) rr dblog = , foeSwitchVar = ldbChangelog ldbEnv , foeTracer = LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv + , foeWasCommitted = forkerCommitted } atomically $ do -- Note that we add the forkerEnv to the 'ldbForkers' so that an exception @@ -921,5 +923,7 @@ implForkerClose (LDBHandle varState) forkerKey env = do (\m -> Map.updateLookupWithKey (\_ _ -> Nothing) forkerKey m) case frk of Nothing -> pure () - Just e -> traceWith (foeTracer e) DanglingForkerClosed + Just e -> do + wc <- readTVarIO (foeWasCommitted e) + traceWith (foeTracer e) (ForkerClose $ if wc then ForkerWasCommitted else ForkerWasUncommitted) closeForkerEnv env diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs index 6c770ccc30..e7e82b87eb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs @@ -23,6 +23,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.Forker import qualified Control.Monad as Monad import Control.ResourceRegistry import Control.Tracer +import Data.Functor.Contravariant ((>$<)) import qualified Data.Map.Strict as Map import Data.Semigroup import qualified Data.Set as Set @@ -43,6 +44,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq ) import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS import Ouroboros.Consensus.Storage.LedgerDB.V1.Lock +import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike import qualified Ouroboros.Network.AnchoredSeq as AS @@ -72,6 +74,7 @@ data ForkerEnv m l blk = ForkerEnv -- flushed, but 'forkerCommit' will take care of this. , foeTracer :: !(Tracer m TraceForkerEvent) -- ^ Config + , foeWasCommitted :: !(StrictTVar m Bool) } deriving Generic @@ -132,16 +135,14 @@ implForkerReadTables :: ForkerEnv m l blk -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK) -implForkerReadTables env ks = do - traceWith (foeTracer env) ForkerReadTablesStart - chlog <- readTVarIO (foeChangelog env) - bsvh <- getValueHandle env - unfwd <- readKeySetsWith bsvh (changelogLastFlushedState chlog) ks - case forwardTableKeySets chlog unfwd of - Left _err -> error "impossible!" - Right vs -> do - traceWith (foeTracer env) ForkerReadTablesEnd - pure vs +implForkerReadTables env ks = + encloseTimedWith (ForkerReadTables >$< foeTracer env) $ do + chlog <- readTVarIO (foeChangelog env) + bsvh <- getValueHandle env + unfwd <- readKeySetsWith bsvh (changelogLastFlushedState chlog) ks + case forwardTableKeySets chlog unfwd of + Left _err -> error "impossible!" + Right vs -> pure vs implForkerRangeReadTables :: (IOLike m, GetTip l, HasLedgerTables l) => @@ -149,36 +150,35 @@ implForkerRangeReadTables :: ForkerEnv m l blk -> RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l)) -implForkerRangeReadTables qbs env rq0 = do - traceWith (foeTracer env) ForkerRangeReadTablesStart - ldb <- readTVarIO $ foeChangelog env - let - -- Get the differences without the keys that are greater or equal - -- than the maximum previously seen key. - diffs = - maybe - id - (ltliftA2 doDropLTE) - (BackingStore.rqPrev rq) - $ ltmap prj - $ changelogDiffs ldb - -- (1) Ensure that we never delete everything read from disk (ie if - -- our result is non-empty then it contains something read from - -- disk, as we only get an empty result if we reached the end of - -- the table). - -- - -- (2) Also, read one additional key, which we will not include in - -- the result but need in order to know which in-memory - -- insertions to include. - maxDeletes = ltcollapse $ ltmap (K2 . numDeletesDiffMK) diffs - nrequested = 1 + max (BackingStore.rqCount rq) (1 + maxDeletes) +implForkerRangeReadTables qbs env rq0 = + encloseTimedWith (ForkerRangeReadTables >$< foeTracer env) $ do + ldb <- readTVarIO $ foeChangelog env + let + -- Get the differences without the keys that are greater or equal + -- than the maximum previously seen key. + diffs = + maybe + id + (ltliftA2 doDropLTE) + (BackingStore.rqPrev rq) + $ ltmap prj + $ changelogDiffs ldb + -- (1) Ensure that we never delete everything read from disk (ie if + -- our result is non-empty then it contains something read from + -- disk, as we only get an empty result if we reached the end of + -- the table). + -- + -- (2) Also, read one additional key, which we will not include in + -- the result but need in order to know which in-memory + -- insertions to include. + maxDeletes = ltcollapse $ ltmap (K2 . numDeletesDiffMK) diffs + nrequested = 1 + max (BackingStore.rqCount rq) (1 + maxDeletes) - let st = changelogLastFlushedState ldb - bsvh <- getValueHandle env - (values, mx) <- BackingStore.bsvhRangeRead bsvh st (rq{BackingStore.rqCount = nrequested}) - traceWith (foeTracer env) ForkerRangeReadTablesEnd - let res = ltliftA2 (doFixupReadResult nrequested) diffs values - pure (res, mx) + let st = changelogLastFlushedState ldb + bsvh <- getValueHandle env + (values, mx) <- BackingStore.bsvhRangeRead bsvh st (rq{BackingStore.rqCount = nrequested}) + let res = ltliftA2 (doFixupReadResult nrequested) diffs values + pure (res, mx) where rq = BackingStore.RangeQuery rq1 (fromIntegral $ defaultQueryBatchSize qbs) @@ -309,17 +309,16 @@ implForkerReadStatistics env = do } implForkerPush :: - (MonadSTM m, GetTip l, HasLedgerTables l) => + (IOLike m, GetTip l, HasLedgerTables l) => ForkerEnv m l blk -> l DiffMK -> m () -implForkerPush env newState = do - traceWith (foeTracer env) ForkerPushStart - atomically $ do - chlog <- readTVar (foeChangelog env) - let chlog' = extend newState chlog - writeTVar (foeChangelog env) chlog' - traceWith (foeTracer env) ForkerPushEnd +implForkerPush env newState = + encloseTimedWith (ForkerPush >$< foeTracer env) $ do + atomically $ do + chlog <- readTVar (foeChangelog env) + let chlog' = extend newState chlog + writeTVar (foeChangelog env) chlog' implForkerCommit :: (MonadSTM m, GetTip l, StandardHash l, HasLedgerTables l) => @@ -350,6 +349,7 @@ implForkerCommit env = do , changelogDiffs = ltliftA2 (doPrune s) (changelogDiffs orig) (changelogDiffs dblog) } + Monad.void $ swapTVar (foeWasCommitted env) True where -- Prune the diffs from the forker's log that have already been flushed 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 5013a4a628..49ba973a6b 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 @@ -734,7 +734,9 @@ implForkerClose (LDBHandle varState) forkerKey forkerEnv = do case frk of Nothing -> pure () - Just e -> traceWith (foeTracer e) DanglingForkerClosed + Just e -> do + wc <- readTVarIO (foeWasCommitted e) + traceWith (foeTracer e) (ForkerClose $ if wc then ForkerWasCommitted else ForkerWasUncommitted) closeForkerEnv forkerEnv @@ -757,6 +759,7 @@ newForker h ldbEnv rr (rk, st) = do traceWith tr ForkerOpen lseqVar <- newTVarIO . LedgerSeq . AS.Empty $ st foeCleanup <- newTVarIO $ pure () + forkerCommitted <- newTVarIO False let forkerEnv = ForkerEnv { foeLedgerSeq = lseqVar @@ -768,6 +771,7 @@ newForker h ldbEnv rr (rk, st) = do , foeCleanup , foeLedgerDbLock = ldbOpenHandlesLock ldbEnv , foeLedgerDbToClose = ldbToClose ldbEnv + , foeWasCommitted = forkerCommitted } atomically $ modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv pure $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs index a1b9e77c49..a819063fd7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs @@ -22,6 +22,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.Forker import Control.RAWLock (RAWLock) import Control.ResourceRegistry import Control.Tracer +import Data.Functor.Contravariant ((>$<)) import Data.Maybe (fromMaybe) import GHC.Generics import NoThunks.Class @@ -35,6 +36,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.Forker import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq import Ouroboros.Consensus.Util (whenJust) import Ouroboros.Consensus.Util.CallStack +import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.NormalForm.StrictTVar () import qualified Ouroboros.Network.AnchoredSeq as AS @@ -66,6 +68,7 @@ data ForkerEnv m l blk = ForkerEnv -- LedgerDB and release the discarded ones. , foeLedgerDbLock :: !(RAWLock m ()) -- ^ 'ldbOpenHandlesLock'. + , foeWasCommitted :: !(StrictTVar m Bool) } deriving Generic @@ -79,36 +82,32 @@ deriving instance NoThunks (ForkerEnv m l blk) implForkerReadTables :: - (MonadSTM m, GetTip l) => + (IOLike m, GetTip l) => ForkerEnv m l blk -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK) -implForkerReadTables env ks = do - traceWith (foeTracer env) ForkerReadTablesStart - lseq <- readTVarIO (foeLedgerSeq env) - let stateRef = currentHandle lseq - tbs <- read (tables stateRef) (state stateRef) ks - traceWith (foeTracer env) ForkerReadTablesEnd - pure tbs +implForkerReadTables env ks = + encloseTimedWith (ForkerReadTables >$< foeTracer env) $ do + lseq <- readTVarIO (foeLedgerSeq env) + let stateRef = currentHandle lseq + read (tables stateRef) (state stateRef) ks implForkerRangeReadTables :: - (MonadSTM m, GetTip l, HasLedgerTables l) => + (IOLike m, GetTip l, HasLedgerTables l) => QueryBatchSize -> ForkerEnv m l blk -> RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l)) -implForkerRangeReadTables qbs env rq0 = do - traceWith (foeTracer env) ForkerRangeReadTablesStart - ldb <- readTVarIO $ foeLedgerSeq env - let n = fromIntegral $ defaultQueryBatchSize qbs - stateRef = currentHandle ldb - case rq0 of - NoPreviousQuery -> readRange (tables stateRef) (state stateRef) (Nothing, n) - PreviousQueryWasFinal -> pure (LedgerTables emptyMK, Nothing) - PreviousQueryWasUpTo k -> do - tbs <- readRange (tables stateRef) (state stateRef) (Just k, n) - traceWith (foeTracer env) ForkerRangeReadTablesEnd - pure tbs +implForkerRangeReadTables qbs env rq0 = + encloseTimedWith (ForkerRangeReadTables >$< foeTracer env) $ do + ldb <- readTVarIO $ foeLedgerSeq env + let n = fromIntegral $ defaultQueryBatchSize qbs + stateRef = currentHandle ldb + case rq0 of + NoPreviousQuery -> readRange (tables stateRef) (state stateRef) (Nothing, n) + PreviousQueryWasFinal -> pure (LedgerTables emptyMK, Nothing) + PreviousQueryWasUpTo k -> + readRange (tables stateRef) (state stateRef) (Just k, n) implForkerGetLedgerState :: (MonadSTM m, GetTip l) => @@ -129,24 +128,23 @@ implForkerPush :: ForkerEnv m l blk -> l DiffMK -> m () -implForkerPush env newState = do - traceWith (foeTracer env) ForkerPushStart - lseq <- readTVarIO (foeLedgerSeq env) +implForkerPush env newState = + encloseTimedWith (ForkerPush >$< foeTracer env) $ do + lseq <- readTVarIO (foeLedgerSeq env) - let st0 = current lseq - st = forgetLedgerTables newState + let st0 = current lseq + st = forgetLedgerTables newState - bracketOnError - (duplicate (tables $ currentHandle lseq) (foeResourceRegistry env)) - (release . fst) - ( \(_, newtbs) -> do - pushDiffs newtbs st0 newState + bracketOnError + (duplicate (tables $ currentHandle lseq) (foeResourceRegistry env)) + (release . fst) + ( \(_, newtbs) -> do + pushDiffs newtbs st0 newState - let lseq' = extend (StateRef st newtbs) lseq + let lseq' = extend (StateRef st newtbs) lseq - traceWith (foeTracer env) ForkerPushEnd - atomically $ writeTVar (foeLedgerSeq env) lseq' - ) + atomically $ writeTVar (foeLedgerSeq env) lseq' + ) implForkerCommit :: (IOLike m, GetTip l, StandardHash l) => @@ -183,6 +181,7 @@ implForkerCommit env = do ) whenJust ldbToClose (modifyTVar foeLedgerDbToClose . (:)) writeTVar foeCleanup transfer + writeTVar foeWasCommitted True where ForkerEnv { foeLedgerSeq @@ -191,6 +190,7 @@ implForkerCommit env = do , foeLedgerDbRegistry , foeCleanup , foeLedgerDbToClose + , foeWasCommitted } = env theImpossible = From b5127a54eae206789431417d3e72f56fea51e0ee Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 24 Nov 2025 16:41:22 +0100 Subject: [PATCH 2/5] Reject legacy snapshots --- ...124_165114_javier.sagredo_reject_legacy.md | 22 +++++++++++++++++++ .../Consensus/Storage/LedgerDB/V2/LSM.hs | 4 +++- .../Consensus/Storage/LedgerDB/Snapshots.hs | 2 ++ .../Storage/LedgerDB/V1/Snapshots.hs | 5 ++++- .../Consensus/Storage/LedgerDB/V2/InMemory.hs | 5 ++++- 5 files changed, 35 insertions(+), 3 deletions(-) create mode 100644 ouroboros-consensus/changelog.d/20251124_165114_javier.sagredo_reject_legacy.md diff --git a/ouroboros-consensus/changelog.d/20251124_165114_javier.sagredo_reject_legacy.md b/ouroboros-consensus/changelog.d/20251124_165114_javier.sagredo_reject_legacy.md new file mode 100644 index 0000000000..11b01edb2e --- /dev/null +++ b/ouroboros-consensus/changelog.d/20251124_165114_javier.sagredo_reject_legacy.md @@ -0,0 +1,22 @@ + + + + +### Breaking + +- Legacy snapshots will be rejected and deleted, instead of crashing consensus. diff --git a/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs index cc44c81736..1c4dd4305f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs @@ -450,8 +450,10 @@ loadSnapshot :: Session m -> DiskSnapshot -> ExceptT (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk) -loadSnapshot tracer rr ccfg fs session ds = +loadSnapshot tracer rr ccfg fs@(SomeHasFS hfs) session ds = do + fileEx <- lift $ doesFileExist hfs (snapshotToDirPath ds) + Monad.when fileEx $ throwE $ InitFailureRead ReadSnapshotIsLegacy snapshotMeta <- withExceptT (InitFailureRead . ReadMetadataError (snapshotToMetadataPath ds)) $ loadSnapshotMetadata fs ds 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 1b5826e2f3..e432acf581 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 @@ -185,6 +185,8 @@ data ReadSnapshotErr ReadSnapshotDataCorruption | -- | An error occurred while reading the snapshot metadata file ReadMetadataError FsPath MetadataErr + | -- | We were given a legacy snapshot + ReadSnapshotIsLegacy deriving (Eq, Show) data TablesCodecVersion = TablesCodecVersion1 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 0e4b658ee3..1fab7171eb 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 @@ -163,6 +163,7 @@ import Ouroboros.Consensus.Util.Args (Complete) import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike import System.FS.API +import qualified System.FS.API as FS snapshotManager :: ( IOLike m @@ -293,7 +294,9 @@ loadSnapshot :: (SnapshotFailure blk) m ((DbChangelog' blk, ResourceKey m, LedgerBackingStore m (ExtLedgerState blk)), RealPoint blk) -loadSnapshot tracer bArgs@(SomeBackendArgs bss) ccfg fs@(SnapshotsFS fs') reg s = do +loadSnapshot tracer bArgs@(SomeBackendArgs bss) ccfg fs@(SnapshotsFS fs'@(SomeHasFS hfs)) reg s = do + fileEx <- Trans.lift $ FS.doesFileExist hfs (snapshotToDirPath s) + Monad.when fileEx $ throwError $ InitFailureRead ReadSnapshotIsLegacy (extLedgerSt, checksumAsRead) <- withExceptT (InitFailureRead . ReadSnapshotFailed) $ readExtLedgerState fs' (decodeDiskExtLedgerState ccfg) decode (snapshotToStatePath s) 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 906937b457..93f2ed831d 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 @@ -323,7 +323,10 @@ loadSnapshot :: SomeHasFS m -> DiskSnapshot -> ExceptT (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk) -loadSnapshot tracer _rr ccfg fs ds = do +loadSnapshot tracer _rr ccfg fs@(SomeHasFS hfs) ds = do + fileEx <- lift $ doesFileExist hfs (snapshotToDirPath ds) + Monad.when fileEx $ throwE $ InitFailureRead ReadSnapshotIsLegacy + snapshotMeta <- withExceptT (InitFailureRead . ReadMetadataError (snapshotToMetadataPath ds)) $ loadSnapshotMetadata fs ds From 7a462192c40140df1c415d412858cf26b416e5b4 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 25 Nov 2025 08:54:30 +0100 Subject: [PATCH 3/5] Use patched lsm-tree for filepath 1.4 --- cabal.project | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/cabal.project b/cabal.project index b983c81b56..68712c03a6 100644 --- a/cabal.project +++ b/cabal.project @@ -89,3 +89,12 @@ source-repository-package subdir: ouroboros-network-api ouroboros-network + +source-repository-package + type: git + location: https://github.com/IntersectMBO/lsm-tree + tag: 96474ce9559573698095229d8d08bd1a95b7ae01 + --sha256: sha256-5Tk4kVP6U0MuPHjRNal9XFFz6TgHBoFOhGCzEYrV3v4= + subdir: + lsm-tree + blockio From 41f32e52644aa168c4f4d4ef645ed6c3ec2ecfd6 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 25 Nov 2025 08:57:31 +0100 Subject: [PATCH 4/5] Update ouroboros-network to 0.22.4 --- cabal.project | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/cabal.project b/cabal.project index 68712c03a6..4607793e46 100644 --- a/cabal.project +++ b/cabal.project @@ -82,19 +82,19 @@ source-repository-package -- Backported version of https://github.com/IntersectMBO/ouroboros-network/pull/5161 source-repository-package - type: git - location: https://github.com/IntersectMBO/ouroboros-network - tag: 1385b53cefb81e79553b6b0252537455833ea9c4 - --sha256: sha256-zZ7WsMfRs1fG16bmvI5vIh4fhQ8RGyEvYGLSWlrxpg0= - subdir: - ouroboros-network-api - ouroboros-network + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: dfcb1f9c578ec8cd5114fea9696e7be6c9001323 + --sha256: sha256-omXPdi/T/f3gq9rOH20zX+x3WvaxlB704g07RF/13Nk= + subdir: + ouroboros-network-api + ouroboros-network source-repository-package type: git location: https://github.com/IntersectMBO/lsm-tree - tag: 96474ce9559573698095229d8d08bd1a95b7ae01 - --sha256: sha256-5Tk4kVP6U0MuPHjRNal9XFFz6TgHBoFOhGCzEYrV3v4= + tag: 3c51ea5ac6400f32a7bdf17260325d4d0a360a98 + --sha256: sha256-44SHqtAciPhoI6ysLt8RdNvlVvN91GWHMnr68vOU2gQ= subdir: lsm-tree blockio From 163895614992007a09675fd15980578ecd6e1e91 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Wed, 1 Oct 2025 13:47:01 +0200 Subject: [PATCH 5/5] Expose library for snapshot conversion --- .../app/snapshot-converter.hs | 442 +-------------- .../ouroboros-consensus-cardano.cabal | 57 +- .../Consensus/Cardano/SnapshotConversion.hs | 518 ++++++++++++++++++ .../Cardano/StreamingLedgerTables.hs | 0 4 files changed, 558 insertions(+), 459 deletions(-) create mode 100644 ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/SnapshotConversion.hs rename ouroboros-consensus-cardano/{app => src/snapshot-conversion}/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs (100%) diff --git a/ouroboros-consensus-cardano/app/snapshot-converter.hs b/ouroboros-consensus-cardano/app/snapshot-converter.hs index 6802074a06..e2f53b008d 100644 --- a/ouroboros-consensus-cardano/app/snapshot-converter.hs +++ b/ouroboros-consensus-cardano/app/snapshot-converter.hs @@ -1,60 +1,16 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} module Main (main) where import Cardano.Crypto.Init (cryptoInit) import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo) -import Codec.Serialise -import qualified Control.Monad as Monad import Control.Monad.Except -import Control.Monad.Trans (lift) -import Control.ResourceRegistry import DBAnalyser.Parsers -import Data.Bifunctor -import Data.Char (toLower) -import qualified Data.Text.Lazy as T import Main.Utf8 import Options.Applicative import Options.Applicative.Help (Doc, line) -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Cardano.Block -import Ouroboros.Consensus.Cardano.StreamingLedgerTables -import Ouroboros.Consensus.Config -import Ouroboros.Consensus.Ledger.Basics -import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Storage.LedgerDB.API -import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as V1 -import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM -import Ouroboros.Consensus.Util.CRC -import Ouroboros.Consensus.Util.IOLike hiding (yield) -import System.Console.ANSI -import qualified System.Directory as D +import Ouroboros.Consensus.Cardano.SnapshotConversion import System.Exit -import System.FS.API -import System.FS.CRC -import System.FS.IO -import System.FilePath (splitDirectories) -import qualified System.FilePath as F -import System.IO -import System.ProgressBar -import System.Random - -data Format - = Mem FilePath - | LMDB FilePath - | LSM FilePath FilePath - deriving (Show, Read) data Config = Config { from :: Format @@ -168,402 +124,14 @@ parsePath optName strHelp = ] ) -data Error blk - = SnapshotError (SnapshotFailure blk) - | BadDirectoryName FilePath - | WrongSlotDirectoryName FilePath SlotNo - | InvalidMetadata String - | BackendMismatch SnapshotBackend SnapshotBackend - | CRCMismatch CRC CRC - | ReadTablesError DeserialiseFailure - | Cancelled - deriving Exception - -instance StandardHash blk => Show (Error blk) where - show (SnapshotError err) = - "Couldn't deserialize the snapshot. Are you running the same node version that created the snapshot? " - <> show err - show (BadDirectoryName fp) = - mconcat - [ "Filepath " - , fp - , " is not an snapshot. The last fragment on the path should be" - , " named after the slot number of the state it contains and an" - , " optional suffix, such as `163470034` or `163470034_my-suffix`." - ] - show (InvalidMetadata s) = "Metadata is invalid: " <> s - show (BackendMismatch b1 b2) = - mconcat - [ "Mismatched backend in snapshot. Reading as " - , show b1 - , " but snapshot is " - , show b2 - ] - show (WrongSlotDirectoryName fp sl) = - mconcat - [ "The name of the snapshot (\"" - , fp - , "\") does not correspond to the slot number of the state (" - , (show . unSlotNo $ sl) - , ")." - ] - show (CRCMismatch c1 c2) = - mconcat - [ "The input snapshot seems corrupted. Metadata has CRC " - , show c1 - , " but reading it gives CRC " - , show c2 - ] - show (ReadTablesError df) = - mconcat - ["Error when reading entries in the UTxO tables: ", show df] - show Cancelled = "Cancelled" - -data InEnv backend = InEnv - { inState :: LedgerState (CardanoBlock StandardCrypto) EmptyMK - , inFilePath :: FilePath - , inStream :: - LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ResourceRegistry IO -> - IO (SomeBackend YieldArgs) - , inProgressMsg :: String - , inCRC :: CRC - , inSnapReadCRC :: Maybe CRC - } - -data SomeBackend c where - SomeBackend :: - StreamingBackend IO backend (LedgerState (CardanoBlock StandardCrypto)) => - c IO backend (LedgerState (CardanoBlock StandardCrypto)) -> SomeBackend c - -data OutEnv backend = OutEnv - { outFilePath :: FilePath - , outStream :: - LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ResourceRegistry IO -> - IO (SomeBackend SinkArgs) - , outCreateExtra :: Maybe FilePath - , outDeleteExtra :: Maybe FilePath - , outProgressMsg :: String - , outBackend :: SnapshotBackend - } - main :: IO () main = withStdTerminalHandles $ do - eRes <- runExceptT main' + cryptoInit + (conf, args) <- getCommandLineConfig + pInfo <- mkProtocolInfo args + eRes <- runExceptT (convertSnapshot True pInfo (from conf) (to conf)) case eRes of Left err -> do putStrLn $ show err exitFailure Right () -> exitSuccess - where - main' = do - lift $ cryptoInit - (conf, args) <- lift $ getCommandLineConfig - ccfg <- lift $ configCodec . pInfoConfig <$> mkProtocolInfo args - - InEnv{..} <- getInEnv ccfg (from conf) - - o@OutEnv{..} <- getOutEnv inState (to conf) - - wipeOutputPaths o - - lift $ putStr "Copying state file..." >> hFlush stdout - lift $ D.copyFile (inFilePath F. "state") (outFilePath F. "state") - lift $ putColored Green True "Done" - - lift $ putStr "Streaming ledger tables..." >> hFlush stdout >> saveCursor - - tid <- lift $ niceAnimatedProgressBar inProgressMsg outProgressMsg - - eRes <- lift $ runExceptT (stream inState inStream outStream) - - case eRes of - Left err -> throwError $ ReadTablesError err - Right (mCRCIn, mCRCOut) -> do - lift $ maybe (pure ()) cancel tid - lift $ clearLine >> restoreCursor >> cursorUp 1 >> putColored Green True "Done" - let crcIn = maybe inCRC (crcOfConcat inCRC) mCRCIn - maybe - ( lift $ - putColored Yellow True "The metadata file is missing, the snapshot is not guaranteed to be correct!" - ) - ( \cs -> - Monad.when (cs /= crcIn) $ throwError $ CRCMismatch cs crcIn - ) - inSnapReadCRC - - let crcOut = maybe inCRC (crcOfConcat inCRC) mCRCOut - - lift $ putStr "Generating new metadata file..." >> hFlush stdout - putMetadata outFilePath (SnapshotMetadata outBackend crcOut TablesCodecVersion1) - - lift $ putColored Green True "Done" - - wipeOutputPaths OutEnv{..} = do - wipePath outFilePath - lift $ maybe (pure ()) (D.createDirectory . (outFilePath F.)) outCreateExtra - maybe - (pure ()) - wipePath - outDeleteExtra - - getState ccfg fp@(pathToHasFS -> fs) = do - eState <- lift $ do - putStr $ "Reading ledger state from " <> (fp F. "state") <> "..." - hFlush stdout - runExceptT (readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (mkFsPath ["state"])) - case eState of - Left err -> - throwError . SnapshotError . InitFailureRead @(CardanoBlock StandardCrypto) . ReadSnapshotFailed $ - err - Right st -> lift $ do - putColored Green True " Done" - pure . first ledgerState $ st - - getMetadata fp bknd = do - (fs, ds) <- toDiskSnapshot fp - mtd <- - lift $ runExceptT $ loadSnapshotMetadata fs ds - (,ds) - <$> either - ( \case - MetadataFileDoesNotExist -> pure Nothing - MetadataInvalid s -> throwError $ InvalidMetadata s - MetadataBackendMismatch -> error "impossible" - ) - ( \mtd' -> do - if bknd /= snapshotBackend mtd' - then throwError $ BackendMismatch bknd (snapshotBackend mtd') - else pure $ Just $ snapshotChecksum mtd' - ) - mtd - - putMetadata fp bknd = do - (fs, ds) <- toDiskSnapshot fp - lift $ writeSnapshotMetadata fs ds bknd - - getInEnv ccfg = \case - Mem fp -> do - (mtd, ds) <- getMetadata fp UTxOHDMemSnapshot - (st, c) <- getState ccfg fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - ( withOrigin - ( error - "Impossible! the snapshot seems to be at Genesis but cardano-node would never create such an snapshot!" - ) - id - $ pointSlot (getTip st) - ) - ) - - pure $ - InEnv - st - fp - (\a b -> SomeBackend <$> mkInMemYieldArgs (fp F. "tables") a b) - ("InMemory@[" <> fp <> "]") - c - mtd - LMDB fp -> do - (mtd, ds) <- getMetadata fp UTxOHDLMDBSnapshot - (st, c) <- getState ccfg fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - - pure $ - InEnv - st - fp - (\a b -> SomeBackend <$> V1.mkLMDBYieldArgs (fp F. "tables") defaultLMDBLimits a b) - ("LMDB@[" <> fp <> "]") - c - mtd - LSM fp lsmDbPath -> do - (mtd, ds) <- getMetadata fp UTxOHDLSMSnapshot - (st, c) <- getState ccfg fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - - pure $ - InEnv - st - fp - ( \a b -> - SomeBackend <$> mkLSMYieldArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b - ) - ("LSM@[" <> lsmDbPath <> "]") - c - mtd - - getOutEnv st = \case - Mem fp -> do - (_, ds) <- toDiskSnapshot fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - pure $ - OutEnv - fp - (\a b -> SomeBackend <$> mkInMemSinkArgs (fp F. "tables") a b) - (Just "tables") - (Nothing) - ("InMemory@[" <> fp <> "]") - UTxOHDMemSnapshot - LMDB fp -> do - (_, ds) <- toDiskSnapshot fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - pure $ - OutEnv - fp - (\a b -> SomeBackend <$> V1.mkLMDBSinkArgs fp defaultLMDBLimits a b) - Nothing - Nothing - ("LMDB@[" <> fp <> "]") - UTxOHDLMDBSnapshot - LSM fp lsmDbPath -> do - (_, ds) <- toDiskSnapshot fp - Monad.when - ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) - ( throwError $ - WrongSlotDirectoryName - (snapshotToDirName ds) - (withOrigin undefined id $ pointSlot (getTip st)) - ) - pure $ - OutEnv - fp - ( \a b -> - SomeBackend <$> mkLSMSinkArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b - ) - Nothing - (Just lsmDbPath) - ("LSM@[" <> lsmDbPath <> "]") - UTxOHDLSMSnapshot - -stream :: - LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ResourceRegistry IO -> - IO (SomeBackend YieldArgs) - ) -> - ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> - ResourceRegistry IO -> - IO (SomeBackend SinkArgs) - ) -> - ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC) -stream st mYieldArgs mSinkArgs = - ExceptT $ - withRegistry $ \reg -> do - (SomeBackend (yArgs :: YieldArgs IO backend1 l)) <- mYieldArgs st reg - (SomeBackend (sArgs :: SinkArgs IO backend2 l)) <- mSinkArgs st reg - runExceptT $ yield (Proxy @backend1) yArgs st $ sink (Proxy @backend2) sArgs st - --- Helpers - --- UI -niceAnimatedProgressBar :: String -> String -> IO (Maybe (Async IO ())) -niceAnimatedProgressBar inMsg outMsg = do - stdoutSupportsANSI <- hNowSupportsANSI stdout - if stdoutSupportsANSI - then do - putStrLn "" - pb <- - newProgressBar - defStyle{stylePrefix = msg (T.pack inMsg), stylePostfix = msg (T.pack outMsg)} - 10 - (Progress 1 100 ()) - - fmap Just $ - async $ - let loop = do - threadDelay 0.2 - updateProgress pb (\prg -> prg{progressDone = (progressDone prg + 4) `mod` 100}) - in Monad.forever loop - else pure Nothing - -putColored :: Color -> Bool -> String -> IO () -putColored c b s = do - stdoutSupportsANSI <- hNowSupportsANSI stdout - Monad.when stdoutSupportsANSI $ setSGR [SetColor Foreground Vivid c] - if b - then - putStrLn s - else - putStr s - Monad.when stdoutSupportsANSI $ setSGR [Reset] - hFlush stdout - -askForConfirmation :: - ExceptT (Error (CardanoBlock StandardCrypto)) IO a -> - String -> - ExceptT (Error (CardanoBlock StandardCrypto)) IO a -askForConfirmation act infoMsg = do - lift $ putColored Yellow False $ "I'm going to " <> infoMsg <> ". Continue? (Y/n) " - answer <- lift $ getLine - case map toLower answer of - "y" -> act - _ -> throwError Cancelled - --- | Ask before deleting -wipePath :: FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO () -wipePath fp = do - exists <- lift $ D.doesDirectoryExist fp - ( if exists - then flip askForConfirmation ("wipe the path " <> fp) - else id - ) - (lift $ D.removePathForcibly fp >> D.createDirectoryIfMissing True fp) - -toDiskSnapshot :: - FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO (SomeHasFS IO, DiskSnapshot) -toDiskSnapshot fp@(F.splitFileName . maybeRemoveTrailingSlash -> (snapPath, snapName)) = - maybe - (throwError $ BadDirectoryName fp) - (pure . (pathToHasFS snapPath,)) - $ snapshotFromPath snapName - --- | Given a filepath pointing to a snapshot (with or without a trailing slash), produce: --- --- * A HasFS at the snapshot directory -pathToHasFS :: FilePath -> SomeHasFS IO -pathToHasFS (maybeRemoveTrailingSlash -> path) = - SomeHasFS $ ioHasFS $ MountPoint path - -maybeRemoveTrailingSlash :: String -> String -maybeRemoveTrailingSlash s = case last s of - '/' -> init s - '\\' -> init s - _ -> s - -defaultLMDBLimits :: V1.LMDBLimits -defaultLMDBLimits = - V1.LMDBLimits - { V1.lmdbMapSize = 16 * 1024 * 1024 * 1024 - , V1.lmdbMaxDatabases = 10 - , V1.lmdbMaxReaders = 16 - } diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 399435917f..d5fa35d80b 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -179,6 +179,39 @@ library validation, vector-map, +library snapshot-conversion + import: common-lib + visibility: public + hs-source-dirs: src/snapshot-conversion + other-modules: + Ouroboros.Consensus.Cardano.StreamingLedgerTables + exposed-modules: + Ouroboros.Consensus.Cardano.SnapshotConversion + build-depends: + ansi-terminal, + base, + cardano-ledger-binary, + cardano-ledger-core, + cardano-ledger-shelley, + cborg, + directory, + filepath, + fs-api, + microlens, + mtl, + optparse-applicative, + ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm}, + ouroboros-consensus-cardano, + random, + resource-registry, + serialise, + sop-core, + sop-extras, + strict-sop-core, + terminal-progress-bar, + text, + + library unstable-byronspec import: common-lib visibility: public @@ -695,35 +728,15 @@ executable immdb-server executable snapshot-converter import: common-exe hs-source-dirs: app - other-modules: - Ouroboros.Consensus.Cardano.StreamingLedgerTables main-is: snapshot-converter.hs build-depends: - ansi-terminal, base, cardano-crypto-class, - cardano-ledger-binary, - cardano-ledger-core, - cardano-ledger-shelley, - cborg, - directory, - filepath, - fs-api, - microlens, mtl, optparse-applicative, - ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm}, - ouroboros-consensus-cardano, - ouroboros-consensus-cardano:unstable-cardano-tools, - random, - resource-registry, - serialise, - sop-core, - sop-extras, - strict-sop-core, - terminal-progress-bar, - text, + ouroboros-consensus, + ouroboros-consensus-cardano:{unstable-cardano-tools, ouroboros-consensus-cardano, snapshot-conversion}, with-utf8, other-modules: diff --git a/ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/SnapshotConversion.hs b/ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/SnapshotConversion.hs new file mode 100644 index 0000000000..335266c575 --- /dev/null +++ b/ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/SnapshotConversion.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Convert snapshots among different formats. This is exposed in +-- @cardano-node@ as a subcommand and also via the @snapshot-converter@ +-- executable. +module Ouroboros.Consensus.Cardano.SnapshotConversion + ( Format (..) + , parseFormat + , convertSnapshot + ) where + +import Codec.Serialise +import Control.Monad (when) +import qualified Control.Monad as Monad +import Control.Monad.Except +import Control.Monad.Trans (lift) +import Control.ResourceRegistry +import Data.Bifunctor +import Data.Char (toLower) +import qualified Data.Text.Lazy as T +import Options.Applicative +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.Node () +import Ouroboros.Consensus.Cardano.StreamingLedgerTables +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Ledger.Basics +import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Storage.LedgerDB.API +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as V1 +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM +import Ouroboros.Consensus.Util.CRC +import Ouroboros.Consensus.Util.IOLike hiding (yield) +import System.Console.ANSI +import qualified System.Directory as D +import System.FS.API +import System.FS.CRC +import System.FS.IO +import System.FilePath (splitDirectories) +import qualified System.FilePath as F +import System.IO +import System.ProgressBar +import System.Random + +data Format + = Mem FilePath + | LMDB FilePath + | LSM FilePath FilePath + deriving (Show, Read) + +{------------------------------------------------------------------------------- + Optparse +-------------------------------------------------------------------------------} + +inoutForHelp :: String -> Bool -> String +inoutForHelp s b = + mconcat $ + ("Output " <> s) + : if b + then + [ ". Must be a filepath where the last fragment is named after the " + , "slot of the snapshotted state plus an optional suffix. Example: `1645330287_suffix`." + ] + else [] + +parsePath :: String -> String -> Parser FilePath +parsePath optName strHelp = + strOption + ( mconcat + [ long optName + , help strHelp + , metavar "PATH" + ] + ) + +parseFormat :: Parser Format +parseFormat = + ( Mem + <$> (parsePath "mem-out" (inoutForHelp "snapshot dir" True)) + ) + <|> ( LMDB + <$> (parsePath "lmdb-out" (inoutForHelp "snapshot dir" True)) + ) + <|> ( LSM + <$> (parsePath "lsm-snapshot-out" (inoutForHelp "snapshot dir" True)) + <*> (parsePath "lsm-database-out" (inoutForHelp "LSM database" False)) + ) + +{------------------------------------------------------------------------------- + Errors +-------------------------------------------------------------------------------} + +data Error blk + = SnapshotError (SnapshotFailure blk) + | BadDirectoryName FilePath + | WrongSlotDirectoryName FilePath SlotNo + | InvalidMetadata String + | BackendMismatch SnapshotBackend SnapshotBackend + | CRCMismatch CRC CRC + | ReadTablesError DeserialiseFailure + | Cancelled + deriving Exception + +instance StandardHash blk => Show (Error blk) where + show (SnapshotError err) = + "Couldn't deserialize the snapshot. Are you running the same node version that created the snapshot? " + <> show err + show (BadDirectoryName fp) = + mconcat + [ "Filepath " + , fp + , " is not an snapshot. The last fragment on the path should be" + , " named after the slot number of the state it contains and an" + , " optional suffix, such as `163470034` or `163470034_my-suffix`." + ] + show (InvalidMetadata s) = "Metadata is invalid: " <> s + show (BackendMismatch b1 b2) = + mconcat + [ "Mismatched backend in snapshot. Reading as " + , show b1 + , " but snapshot is " + , show b2 + ] + show (WrongSlotDirectoryName fp sl) = + mconcat + [ "The name of the snapshot (\"" + , fp + , "\") does not correspond to the slot number of the state (" + , (show . unSlotNo $ sl) + , ")." + ] + show (CRCMismatch c1 c2) = + mconcat + [ "The input snapshot seems corrupted. Metadata has CRC " + , show c1 + , " but reading it gives CRC " + , show c2 + ] + show (ReadTablesError df) = + mconcat + ["Error when reading entries in the UTxO tables: ", show df] + show Cancelled = "Cancelled" + +{------------------------------------------------------------------------------- + Environments +-------------------------------------------------------------------------------} + +data InEnv backend = InEnv + { inState :: LedgerState (CardanoBlock StandardCrypto) EmptyMK + -- ^ Ledger state (without tables) that will be used to index the snapshot. + , inFilePath :: FilePath + -- ^ The file path to the LedgerDB snapshot + , inStream :: + LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend YieldArgs) + -- ^ Yield arguments for producing a stream of TxOuts + , inProgressMsg :: String + -- ^ A progress message (just for displaying) + , inCRC :: CRC + -- ^ The CRC of the input @state@ file as read + , inSnapReadCRC :: Maybe CRC + -- ^ The CRC of the input snapshot from the metadata file + } + +data OutEnv backend = OutEnv + { outFilePath :: FilePath + -- ^ The output snapshot directory + , outStream :: + LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend SinkArgs) + -- ^ Sink arguments for consuming a stream of TxOuts + , outDeleteExtra :: Maybe FilePath + -- ^ In case some other directory needs to be wiped out + , outProgressMsg :: String + -- ^ A progress message (just for displaying) + , outBackend :: SnapshotBackend + -- ^ The backend used for the output snapshot, to write it in the metadata + } + +data SomeBackend c where + SomeBackend :: + StreamingBackend IO backend (LedgerState (CardanoBlock StandardCrypto)) => + c IO backend (LedgerState (CardanoBlock StandardCrypto)) -> SomeBackend c + +convertSnapshot :: + Bool -> + ProtocolInfo (CardanoBlock StandardCrypto) -> + Format -> + Format -> + ExceptT (Error (CardanoBlock StandardCrypto)) IO () +convertSnapshot interactive (configCodec . pInfoConfig -> ccfg) from to = do + InEnv{..} <- getInEnv + + o@OutEnv{..} <- getOutEnv inState + + wipeOutputPaths o + + when interactive $ lift $ putStr "Copying state file..." >> hFlush stdout + lift $ D.copyFile (inFilePath F. "state") (outFilePath F. "state") + when interactive $ lift $ putColored Green True "Done" + + when interactive $ lift $ putStr "Streaming ledger tables..." >> hFlush stdout >> saveCursor + + tid <- + if interactive + then lift $ niceAnimatedProgressBar inProgressMsg outProgressMsg + else pure Nothing + + eRes <- lift $ runExceptT (stream inState inStream outStream) + + case eRes of + Left err -> throwError $ ReadTablesError err + Right (mCRCIn, mCRCOut) -> do + lift $ maybe (pure ()) cancel tid + when interactive $ lift $ clearLine >> restoreCursor >> cursorUp 1 >> putColored Green True "Done" + let crcIn = maybe inCRC (crcOfConcat inCRC) mCRCIn + when interactive $ + maybe + ( lift $ + putColored Yellow True "The metadata file is missing, the snapshot is not guaranteed to be correct!" + ) + ( \cs -> + Monad.when (cs /= crcIn) $ throwError $ CRCMismatch cs crcIn + ) + inSnapReadCRC + + let crcOut = maybe inCRC (crcOfConcat inCRC) mCRCOut + + when interactive $ lift $ putStr "Generating new metadata file..." >> hFlush stdout + putMetadata outFilePath (SnapshotMetadata outBackend crcOut TablesCodecVersion1) + + when interactive $ lift $ putColored Green True "Done" + where + wipeOutputPaths OutEnv{..} = do + wipePath interactive outFilePath + maybe + (pure ()) + (wipePath interactive) + outDeleteExtra + + getState fp@(pathToHasFS -> fs) = do + eState <- lift $ do + when interactive $ putStr $ "Reading ledger state from " <> (fp F. "state") <> "..." + when interactive $ hFlush stdout + runExceptT (readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (mkFsPath ["state"])) + case eState of + Left err -> + throwError . SnapshotError . InitFailureRead @(CardanoBlock StandardCrypto) . ReadSnapshotFailed $ + err + Right st -> lift $ do + when interactive $ putColored Green True " Done" + pure . first ledgerState $ st + + -- Metadata management + getMetadata fp bknd = do + (fs, ds) <- toDiskSnapshot fp + mtd <- + lift $ runExceptT $ loadSnapshotMetadata fs ds + (,ds) + <$> either + ( \case + MetadataFileDoesNotExist -> pure Nothing + MetadataInvalid s -> throwError $ InvalidMetadata s + MetadataBackendMismatch -> error "impossible" + ) + ( \mtd' -> do + if bknd /= snapshotBackend mtd' + then throwError $ BackendMismatch bknd (snapshotBackend mtd') + else pure $ Just $ snapshotChecksum mtd' + ) + mtd + + putMetadata fp bknd = do + (fs, ds) <- toDiskSnapshot fp + lift $ writeSnapshotMetadata fs ds bknd + + -- Produce an InEnv from the given arguments + getInEnv = case from of + Mem fp -> do + (mtd, ds) <- getMetadata fp UTxOHDMemSnapshot + (st, c) <- getState fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + ( withOrigin + ( error + "Impossible! the snapshot seems to be at Genesis but cardano-node would never create such an snapshot!" + ) + id + $ pointSlot (getTip st) + ) + ) + + pure $ + InEnv + st + fp + (\a b -> SomeBackend <$> mkInMemYieldArgs (fp F. "tables") a b) + ("InMemory@[" <> fp <> "]") + c + mtd + LMDB fp -> do + (mtd, ds) <- getMetadata fp UTxOHDLMDBSnapshot + (st, c) <- getState fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + + pure $ + InEnv + st + fp + (\a b -> SomeBackend <$> V1.mkLMDBYieldArgs (fp F. "tables") defaultLMDBLimits a b) + ("LMDB@[" <> fp <> "]") + c + mtd + LSM fp lsmDbPath -> do + (mtd, ds) <- getMetadata fp UTxOHDLSMSnapshot + (st, c) <- getState fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + + pure $ + InEnv + st + fp + ( \a b -> + SomeBackend <$> mkLSMYieldArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b + ) + ("LSM@[" <> lsmDbPath <> "]") + c + mtd + + -- Produce an OutEnv from the given arguments + getOutEnv st = case to of + Mem fp -> do + (_, ds) <- toDiskSnapshot fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + pure $ + OutEnv + fp + (\a b -> SomeBackend <$> mkInMemSinkArgs (fp F. "tables") a b) + Nothing + ("InMemory@[" <> fp <> "]") + UTxOHDMemSnapshot + LMDB fp -> do + (_, ds) <- toDiskSnapshot fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + pure $ + OutEnv + fp + (\a b -> SomeBackend <$> V1.mkLMDBSinkArgs fp defaultLMDBLimits a b) + Nothing + ("LMDB@[" <> fp <> "]") + UTxOHDLMDBSnapshot + LSM fp lsmDbPath -> do + (_, ds) <- toDiskSnapshot fp + Monad.when + ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds)) + ( throwError $ + WrongSlotDirectoryName + (snapshotToDirName ds) + (withOrigin undefined id $ pointSlot (getTip st)) + ) + pure $ + OutEnv + fp + ( \a b -> + SomeBackend <$> mkLSMSinkArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b + ) + (Just lsmDbPath) + ("LSM@[" <> lsmDbPath <> "]") + UTxOHDLSMSnapshot + + stream :: + LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend YieldArgs) + ) -> + ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend SinkArgs) + ) -> + ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC) + stream st mYieldArgs mSinkArgs = + ExceptT $ + withRegistry $ \reg -> do + (SomeBackend (yArgs :: YieldArgs IO backend1 l)) <- mYieldArgs st reg + (SomeBackend (sArgs :: SinkArgs IO backend2 l)) <- mSinkArgs st reg + runExceptT $ yield (Proxy @backend1) yArgs st $ sink (Proxy @backend2) sArgs st + +{------------------------------------------------------------------------------- + User interaction +-------------------------------------------------------------------------------} + +niceAnimatedProgressBar :: String -> String -> IO (Maybe (Async IO ())) +niceAnimatedProgressBar inMsg outMsg = do + stdoutSupportsANSI <- hNowSupportsANSI stdout + if stdoutSupportsANSI + then do + putStrLn "" + pb <- + newProgressBar + defStyle{stylePrefix = msg (T.pack inMsg), stylePostfix = msg (T.pack outMsg)} + 10 + (Progress 1 100 ()) + + fmap Just $ + async $ + let loop = do + threadDelay 0.2 + updateProgress pb (\prg -> prg{progressDone = (progressDone prg + 4) `mod` 100}) + in Monad.forever loop + else pure Nothing + +putColored :: Color -> Bool -> String -> IO () +putColored c b s = do + stdoutSupportsANSI <- hNowSupportsANSI stdout + Monad.when stdoutSupportsANSI $ setSGR [SetColor Foreground Vivid c] + if b + then + putStrLn s + else + putStr s + Monad.when stdoutSupportsANSI $ setSGR [Reset] + hFlush stdout + +askForConfirmation :: + Bool -> + ExceptT (Error (CardanoBlock StandardCrypto)) IO a -> + String -> + ExceptT (Error (CardanoBlock StandardCrypto)) IO a +askForConfirmation False act _ = act +askForConfirmation True act infoMsg = do + lift $ putColored Yellow False $ "I'm going to " <> infoMsg <> ". Continue? (Y/n) " + answer <- lift $ getLine + case map toLower answer of + "y" -> act + _ -> throwError Cancelled + +-- | Ask before deleting +wipePath :: Bool -> FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO () +wipePath interactive fp = do + exists <- lift $ D.doesDirectoryExist fp + ( if exists + then flip (askForConfirmation interactive) ("wipe the path " <> fp) + else id + ) + (lift $ D.removePathForcibly fp >> D.createDirectoryIfMissing True fp) + +{------------------------------------------------------------------------------- + Helpers +-------------------------------------------------------------------------------} +toDiskSnapshot :: + FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO (SomeHasFS IO, DiskSnapshot) +toDiskSnapshot fp@(F.splitFileName . maybeRemoveTrailingSlash -> (snapPath, snapName)) = + maybe + (throwError $ BadDirectoryName fp) + (pure . (pathToHasFS snapPath,)) + $ snapshotFromPath snapName + +-- | Given a filepath pointing to a snapshot (with or without a trailing slash), produce: +-- +-- * A HasFS at the snapshot directory +pathToHasFS :: FilePath -> SomeHasFS IO +pathToHasFS (maybeRemoveTrailingSlash -> path) = + SomeHasFS $ ioHasFS $ MountPoint path + +maybeRemoveTrailingSlash :: String -> String +maybeRemoveTrailingSlash s = case last s of + '/' -> init s + '\\' -> init s + _ -> s + +defaultLMDBLimits :: V1.LMDBLimits +defaultLMDBLimits = + V1.LMDBLimits + { V1.lmdbMapSize = 16 * 1024 * 1024 * 1024 + , V1.lmdbMaxDatabases = 10 + , V1.lmdbMaxReaders = 16 + } diff --git a/ouroboros-consensus-cardano/app/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs b/ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs similarity index 100% rename from ouroboros-consensus-cardano/app/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs rename to ouroboros-consensus-cardano/src/snapshot-conversion/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs