Canonical snapshots

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs

@@ -214,6 +214,48 @@ instance
       toPlainEncoding (eraProtVerLow @era) $
         encodeMap encodeMemPack (eliminateCardanoTxOut (const encodeMemPack)) tbs
 
+  encodeTxInWithHint (HardForkLedgerState (HardForkState idx)) txin =
+    let
+      -- These could be made into a CAF to avoid recomputing it, but
+      -- it is only used in serialization so it is not critical.
+      np =
+        (Fn $ const $ K $ Codec.CBOR.Encoding.encodeMapLen 0)
+          :* (Fn $ const $ K $ encOne (Proxy @ShelleyEra))
+          :* (Fn $ const $ K $ encOne (Proxy @AllegraEra))
+          :* (Fn $ const $ K $ encOne (Proxy @MaryEra))
+          :* (Fn $ const $ K $ encOne (Proxy @AlonzoEra))
+          :* (Fn $ const $ K $ encOne (Proxy @BabbageEra))
+          :* (Fn $ const $ K $ encOne (Proxy @ConwayEra))
+          :* (Fn $ const $ K $ encOne (Proxy @DijkstraEra))
+          :* Nil
+     in
+      hcollapse $ hap np $ Telescope.tip idx
+   where
+    encOne :: forall era. Era era => Proxy era -> Encoding
+    encOne _ =
+      toPlainEncoding (eraProtVerLow @era) $ encodeMemPack txin
+
+  encodeTxOutWithHint (HardForkLedgerState (HardForkState idx)) txout =
+    let
+      -- These could be made into a CAF to avoid recomputing it, but
+      -- it is only used in serialization so it is not critical.
+      np =
+        (Fn $ const $ K $ Codec.CBOR.Encoding.encodeMapLen 0)
+          :* (Fn $ const $ K $ encOne (Proxy @ShelleyEra))
+          :* (Fn $ const $ K $ encOne (Proxy @AllegraEra))
+          :* (Fn $ const $ K $ encOne (Proxy @MaryEra))
+          :* (Fn $ const $ K $ encOne (Proxy @AlonzoEra))
+          :* (Fn $ const $ K $ encOne (Proxy @BabbageEra))
+          :* (Fn $ const $ K $ encOne (Proxy @ConwayEra))
+          :* (Fn $ const $ K $ encOne (Proxy @DijkstraEra))
+          :* Nil
+     in
+      hcollapse $ hap np $ Telescope.tip idx
+   where
+    encOne :: forall era. Era era => Proxy era -> Encoding
+    encOne _ =
+      toPlainEncoding (eraProtVerLow @era) $ eliminateCardanoTxOut (const encodeMemPack) txout
+
   decodeTablesWithHint ::
     forall s.
     LedgerState (HardForkBlock (CardanoEras c)) EmptyMK ->

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -367,6 +367,8 @@ instance
   where
   encodeTablesWithHint _ (LedgerTables (ValuesMK tbs)) =
     toPlainEncoding (Core.eraProtVerLow @era) $ encodeMap encodeMemPack encodeMemPack tbs
+  encodeTxInWithHint _ = toPlainEncoding (Core.eraProtVerLow @era) . encodeMemPack
+  encodeTxOutWithHint _ = toPlainEncoding (Core.eraProtVerLow @era) . encodeMemPack
   decodeTablesWithHint st =
     let certInterns =
           internsFromMap $

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -503,6 +503,8 @@ instance
     encOne :: Encoding
     encOne = toPlainEncoding (SL.eraProtVerLow @era) $ encodeMap encodeMemPack encodeMemPack tbs
 
+  encodeTxInWithHint _ = toPlainEncoding (SL.eraProtVerLow @era) . encodeMemPack
+  encodeTxOutWithHint _ = toPlainEncoding (SL.eraProtVerLow @era) . encodeMemPack
   decodeTablesWithHint ::
     forall s.
     LedgerState (HardForkBlock '[ShelleyBlock proto era]) EmptyMK ->

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -557,6 +557,34 @@ instance
           )
           tbs
 
+  encodeTxInWithHint (HardForkLedgerState (HardForkState idx)) txin =
+    let
+      np =
+        (Fn $ const $ K $ encOne (Proxy @era1))
+          :* (Fn $ const $ K $ encOne (Proxy @era2))
+          :* Nil
+     in
+      hcollapse $ hap np $ Telescope.tip idx
+   where
+    encOne :: forall era. SL.Era era => Proxy era -> Encoding
+    encOne _ =
+      toPlainEncoding (SL.eraProtVerLow @era) $ encodeMemPack (getShelleyHFCTxIn txin)
+
+  encodeTxOutWithHint (HardForkLedgerState (HardForkState idx)) txout0 =
+    let
+      np =
+        (Fn $ const $ K $ encOne (Proxy @era1))
+          :* (Fn $ const $ K $ encOne (Proxy @era2))
+          :* Nil
+     in
+      hcollapse $ hap np $ Telescope.tip idx
+   where
+    encOne :: forall era. SL.Era era => Proxy era -> Encoding
+    encOne _ =
+      toPlainEncoding (SL.eraProtVerLow @era) $ case txout0 of
+        Z txout -> encodeMemPack $ unwrapTxOut txout
+        S (Z txout) -> encodeMemPack $ unwrapTxOut txout
+
   decodeTablesWithHint ::
     forall s.
     LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2)) EmptyMK ->

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

