Return the last read key in LMDB backend

Author: jasagredo

cabal.project

@@ -16,7 +16,7 @@ index-state:
   -- Bump this if you need newer packages from Hackage
   , hackage.haskell.org 2025-07-22T09:13:54Z
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2025-08-06T10:58:15Z
+  , cardano-haskell-packages 2025-08-21T09:41:03Z
 
 packages:
   ouroboros-consensus

flake.lock

@@ -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
+
+- `forkerRangeRead` now returns also the maximal key found in the backend.

ouroboros-consensus/changelog.d/20250822_163712_jasataco_lmdb.md

@@ -66,6 +66,7 @@ import Control.Monad.Except
 import Control.Monad.Reader (ReaderT (..))
 import Control.Monad.Trans (MonadTrans (..))
 import Control.ResourceRegistry
+import Data.Bifunctor (first)
 import Data.Kind
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -105,7 +106,7 @@ data Forker m l blk = Forker
 
     forkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
   -- ^ Read ledger tables from disk.
-  , forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK))
+  , forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l)))
   -- ^ Range-read ledger tables from disk.
   --
   -- This range read will return as many values as the 'QueryBatchSize' that
@@ -206,7 +207,8 @@ ledgerStateReadOnlyForker frk =
   ReadOnlyForker
     { roforkerClose = roforkerClose
     , roforkerReadTables = fmap castLedgerTables . roforkerReadTables . castLedgerTables
-    , roforkerRangeReadTables = fmap castLedgerTables . roforkerRangeReadTables . castRangeQueryPrevious
+    , roforkerRangeReadTables =
+        fmap (first castLedgerTables) . roforkerRangeReadTables . castRangeQueryPrevious
     , roforkerGetLedgerState = ledgerState <$> roforkerGetLedgerState
     , roforkerReadStatistics = roforkerReadStatistics
     }
@@ -239,7 +241,7 @@ data ReadOnlyForker m l blk = ReadOnlyForker
   -- ^ See 'forkerClose'
   , roforkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
   -- ^ See 'forkerReadTables'
-  , roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK))
+  , roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l)))
   -- ^ See 'forkerRangeReadTables'.
   , roforkerGetLedgerState :: !(STM m (l EmptyMK))
   -- ^ See 'forkerGetLedgerState'

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

@@ -58,6 +58,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API
   ) where
 
 import Cardano.Slotting.Slot (SlotNo, WithOrigin (..))
+import Data.Bifunctor
 import Data.Kind
 import GHC.Generics
 import NoThunks.Class (OnlyCheckWhnfNamed (..))
@@ -93,7 +94,7 @@ data DiffsToFlush l = DiffsToFlush
   -- considered as "last flushed" in the kept 'DbChangelog'
   }
 
-data BackingStore m keys values diff = BackingStore
+data BackingStore m keys key values diff = BackingStore
   { bsClose :: !(m ())
   -- ^ Close the backing store
   --
@@ -107,7 +108,7 @@ data BackingStore m keys values diff = BackingStore
   --
   -- The destination path must not already exist. After this operation, it
   -- will be a directory.
-  , bsValueHandle :: !(m (BackingStoreValueHandle m keys values))
+  , bsValueHandle :: !(m (BackingStoreValueHandle m keys key values))
   -- ^ Open a 'BackingStoreValueHandle' capturing the current value of the
   -- entire database
   , bsWrite :: !(SlotNo -> WriteHint diff -> diff -> m ())
@@ -118,14 +119,15 @@ data BackingStore m keys values diff = BackingStore
   }
 
 deriving via
-  OnlyCheckWhnfNamed "BackingStore" (BackingStore m keys values diff)
+  OnlyCheckWhnfNamed "BackingStore" (BackingStore m keys key values diff)
   instance
-    NoThunks (BackingStore m keys values diff)
+    NoThunks (BackingStore m keys key values diff)
 
 type LedgerBackingStore m l =
   BackingStore
     m
     (LedgerTables l KeysMK)
+    (TxIn l)
     (LedgerTables l ValuesMK)
     (LedgerTables l DiffMK)
 
