LedgerDB.V2: add trace events for opening/closing of handles

For tracking whether we are leaking any handles, in a test to be added in a
follow-up commit

Author: amesgen

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

@@ -198,7 +198,7 @@ load config@Config{inpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS), pa
       pure (forgetLedgerTables st, projectLedgerTables st)
     Mem -> do
       checkSnapshotFileStructure Mem path fs
-      (ls, _) <- withExceptT SnapshotError $ V2.loadSnapshot rr ccfg fs ds
+      (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))
     LMDB -> do
@@ -237,7 +237,7 @@ store config@Config{outpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS),
       withFile hasFS (path <.> "checksum") (WriteMode MustBeNew) $ \h ->
         Monad.void $ hPutAll hasFS h . BS.toLazyByteString . BS.word32HexFixed $ getCRC crc
     Mem -> do
-      lseq <- V2.empty state tbs $ V2.newInMemoryLedgerTablesHandle fs
+      lseq <- V2.empty state tbs $ V2.newInMemoryLedgerTablesHandle nullTracer fs
       let h = V2.currentHandle lseq
       Monad.void $ V2.takeSnapshot ccfg nullTracer fs suffix h
     LMDB -> do

ouroboros-consensus/changelog.d/20250528_135650_alexander.esgen_v2_ledgerseq_close.md

@@ -0,0 +1,3 @@
+### Breaking
+
+- LedgerDB: added new trace events (enabling new tests).

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

@@ -128,12 +128,15 @@ mkInitDb args flavArgs getBlock =
 
   bss = case flavArgs of V2Args bss0 -> bss0
 
+  v2Tracer :: Tracer m V2.FlavorImplSpecificTrace
+  v2Tracer = LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 >$< lgrTracer
+
   emptyF ::
     ExtLedgerState blk ValuesMK ->
     m (LedgerSeq' m blk)
   emptyF st =
     empty' st $ case bss of
-      InMemoryHandleArgs -> InMemory.newInMemoryLedgerTablesHandle lgrHasFS
+      InMemoryHandleArgs -> InMemory.newInMemoryLedgerTablesHandle v2Tracer lgrHasFS
       LSMHandleArgs x -> absurd x
 
   loadSnapshot ::
@@ -142,7 +145,7 @@ mkInitDb args flavArgs getBlock =
     DiskSnapshot ->
     m (Either (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
   loadSnapshot ccfg fs ds = case bss of
-    InMemoryHandleArgs -> runExceptT $ InMemory.loadSnapshot lgrRegistry ccfg fs ds
+    InMemoryHandleArgs -> runExceptT $ InMemory.loadSnapshot v2Tracer lgrRegistry ccfg fs ds
     LSMHandleArgs x -> absurd x
 
 implMkLedgerDb ::

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

@@ -26,6 +26,9 @@ data HandleArgs
   deriving (Generic, NoThunks)
 
 data FlavorImplSpecificTrace
-  = FlavorImplSpecificTraceInMemory
-  | FlavorImplSpecificTraceOnDisk
+  = -- | Created a new 'LedgerTablesHandle', potentially by duplicating an
+    -- existing one.
+    TraceLedgerTablesHandleCreate
+  | -- | Closed a 'LedgerTablesHandle'.
+    TraceLedgerTablesHandleClose
   deriving (Show, Eq)

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

@@ -51,6 +51,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol
 import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
 import Ouroboros.Consensus.Storage.LedgerDB.API
 import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
 import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
 import Ouroboros.Consensus.Util.CBOR (readIncremental)
 import Ouroboros.Consensus.Util.CRC
@@ -85,18 +86,21 @@ newInMemoryLedgerTablesHandle ::
   , CanUpgradeLedgerTables l
   , SerializeTablesWithHint l
   ) =>
+  Tracer m V2.FlavorImplSpecificTrace ->
   SomeHasFS m ->
   LedgerTables l ValuesMK ->
   m (LedgerTablesHandle m l)
-newInMemoryLedgerTablesHandle someFS@(SomeHasFS hasFS) l = do
+newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do
   !tv <- newTVarIO (LedgerTablesHandleOpen l)
+  traceWith tracer V2.TraceLedgerTablesHandleCreate
   pure
     LedgerTablesHandle
-      { close =
+      { close = do
           atomically $ writeTVar tv LedgerTablesHandleClosed
+          traceWith tracer V2.TraceLedgerTablesHandleClose
       , duplicate = do
           hs <- readTVarIO tv
-          !x <- guardClosed hs $ newInMemoryLedgerTablesHandle someFS
+          !x <- guardClosed hs $ newInMemoryLedgerTablesHandle tracer someFS
           pure x
       , read = \keys -> do
           hs <- readTVarIO tv
@@ -208,12 +212,13 @@ loadSnapshot ::
   , IOLike m
   , LedgerSupportsInMemoryLedgerDB blk
   ) =>
+  Tracer m V2.FlavorImplSpecificTrace ->
   ResourceRegistry m ->
   CodecConfig blk ->
   SomeHasFS m ->
   DiskSnapshot ->
   ExceptT (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
-loadSnapshot _rr ccfg fs ds = do
+loadSnapshot tracer _rr ccfg fs ds = do
   snapshotMeta <-
     withExceptT (InitFailureRead . ReadMetadataError (snapshotToMetadataPath ds)) $
       loadSnapshotMetadata fs ds
@@ -242,4 +247,4 @@ loadSnapshot _rr ccfg fs ds = do
         throwE $
           InitFailureRead $
             ReadSnapshotDataCorruption
-      (,pt) <$> lift (empty extLedgerSt values (newInMemoryLedgerTablesHandle fs))
+      (,pt) <$> lift (empty extLedgerSt values (newInMemoryLedgerTablesHandle tracer fs))