Return the last read key when doing range reads

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

ouroboros-consensus-cardano/changelog.d/20250902_113907_javier.sagredo_lmdb.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/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs

@@ -1331,17 +1331,12 @@ answerShelleyTraversingQueries ejTxOut ejTxIn filt cfg q forker = case q of
         )
         vs
 
-  vnull :: ValuesMK k v -> Bool
-  vnull (ValuesMK vs) = Map.null vs
-
-  toMaxKey (LedgerTables (ValuesMK vs)) = fst $ Map.findMax vs
-
   loop queryPredicate !prev !acc = do
-    extValues <- LedgerDB.roforkerRangeReadTables forker prev
-    if ltcollapse $ ltmap (K2 . vnull) extValues
-      then pure acc
-      else
+    (extValues, k) <- LedgerDB.roforkerRangeReadTables forker prev
+    case k of
+      Nothing -> pure acc
+      Just k' ->
         loop
           queryPredicate
-          (PreviousQueryWasUpTo $ toMaxKey extValues)
+          (PreviousQueryWasUpTo k')
           (combUtxo acc $ partial queryPredicate extValues)

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

@@ -704,7 +704,7 @@ runThreadNetwork
         let emptySt = emptySt'
             doRangeQuery = roforkerRangeReadTables forker
         fullLedgerSt <- fmap ledgerState $ do
-          fullUTxO <- doRangeQuery NoPreviousQuery
+          (fullUTxO, _) <- doRangeQuery NoPreviousQuery
           pure $! withLedgerTables emptySt fullUTxO
         roforkerClose forker
         -- Combine the node's seed with the current slot number, to make sure

ouroboros-consensus/changelog.d/20250822_163712_jasataco_lmdb.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
+
+- `forkerRangeRead` now returns also the maximal key found in the backend.

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

@@ -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,11 +106,20 @@ 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
-  -- was passed when opening the LedgerDB.
+  -- This range read will return as many values as the 'QueryBatchSize' that was
+  -- passed when opening the LedgerDB.
+  --
+  -- The second component of the returned tuple is the maximal key found by the
+  -- forker. This is only necessary because some backends have a different
+  -- sorting for the keys than the order defined in Haskell.
+  --
+  -- The last key retrieved is part of the map too. It is intended to be fed
+  -- back into the next iteration of the range read. If the function returns
+  -- Nothing, it means the read returned no results, or in other words, we
+  -- reached the end of the ledger tables.
   , forkerGetLedgerState :: !(STM m (l EmptyMK))
   -- ^ Get the full ledger state without tables.
   --
@@ -206,7 +216,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 +250,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/V1/BackingStore/API.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/Impl/InMemory.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 ->