@@ -157,15 +159,15 @@ data InitFrom values
 -- The performance cost is usually minimal unless this handle is held open too
 -- long. We expect clients of the 'BackingStore' to not retain handles for a
 -- long time.
-data BackingStoreValueHandle m keys values = BackingStoreValueHandle
+data BackingStoreValueHandle m keys key values = BackingStoreValueHandle
   { bsvhAtSlot :: !(WithOrigin SlotNo)
   -- ^ At which slot this handle was created
   , bsvhClose :: !(m ())
   -- ^ Close the handle
   --
   -- Other methods throw exceptions if called on a closed handle. 'bsvhClose'
   -- itself is idempotent.
-  , bsvhRangeRead :: !(ReadHint values -> RangeQuery keys -> m values)
+  , bsvhRangeRead :: !(ReadHint values -> RangeQuery keys -> m (values, Maybe key))
   -- ^ See 'RangeQuery'
   , bsvhReadAll :: !(ReadHint values -> m values)
   -- ^ Costly read all operation, not to be used in Consensus but only in
@@ -180,14 +182,15 @@ data BackingStoreValueHandle m keys values = BackingStoreValueHandle
   }
 
 deriving via
-  OnlyCheckWhnfNamed "BackingStoreValueHandle" (BackingStoreValueHandle m keys values)
+  OnlyCheckWhnfNamed "BackingStoreValueHandle" (BackingStoreValueHandle m keys key values)
   instance
-    NoThunks (BackingStoreValueHandle m keys values)
+    NoThunks (BackingStoreValueHandle m keys key values)
 
 type LedgerBackingStoreValueHandle m l =
   BackingStoreValueHandle
     m
     (LedgerTables l KeysMK)
+    (TxIn l)
     (LedgerTables l ValuesMK)
 
 type BackingStoreValueHandle' m blk = LedgerBackingStoreValueHandle m (ExtLedgerState blk)
