Implement LSM-trees based ledger tables handles in LedgerDB V2

Author: jasagredo

cabal.project

@@ -14,7 +14,7 @@ repository cardano-haskell-packages
 -- update either of these.
 index-state:
   -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2025-07-22T09:13:54Z
+  , hackage.haskell.org 2025-08-07T11:24:08Z
   -- Bump this if you need newer packages from CHaP
   , cardano-haskell-packages 2025-08-21T09:41:03Z
 
@@ -56,6 +56,11 @@ allow-newer:
     , fin:QuickCheck
     , bin:QuickCheck
 
+if impl (ghc >= 9.10)
+  allow-newer:
+    -- https://github.com/phadej/regression-simple/pull/14
+    , regression-simple:base
+
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/cardano-ledger
@@ -90,3 +95,10 @@ constraints:
   plutus-core < 1.51,
   plutus-ledger-api < 1.51,
   plutus-tx < 1.51,
+
+if os (windows)
+  source-repository-package
+    type: git
+    location: https://github.com/jasagredo/digest
+    tag: 329fc2a911878ffe47472751cb40aae20ab2c00a
+    --sha256: sha256-84f8dFee9EfWbQ5UTLZ9MrsZ3JVojNhzfTGmWof6wHU=

nix/haskell.nix

@@ -89,9 +89,13 @@ in
     nativeBuildInputs = [
       final.fd
       final.cabal-docspec
-      (hsPkgs.ghcWithPackages
-        (ps: [ ps.latex-svg-image ] ++ lib.filter (p: p ? components.library)
-          (lib.attrValues (haskell-nix.haskellLib.selectProjectPackages ps))))
+      (hsPkgs.shellFor {
+        withHoogle = false;
+        exactDeps = true;
+        packages = _: [ ];
+        additional = (ps: [ ps.latex-svg-image ] ++ lib.filter (p: p ? components.library)
+          (lib.attrValues (haskell-nix.haskellLib.selectProjectPackages ps)));
+      }).ghc
       final.texliveFull
     ];
 

ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs

@@ -46,7 +46,7 @@ parseDBAnalyserConfig =
       [ flag' V1InMem $
           mconcat
             [ long "v1-in-mem"
-            , help "use v1 in-memory backing store"
+            , help "use v1 in-memory backing store [deprecated]"
             ]
       , flag' V1LMDB $
           mconcat
@@ -55,9 +55,14 @@ parseDBAnalyserConfig =
             ]
       , flag' V2InMem $
           mconcat
-            [ long "v2-in-mem"
+            [ long "in-mem"
             , help "use v2 in-memory backend"
             ]
+      , flag' V2LSM $
+          mconcat
+            [ long "lsm"
+            , help "use v2 LSM backend"
+            ]
       ]
 
 parseSelectDB :: Parser SelectDB

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

@@ -38,6 +38,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Lock as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq as V2
 import Ouroboros.Consensus.Util.CRC
@@ -199,7 +200,7 @@ load config@Config{inpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS), pa
       checkSnapshotFileStructure Mem path fs
       (ls, _) <- withExceptT SnapshotError $ V2.loadSnapshot nullTracer rr ccfg fs ds
       let h = V2.currentHandle ls
-      (V2.state h,) <$> Trans.lift (V2.readAll (V2.tables h))
+      (V2.state h,) <$> Trans.lift (V2.readAll (V2.tables h) (V2.state h))
     LMDB -> do
       checkSnapshotFileStructure LMDB path fs
       ((dbch, k, bstore), _) <-
@@ -240,7 +241,7 @@ store config@Config{outpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS),
     Mem -> do
       lseq <- V2.empty state tbs $ V2.newInMemoryLedgerTablesHandle nullTracer fs
       let h = V2.currentHandle lseq
-      Monad.void $ V2.implTakeSnapshot ccfg nullTracer fs suffix h
+      Monad.void $ InMemory.implTakeSnapshot ccfg nullTracer fs suffix h
     LMDB -> do
       chlog <- newTVarIO (V1.empty state)
       lock <- V1.mkLedgerDBLock

ouroboros-consensus-cardano/changelog.d/20250729_124022_javier.sagredo_lsm1.md

@@ -0,0 +1,25 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -588,6 +588,7 @@ library unstable-cardano-tools
     ouroboros-network-api,
     ouroboros-network-framework ^>=0.19,
     ouroboros-network-protocols,
+    random,
     resource-registry,
     singletons,
     sop-core,

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

@@ -10,7 +10,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -429,16 +428,14 @@ instance
     { getShelleyBlockHFCTxIn :: SL.TxIn
     }
     deriving stock (Show, Eq, Ord)