@@ -75,7 +75,7 @@ openLedgerDB ::
 openLedgerDB args = do
   (ldb, _, od) <- case LedgerDB.lgrBackendArgs args of
     LedgerDB.LedgerDbBackendArgsV1 bss ->
-      let snapManager = LedgerDB.V1.snapshotManager args
+      let snapManager = LedgerDB.V1.snapshotManager args bss
           initDb =
             LedgerDB.V1.mkInitDb
               args
@@ -99,6 +99,11 @@ openLedgerDB args = do
               (configCodec . getExtLedgerCfg . LedgerDB.ledgerDbCfg $ LedgerDB.lgrConfig args)
               (LedgerDBSnapshotEvent >$< LedgerDB.lgrTracer args)
               (LedgerDB.lgrHasFS args)
+              ( flip
+                  LedgerDB.V2.CanonicalSnapshotsFS
+                  (LedgerDB.lgrHasFS args)
+                  <$> LedgerDB.lgrCanonicalSnapshotsFS args
+              )
       let initDb =
             LedgerDB.V2.mkInitDb
               args

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs

@@ -173,11 +173,11 @@ import Ouroboros.Network.Protocol.ChainSync.Codec (timeLimitsChainSync)
 import Ouroboros.Network.RethrowPolicy
 import qualified SafeWildCards
 import System.Exit (ExitCode (..))
-import System.FS.API (SomeHasFS (..), mkFsPath)
+import System.FS.API (SomeHasFS (..))
 import System.FS.API.Types (MountPoint (..))
 import System.FS.IO (ioHasFS)
-import System.FilePath (splitDirectories, (</>))
-import System.Random (StdGen, genWord64, newStdGen, randomIO, split)
+import System.FilePath ((</>))
+import System.Random (StdGen, newStdGen, randomIO, split)
 
 {-------------------------------------------------------------------------------
   The arguments to the Consensus Layer node functionality
@@ -359,6 +359,7 @@ data
   , srnChainDbValidateOverride :: Bool
   -- ^ If @True@, validate the ChainDB on init no matter what
   , srnDatabasePath :: NodeDatabasePaths
+  , srnCanonicalSnapshotsPath :: Maybe FilePath
   -- ^ Location of the DBs
   , srnDiffusionArguments :: Cardano.Diffusion.CardanoNodeArguments m
   , srnDiffusionConfiguration :: Cardano.Diffusion.CardanoConfiguration m
@@ -1050,20 +1051,6 @@ stdLowLevelRunNodeArgsIO
         , llrnPublicPeerSelectionStateVar =
             Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration
         , llrnLdbFlavorArgs = srnLedgerDbBackendArgs
-        -- case srnLedgerDbBackendArgs of
-        --   V1LMDB args -> LedgerDbFlavorArgsV1 args
-        --   V2InMemory -> LedgerDbFlavorArgsV2 (V2.V2Args V2.InMemoryHandleArgs)
-        --   V2LSM path ->
-        --     LedgerDbFlavorArgsV2
-        --       ( V2.V2Args
-        --           ( V2.LSMHandleArgs
-        --               ( V2.LSMArgs
-        --                   (mkFsPath $ splitDirectories path)
-        --                   lsmSalt
-        --                   (LSM.stdMkBlockIOFS (nonImmutableDbPath srnDatabasePath))
-        --               )
-        --           )
-        --       )
         }
    where
     networkMagic :: NetworkMagic
@@ -1076,6 +1063,10 @@ stdLowLevelRunNodeArgsIO
       ChainDB.updateSnapshotPolicyArgs srnSnapshotPolicyArgs
         . ChainDB.updateQueryBatchSize srnQueryBatchSize
         . ChainDB.updateTracer srnTraceChainDB