@@ -196,15 +199,16 @@ castBackingStoreValueHandle ::
   (Functor m, ReadHint values ~ ReadHint values') =>
   (values -> values') ->
   (keys' -> keys) ->
-  BackingStoreValueHandle m keys values ->
-  BackingStoreValueHandle m keys' values'
-castBackingStoreValueHandle f g bsvh =
+  (key -> key') ->
+  BackingStoreValueHandle m keys key values ->
+  BackingStoreValueHandle m keys' key' values'
+castBackingStoreValueHandle f g h bsvh =
   BackingStoreValueHandle
     { bsvhAtSlot
     , bsvhClose
     , bsvhReadAll = \rhint -> f <$> bsvhReadAll rhint
     , bsvhRangeRead = \rhint (RangeQuery prev count) ->
-        fmap f . bsvhRangeRead rhint $ RangeQuery (fmap g prev) count
+        fmap (second (fmap h) . first f) . bsvhRangeRead rhint $ RangeQuery (fmap g prev) count
     , bsvhRead = \rhint -> fmap f . bsvhRead rhint . g
     , bsvhStat
     }
@@ -221,7 +225,7 @@ castBackingStoreValueHandle f g bsvh =
 -- | A combination of 'bsValueHandle' and 'bsvhRead'
 bsRead ::
   MonadThrow m =>
-  BackingStore m keys values diff ->
+  BackingStore m keys key values diff ->
   ReadHint values ->
   keys ->
   m (WithOrigin SlotNo, values)
@@ -231,16 +235,16 @@ bsRead store rhint keys = withBsValueHandle store $ \vh -> do
 
 bsReadAll ::
   MonadThrow m =>
-  BackingStore m keys values diff ->
+  BackingStore m keys key values diff ->
   ReadHint values ->
   m values
 bsReadAll store rhint = withBsValueHandle store $ \vh -> bsvhReadAll vh rhint
 
 -- | A 'IOLike.bracket'ed 'bsValueHandle'
 withBsValueHandle ::
   MonadThrow m =>
-  BackingStore m keys values diff ->
-  (BackingStoreValueHandle m keys values -> m a) ->
+  BackingStore m keys key values diff ->
+  (BackingStoreValueHandle m keys key values -> m a) ->
   m a
 withBsValueHandle store =
   bracket

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs

@@ -247,12 +247,14 @@ newInMemoryBackingStore tracer (SnapshotsFS (SomeHasFS fs)) initialization = do
   rangeRead ::
     RangeQuery (LedgerTables l KeysMK) ->
     LedgerTables l ValuesMK ->
-    LedgerTables l ValuesMK
-  rangeRead rq values = case rqPrev rq of
-    Nothing ->
-      ltmap (rangeRead0' (rqCount rq)) values
-    Just keys ->
-      ltliftA2 (rangeRead' (rqCount rq)) keys values
+    (LedgerTables l ValuesMK, Maybe (TxIn l))
+  rangeRead rq values =
+    let vs@(LedgerTables (ValuesMK m)) = case rqPrev rq of
+          Nothing ->
+            ltmap (rangeRead0' (rqCount rq)) values
+          Just keys ->
+            ltliftA2 (rangeRead' (rqCount rq)) keys values
+     in (vs, fst <$> Map.lookupMax m)
 
   rangeRead0' ::
     Int ->

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

@@ -36,6 +36,7 @@ import Control.Monad (forM_, unless, void, when)
 import qualified Control.Monad.Class.MonadSTM as IOLike
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import qualified Control.Tracer as Trace
+import Data.Bifunctor (first)
 import Data.Functor (($>), (<&>))
 import Data.Functor.Contravariant ((>$<))
 import Data.Map (Map)
@@ -189,12 +190,12 @@ rangeRead ::
   API.RangeQuery (LedgerTables l KeysMK) ->
   idx ->
   LMDBMK (TxIn l) (TxOut l) ->
-  LMDB.Transaction mode (ValuesMK (TxIn l) (TxOut l))
+  LMDB.Transaction mode (ValuesMK (TxIn l) (TxOut l), Maybe (TxIn l))
 rangeRead rq st dbMK =
-  ValuesMK <$> case ksMK of
+  first ValuesMK <$> case ksMK of
     Nothing -> runCursorHelper Nothing
     Just (LedgerTables (KeysMK ks)) -> case Set.lookupMax ks of
-      Nothing -> pure mempty
+      Nothing -> pure (mempty, Nothing)
       Just lastExcludedKey ->
         runCursorHelper $ Just (lastExcludedKey, LMDB.Cursor.Exclusive)
  where
@@ -205,11 +206,11 @@ rangeRead rq st dbMK =
   runCursorHelper ::
     Maybe (TxIn l, LMDB.Cursor.Bound) ->
     -- \^ Lower bound on read range
-    LMDB.Transaction mode (Map (TxIn l) (TxOut l))
+    LMDB.Transaction mode (Map (TxIn l) (TxOut l), Maybe (TxIn l))
   runCursorHelper lb =
     Bridge.runCursorAsTransaction'
       st
-      (LMDB.Cursor.cgetMany lb count)
+      (LMDB.Cursor.cgetManyAndLast lb count)
       db
 
 initLMDBTable ::
@@ -631,7 +632,7 @@ mkLMDBBackingStoreValueHandle db = do
     bsvhRangeRead ::
       l EmptyMK ->
       API.RangeQuery (LedgerTables l KeysMK) ->
-      m (LedgerTables l ValuesMK)
+      m (LedgerTables l ValuesMK, Maybe (TxIn l))
     bsvhRangeRead st rq =
       Status.withReadAccess dbStatusLock (throwIO LMDBErrClosed) $ do
         Status.withReadAccess vhStatusLock (throwIO (LMDBErrNoValueHandle vhId)) $ do
@@ -640,7 +641,7 @@ mkLMDBBackingStoreValueHandle db = do
             liftIO $
               TrH.submitReadOnly trh $
                 let dbMK = getLedgerTables dbBackingTables
-                 in LedgerTables <$> rangeRead rq st dbMK
+                 in first LedgerTables <$> rangeRead rq st dbMK
           Trace.traceWith tracer API.BSVHRangeRead
           pure res