Expose hidden entities and small tweaks for integrating LSM-trees into the node

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-09-26T20:57:57Z
+  , hackage.haskell.org 2025-10-23T13:39:53Z
   -- Bump this if you need newer packages from CHaP
   , cardano-haskell-packages 2025-10-01T14:54:25Z
 

ouroboros-consensus-diffusion/changelog.d/20251023_152349_javier.sagredo_fix_resource_registry.md

@@ -0,0 +1,23 @@
+<!--
+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
+
+- Bump to `resource-registry ^>= 0.2`.
+
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus-diffusion/changelog.d/20251023_154349_javier.sagredo_expose_for_node.md

@@ -0,0 +1,23 @@
+<!--
+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
+
+- `srnLedgerDbBackendArgs` now receives and returns a `StdGen` argument.

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -95,7 +95,7 @@ library
     ouroboros-network-framework ^>=0.19,
     ouroboros-network-protocols ^>=0.15,
     random,
-    resource-registry ^>=0.1,
+    resource-registry ^>=0.2,
     safe-wild-cards ^>=1.0,
     serialise ^>=0.2,
     text,

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

@@ -43,6 +43,8 @@ module Ouroboros.Consensus.Node
   , LowLevelRunNodeArgs (..)
   , MempoolCapacityBytesOverride (..)
   , NodeDatabasePaths (..)
+  , immutableDbPath
+  , nonImmutableDbPath
   , NodeKernel (..)
   , NodeKernelArgs (..)
   , ProtocolInfo (..)
@@ -376,7 +378,10 @@ data
   , -- Ad hoc values to replace default ChainDB configurations
     srnSnapshotPolicyArgs :: SnapshotPolicyArgs
   , srnQueryBatchSize :: QueryBatchSize
