Return maximal key when doing a range read

LSM trees use an ordering different than the Haskell `Ord`. This commit enriches
the type returned by range reads so that the maximal key is returned, which is
then given back to the next iteration of the range reading loop.

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

@@ -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-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.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-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs

@@ -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,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/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 ->