-    deriving newtype NoThunks
+    deriving newtype (NoThunks, MemPack)
 
   injectCanonicalTxIn IZ txIn = ShelleyBlockHFCTxIn txIn
   injectCanonicalTxIn (IS idx') _ = case idx' of {}
 
   ejectCanonicalTxIn IZ txIn = getShelleyBlockHFCTxIn txIn
   ejectCanonicalTxIn (IS idx') _ = case idx' of {}
 
-deriving newtype instance MemPack (CanonicalTxIn '[ShelleyBlock proto era])
-
 {-------------------------------------------------------------------------------
   HardForkTxOut
 -------------------------------------------------------------------------------}

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

@@ -12,7 +12,6 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -498,7 +497,7 @@ instance
     { getShelleyHFCTxIn :: SL.TxIn
     }
     deriving stock (Show, Eq, Ord)
-    deriving newtype NoThunks
+    deriving newtype (NoThunks, MemPack)
 
   injectCanonicalTxIn IZ txIn = ShelleyHFCTxIn txIn
   injectCanonicalTxIn (IS IZ) txIn = ShelleyHFCTxIn (coerce txIn)
@@ -508,10 +507,6 @@ instance
   ejectCanonicalTxIn (IS IZ) txIn = coerce (getShelleyHFCTxIn txIn)
   ejectCanonicalTxIn (IS (IS idx')) _ = case idx' of {}
 
-deriving newtype instance
-  ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =>
-  MemPack (CanonicalTxIn (ShelleyBasedHardForkEras proto1 era1 proto2 era2))
-
 instance
   ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =>
   HasHardForkTxOut (ShelleyBasedHardForkEras proto1 era1 proto2 era2)

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

@@ -15,9 +15,9 @@ import Cardano.Tools.DBAnalyser.HasAnalysis
 import Cardano.Tools.DBAnalyser.Types
 import Control.ResourceRegistry
 import Control.Tracer (Tracer (..), nullTracer)
+import Data.Functor.Contravariant ((>$<))
 import qualified Data.SOP.Dict as Dict
 import Data.Singletons (Sing, SingI (..))
-import Data.Void
 import qualified Debug.Trace as Debug
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
@@ -35,19 +35,24 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB
+import Ouroboros.Consensus.Storage.LedgerDB (TraceEvent (..))
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as LedgerDB.V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
-import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as LedgerDB.V1
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB.V2
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
 import Ouroboros.Consensus.Util.Args
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.Orphans ()
 import Ouroboros.Network.Block (genesisPoint)
+import System.FS.API
 import System.IO
+import System.Random
 import Text.Printf (printf)
 
 {-------------------------------------------------------------------------------
@@ -66,7 +71,7 @@ openLedgerDB ::
     , LedgerDB.TestInternals' IO blk
     )
 openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV1 bss} = do
-  let snapManager = LedgerDB.V1.snapshotManager lgrDbArgs
+  let snapManager = V1.snapshotManager lgrDbArgs
   (ledgerDB, _, intLedgerDB) <-
     LedgerDB.openDBInternal
       lgrDbArgs
@@ -82,8 +87,27 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.L
   pure (ledgerDB, intLedgerDB)
 openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV2 args} = do
   (snapManager, bss') <- case args of
-    LedgerDB.V2.V2Args LedgerDB.V2.InMemoryHandleArgs -> pure (InMemory.snapshotManager lgrDbArgs, LedgerDB.V2.InMemoryHandleEnv)
-    LedgerDB.V2.V2Args (LedgerDB.V2.LSMHandleArgs (LedgerDB.V2.LSMArgs x)) -> absurd x
+    V2.V2Args V2.InMemoryHandleArgs -> pure (InMemory.snapshotManager lgrDbArgs, V2.InMemoryHandleEnv)
+    V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path salt mkFS)) -> do
+      (rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (LedgerDB.lgrRegistry lgrDbArgs)
+      session <-
+        allocate
+          (LedgerDB.lgrRegistry lgrDbArgs)
+          ( \_ ->
+              LSM.openSession
+                ( LedgerDBFlavorImplEvent . LedgerDB.FlavorImplSpecificTraceV2 . V2.LSMTrace
+                    >$< LedgerDB.lgrTracer lgrDbArgs
+                )
+                fs'
+                blockio
+                salt
+                path
+          )
+          LSM.closeSession
+      pure
+        ( LSM.snapshotManager (snd session) lgrDbArgs
+        , V2.LSMHandleEnv (V2.LSMResources (fst session) (snd session) rk1)
+        )
   (ledgerDB, _, intLedgerDB) <-
     LedgerDB.openDBInternal
       lgrDbArgs
@@ -126,6 +150,7 @@ analyse dbaConfig args =
     lock <- newMVar ()
     chainDBTracer <- mkTracer lock verbose
     analysisTracer <- mkTracer lock True
+    lsmSalt <- fst . genWord64 <$> newStdGen
     ProtocolInfo{pInfoInitLedger = genesisLedger, pInfoConfig = cfg} <-
       mkProtocolInfo args
     let shfs = Node.stdMkChainDbHasFS dbDir
@@ -150,6 +175,13 @@ analyse dbaConfig args =
           V2InMem ->
             LedgerDB.LedgerDbFlavorArgsV2
               (LedgerDB.V2.V2Args LedgerDB.V2.InMemoryHandleArgs)
+          V2LSM ->
+            LedgerDB.LedgerDbFlavorArgsV2
+              ( LedgerDB.V2.V2Args
+                  ( LedgerDB.V2.LSMHandleArgs
+                      (LedgerDB.V2.LSMArgs (mkFsPath ["lsm"]) lsmSalt (LSM.stdMkBlockIOFS dbDir))
+                  )
+              )
         args' =
           ChainDB.completeChainDbArgs
             registry

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

@@ -49,7 +49,7 @@ newtype NumberOfBlocks = NumberOfBlocks {unNumberOfBlocks :: Word64}
 
 data Limit = Limit Int | Unlimited
 
-data LedgerDBBackend = V1InMem | V1LMDB | V2InMem
+data LedgerDBBackend = V1InMem | V1LMDB | V2InMem | V2LSM
 
 -- | The extent of the ChainDB on-disk files validation. This is completely
 -- unrelated to validation of the ledger rules.