+        . maybe
+          id
+          (\fp -> ChainDB.enableCanonicalSnapshots (SomeHasFS $ ioHasFS $ MountPoint fp))
+          srnCanonicalSnapshotsPath
         . ( if not srnChainDbValidateOverride
               then id
               else ChainDB.ensureValidateAll

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs

@@ -479,6 +479,8 @@ instance SerialiseHFC '[BlockA, BlockB]
 instance SerializeTablesWithHint (LedgerState (HardForkBlock '[BlockA, BlockB])) where
   encodeTablesWithHint = defaultEncodeTablesWithHint
   decodeTablesWithHint = defaultDecodeTablesWithHint
+  encodeTxInWithHint = defaultEncodeMemPackWithHint
+  encodeTxOutWithHint = defaultEncodeMemPackWithHint
 
 instance
   IndexedMemPack

ouroboros-consensus/ouroboros-consensus.cabal

@@ -373,6 +373,7 @@ library ouroboros-consensus-lsm
     Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
 
   build-depends:
+    FailT,
     base >=4.14 && <4.22,
     blockio,
     cardano-binary,

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

@@ -22,6 +22,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB
   , Backend (..)
   , Args (LMDBBackingStoreArgs)
   , LMDBLimits (LMDBLimits, lmdbMapSize, lmdbMaxDatabases, lmdbMaxReaders)
+  , mkLMDBArgs
 
     -- * Streaming
   , YieldArgs (YieldLMDB)
@@ -64,9 +65,11 @@ import Ouroboros.Consensus.Ledger.Basics
 import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
 import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables)
 import Ouroboros.Consensus.Storage.LedgerDB.API
+import Ouroboros.Consensus.Storage.LedgerDB.Args
 import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
   ( SnapshotBackend (..)
   )
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
 import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API as API
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Bridge as Bridge
@@ -842,6 +845,20 @@ instance
       limits
       (LiveLMDBFS $ FS.SomeHasFS $ ioHasFS $ FS.MountPoint fs)
 
+-- | Create arguments for initializing the LedgerDB using the LMDB backend.
+mkLMDBArgs ::
+  ( MonadIOPrim m
+  , HasLedgerTables (LedgerState blk)
+  , IOLike m
+  ) =>
+  V1.FlushFrequency -> FilePath -> LMDBLimits -> a -> (LedgerDbBackendArgs m blk, a)
+mkLMDBArgs flushing lmdbPath limits =
+  (,) $
+    LedgerDbBackendArgsV1 $
+      V1.V1Args flushing $
+        SomeBackendArgs $
+          LMDBBackingStoreArgs lmdbPath limits Dict.Dict
+
 class (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m
 instance (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m
 
@@ -981,3 +998,6 @@ mkLMDBSinkArgs fp limits hint reg = do
       )
       bsClose
   pure $ SinkLMDB 1000 (bsWrite bs) (\h -> bsCopy bs h (FS.mkFsPath [snapName, "tables"]))
+
+instance (Ord (TxIn l), GetTip l, Monad m) => StreamingBackendV1 m LMDB l where
+  yieldV1 _ vh = yield (Proxy @LMDB) (YieldLMDB 1000 vh)

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

@@ -71,20 +71,23 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol
 import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
 import Ouroboros.Consensus.Ledger.Tables.Utils
 import Ouroboros.Consensus.Storage.LedgerDB.API
+import Ouroboros.Consensus.Storage.LedgerDB.Args
 import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
 import Ouroboros.Consensus.Storage.LedgerDB.V2
 import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend
+import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
 import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
 import Ouroboros.Consensus.Util (chunks)
 import Ouroboros.Consensus.Util.CRC
 import Ouroboros.Consensus.Util.Enclose
-import Ouroboros.Consensus.Util.IOLike
+import Ouroboros.Consensus.Util.IOLike hiding (yield)
 import Ouroboros.Consensus.Util.IndexedMemPack
 import qualified Streaming as S
 import qualified Streaming.Prelude as S
 import System.FS.API
 import qualified System.FS.BlockIO.API as BIO
 import System.FS.BlockIO.IO
+import System.FS.CRC
 import System.FilePath (splitDirectories, splitFileName)
 import System.Random
 import Prelude hiding (read)
@@ -198,12 +201,13 @@ snapshotManager ::
   CodecConfig blk ->
   Tracer m (TraceSnapshotEvent blk) ->
   SomeHasFS m ->
+  Maybe (CanonicalSnapshotsFS m) ->
   SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
-snapshotManager session ccfg tracer fs =
+snapshotManager session ccfg tracer fs mCanonical =
   SnapshotManager
     { listSnapshots = defaultListSnapshots fs
     , deleteSnapshot = implDeleteSnapshot session fs tracer
-    , takeSnapshot = implTakeSnapshot ccfg tracer fs
+    , takeSnapshot = implTakeSnapshot ccfg tracer fs mCanonical
     }
 
 newLSMLedgerTablesHandle ::
@@ -329,30 +333,43 @@ implTakeSnapshot ::
   CodecConfig blk ->
   Tracer m (TraceSnapshotEvent blk) ->
   SomeHasFS m ->
+  Maybe (CanonicalSnapshotsFS m) ->
   Maybe String ->
   StateRef m (ExtLedgerState blk) ->
   m (Maybe (DiskSnapshot, RealPoint blk))
-implTakeSnapshot ccfg tracer hasFS suffix st = case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of
-  Origin -> return Nothing
-  NotOrigin t -> do
-    let number = unSlotNo (realPointSlot t)
-        snapshot = DiskSnapshot number suffix
-    diskSnapshots <- defaultListSnapshots hasFS
-    if List.any (== DiskSnapshot number suffix) diskSnapshots
-      then
-        return Nothing
-      else do
-        encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
-          writeSnapshot hasFS (encodeDiskExtLedgerState ccfg) snapshot st
-        return $ Just (snapshot, t)
+implTakeSnapshot ccfg tracer shfs mCanonicalFS suffix st =
+  case pointToWithOriginRealPoint (castPoint (getTip $ state st)) of
+    Origin -> return Nothing
+    NotOrigin t -> do
+      let number = unSlotNo (realPointSlot t)
+          snapshot = DiskSnapshot number suffix
+      diskSnapshots <- defaultListSnapshots shfs
+      if List.any (== DiskSnapshot number suffix) diskSnapshots
+        then
+          return Nothing
+        else do
+          stateCRC <-
+            encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
+              writeSnapshot shfs (encodeDiskExtLedgerState ccfg) snapshot st
+          takeCanonicalSnapshot
+            (($ t) >$< tracer)
+            snapshot
+            (duplicate (tables st))
+            close
+            (\hdl -> yield (Proxy @LSM) (YieldLSM 1000 hdl) (state st))
+            (state st)
+            stateCRC
+            mCanonicalFS
+
+          return $ Just (snapshot, t)
 
 writeSnapshot ::
   MonadThrow m =>
   SomeHasFS m ->
   (ExtLedgerState blk EmptyMK -> Encoding) ->
   DiskSnapshot ->
   StateRef m (ExtLedgerState blk) ->
-  m ()
+  m CRC
 writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
   createDirectoryIfMissing hasFs True $ snapshotToDirPath ds
   crc1 <- writeExtLedgerState fs encLedger (snapshotToStatePath ds) $ state st
@@ -363,6 +380,7 @@ writeSnapshot fs@(SomeHasFS hasFs) encLedger ds st = do
       , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2
       , snapshotTablesCodecVersion = TablesCodecVersion1
       }
+  pure crc1
 
 -- | Delete snapshot from disk and also from the LSM tree database.
 implDeleteSnapshot ::
@@ -448,10 +466,19 @@ stdMkBlockIOFS fastStoragePath rr = do
 
 data LSM
 
-mkLSMArgs :: FilePath -> StdGen -> FilePath -> (Args IO LSM, StdGen)
-mkLSMArgs fp gen fastStorage =
+-- | Create arguments for initializing the LedgerDB using the LSM-trees backend.
+mkLSMArgs ::
+  ( LedgerSupportsProtocol blk
+  , LedgerDbSerialiseConstraints blk
+  ) =>
+  Proxy blk -> FilePath -> FilePath -> StdGen -> (LedgerDbBackendArgs IO blk, StdGen)
+mkLSMArgs _ fp fastStorage gen =
   let (lsmSalt, gen') = genWord64 gen
-   in (LSMArgs (mkFsPath $ splitDirectories fp) lsmSalt (stdMkBlockIOFS fastStorage), gen')
+   in ( LedgerDbBackendArgsV2 $
+          SomeBackendArgs $
+            LSMArgs (mkFsPath $ splitDirectories fp) lsmSalt (stdMkBlockIOFS fastStorage)
+      , gen'
+      )
 
 instance
   ( LedgerSupportsProtocol blk

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs

@@ -1122,6 +1122,8 @@ instance
   where
   encodeTablesWithHint = defaultEncodeTablesWithHint
   decodeTablesWithHint = defaultDecodeTablesWithHint
+  encodeTxInWithHint = defaultEncodeMemPackWithHint
+  encodeTxOutWithHint = defaultEncodeMemPackWithHint
 
 instance
   ( Bridge m a

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs

@@ -383,4 +383,6 @@ instance
 
 instance SerializeTablesWithHint (LedgerState blk) => SerializeTablesWithHint (ExtLedgerState blk) where
   decodeTablesWithHint st = castLedgerTables <$> decodeTablesWithHint (ledgerState st)
+  encodeTxInWithHint st = encodeTxInWithHint (ledgerState st)
+  encodeTxOutWithHint st = encodeTxOutWithHint (ledgerState st)
   encodeTablesWithHint st tbs = encodeTablesWithHint (ledgerState st) (castLedgerTables tbs)