-  , srnLedgerDbBackendArgs :: LedgerDbBackendArgs m blk
+  , srnLedgerDbBackendArgs :: (StdGen -> (LedgerDbBackendArgs m blk, StdGen))
+  -- ^ The 'StdGen' will be used to initialize the salt for the LSM backend. It
+  -- is expected that it is the same 'StdGen' that is passed elsewhere in
+  -- Consensus, i.e. 'llrnRng'.
   }
 
 {-------------------------------------------------------------------------------
@@ -1005,7 +1010,7 @@ stdLowLevelRunNodeArgsIO
     }
   $(SafeWildCards.fields 'StdRunNodeArgs) = do
     llrnBfcSalt <- stdBfcSaltIO
-    llrnRng <- newStdGen
+    (ldbBackendArgs, llrnRng) <- srnLedgerDbBackendArgs <$> newStdGen
     pure
       LowLevelRunNodeArgs
         { llrnBfcSalt
@@ -1050,7 +1055,7 @@ stdLowLevelRunNodeArgsIO
             InFutureCheck.defaultClockSkew
         , llrnPublicPeerSelectionStateVar =
             Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration
-        , llrnLdbFlavorArgs = srnLedgerDbBackendArgs
+        , llrnLdbFlavorArgs = ldbBackendArgs
         }
    where
     networkMagic :: NetworkMagic

ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs

@@ -1158,7 +1158,7 @@ runThreadNetwork
           mempool
           txs0
 
-      void $ allocate registry (\_ -> pure threadCrucialTxs) cancelThread
+      void $ allocateThread registry (\_ -> pure threadCrucialTxs)
 
       forkTxProducer
         coreNodeId

ouroboros-consensus/changelog.d/20251023_152234_javier.sagredo_fix_resource_registry.md

@@ -0,0 +1,22 @@
+<!--
+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
+
+- Bump to `resource-registry ^>= 0.2`.
+
+### Non-Breaking
+
+- Committing a forker will move the handles to the registry of the LedgerDB. The
+  discarded fork will be queued to be released by the `garbageCollect` logic.
+
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus/changelog.d/20251023_154344_javier.sagredo_expose_for_node.md

@@ -0,0 +1,18 @@
+<!--
+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
+
+- LSM-trees database directory is now created on startup.
+
+### Non-Breaking
+
+- Expose `Ouroboros.Consensus.Storage.LedgerDB.(V1.BackingStore|V2).Backend(Trace)` constructors.
+
+### Breaking
+
+- `Ouroboros.Consensus.Storage.LedgerDB.(V1.BackingStore|V2).Backend(Trace)` no longer depends on the running monad `m`.

ouroboros-consensus/changelog.d/20251029_113308_javier.sagredo_fix_mempool_dangling_forker.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
+
+- The Mempool sync thread was allocated in the top level registry in order to
+  ensure it would be cancelled before the mempool registry was shutting
+  down. This was solved in `resource-registry-0.2.0.0`.
+
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus/ouroboros-consensus.cabal

@@ -344,7 +344,7 @@ library
     psqueues ^>=0.2.3,
     quiet ^>=0.2,
     rawlock ^>=0.1.1,
-    resource-registry ^>=0.1,
+    resource-registry ^>=0.2,
     semialign >=1.1,
     serialise ^>=0.2,
     singletons,
@@ -393,7 +393,7 @@ library ouroboros-consensus-lsm
     ouroboros-consensus,
     primitive,
     random,
-    resource-registry ^>=0.1,
+    resource-registry ^>=0.2,
     serialise ^>=0.2,
     streaming,
     text,

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
     LMDB
   , Backend (..)
   , Args (LMDBBackingStoreArgs)
+  , Trace (OnDiskBackingStoreInitialise, OnDiskBackingStoreTrace)
   , LMDBLimits (LMDBLimits, lmdbMapSize, lmdbMaxDatabases, lmdbMaxReaders)
   , mkLMDBArgs
 
@@ -832,7 +833,7 @@ instance
   where
   data Args m LMDB
     = LMDBBackingStoreArgs FilePath LMDBLimits (Dict.Dict MonadIOPrim m)
-  data Trace m LMDB
+  data Trace LMDB
     = OnDiskBackingStoreInitialise LMDB.Limits
     | OnDiskBackingStoreTrace BackingStoreTrace
     deriving (Eq, Show)

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

@@ -25,6 +25,8 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
     LSM
   , Backend (..)
   , Args (LSMArgs)
+  , Trace (LSMTreeTrace)
+  , LSM.LSMTreeTrace (..)
   , mkLSMArgs
   , stdMkBlockIOFS
 
@@ -64,6 +66,7 @@ import Data.Void
 import Database.LSMTree (Salt, Session, Table)
 import qualified Database.LSMTree as LSM
 import GHC.Generics
+import GHC.Stack (HasCallStack)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Ledger.Abstract
@@ -167,21 +170,22 @@ newLSMLedgerTablesHandle ::
   , IndexedMemPack (l EmptyMK) (TxOut l)
   ) =>
   Tracer m LedgerDBV2Trace ->
-  ResourceRegistry m ->
   (ResourceKey m, UTxOTable m) ->
   m (LedgerTablesHandle m l)
-newLSMLedgerTablesHandle tracer rr (resKey, t) = do
+newLSMLedgerTablesHandle tracer (origResKey, t) = do
   traceWith tracer TraceLedgerTablesHandleCreate
+  tv <- newTVarIO origResKey
   pure
     LedgerTablesHandle
-      { close = implClose resKey
-      , duplicate = implDuplicate rr t tracer
+      { close = implClose tv
+      , duplicate = \rr -> implDuplicate rr t tracer
       , read = implRead t
       , readRange = implReadRange t
       , readAll = implReadAll t
       , pushDiffs = implPushDiffs t
       , takeHandleSnapshot = implTakeHandleSnapshot t
       , tablesSize = pure Nothing
+      , transfer = atomically . writeTVar tv
       }
 
 {-# INLINE implClose #-}
@@ -192,8 +196,9 @@ newLSMLedgerTablesHandle tracer rr (resKey, t) = do
 {-# INLINE implPushDiffs #-}
 {-# INLINE implTakeHandleSnapshot #-}
 
-implClose :: IOLike m => ResourceKey m -> m ()
-implClose = Monad.void . release
+implClose :: (HasCallStack, IOLike m) => StrictTVar m (ResourceKey m) -> m ()
+implClose tv =
+  Monad.void $ release =<< readTVarIO tv
 
 implDuplicate ::
   ( IOLike m
@@ -203,17 +208,17 @@ implDuplicate ::
   ResourceRegistry m ->
   UTxOTable m ->
   Tracer m LedgerDBV2Trace ->
-  m (LedgerTablesHandle m l)
+  m (ResourceKey m, LedgerTablesHandle m l)
 implDuplicate rr t tracer = do
-  table <-
+  (rk, table) <-
     allocate
       rr
       (\_ -> LSM.duplicate t)
       ( \t' -> do
           traceWith tracer TraceLedgerTablesHandleClose
           LSM.closeTable t'
       )
-  newLSMLedgerTablesHandle tracer rr table
+  (rk,) <$> newLSMLedgerTablesHandle tracer (rk, table)
 
 implRead ::
   forall m l.
@@ -461,7 +466,7 @@ loadSnapshot tracer rr ccfg fs session ds =
     case pointToWithOriginRealPoint (castPoint (getTip extLedgerSt)) of
       Origin -> throwE InitFailureGenesis
       NotOrigin pt -> do
-        values <-
+        (rk, values) <-
           lift $
             allocate
               rr
@@ -481,7 +486,7 @@ loadSnapshot tracer rr ccfg fs session ds =
           $ InitFailureRead
             ReadSnapshotDataCorruption
         (,pt)
-          <$> lift (empty extLedgerSt values (newLSMLedgerTablesHandle tracer rr))
+          <$> lift (empty extLedgerSt (rk, values) (newLSMLedgerTablesHandle tracer))
 
 -- | Create the initial LSM table from values, which should happen only at
 -- Genesis.
@@ -495,18 +500,16 @@ tableFromValuesMK ::
   LedgerTables l ValuesMK ->
   m (ResourceKey m, UTxOTable m)
 tableFromValuesMK tracer rr session st (LedgerTables (ValuesMK values)) = do
-  res@(_, table) <-
+  (rk, table) <-
     allocate
       rr
-      ( \_ ->
-          LSM.newTableWith (LSM.defaultTableConfig{LSM.confFencePointerIndex = LSM.OrdinaryIndex}) session
-      )
+      (\_ -> LSM.newTable session)
       ( \tb -> do
           traceWith tracer TraceLedgerTablesHandleClose
           LSM.closeTable tb
       )
   mapM_ (go table) $ chunks 1000 $ Map.toList values
-  pure res
+  pure (rk, table)
  where
   go table items =
     LSM.inserts table $
@@ -570,12 +573,13 @@ instance
     }
     deriving Generic
 
-  data Trace m LSM
+  data Trace LSM
     = LSMTreeTrace !LSM.LSMTreeTrace
     deriving Show
 
   mkResources _ trcr (LSMArgs path salt mkFS) reg _ = do
     (rk1, SomeHasFSAndBlockIO fs blockio) <- mkFS reg
+    createDirectoryIfMissing fs True path
     session <-
       allocate
         reg
@@ -600,7 +604,7 @@ instance
   newHandleFromValues trcr reg res st = do
     table <-
       tableFromValuesMK trcr reg (sessionResource res) (forgetLedgerTables st) (ltprj st)
-    newLSMLedgerTablesHandle trcr reg table
+    newLSMLedgerTablesHandle trcr table
 
   snapshotManager _ res = Ouroboros.Consensus.Storage.LedgerDB.V2.LSM.snapshotManager (sessionResource res)
 
@@ -731,7 +735,7 @@ mkLSMYieldArgs fp snapName mkFS mkGen _ reg = do
             (LSM.SnapshotLabel $ T.pack "UTxO table")
       )
       LSM.closeTable
-  YieldLSM 1000 <$> newLSMLedgerTablesHandle nullTracer reg tb
+  YieldLSM 1000 <$> newLSMLedgerTablesHandle nullTracer tb
 
 -- | Create Sink arguments for LSM
 mkLSMSinkArgs ::