IntersectMBO · geo2a · Dec 18, 2025 · Dec 18, 2025 · Dec 16, 2025
@@ -405,6 +405,16 @@ data ChainDB m blk = ChainDB
   , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk)
   -- ^ Get the Peras certificate snapshot, containing the currently-known
   -- certificates boosting blocks newer than the immutable tip.
+  , waitForImmutableBlock :: RealPoint blk -> m (Maybe (RealPoint blk))
+  -- ^ wait until the immutable tip gets past the given slot:
+  --   - returns the block when it becomes the immutable tip,
+  --     reading it from disk;
+  --   - if no block was found at the target slot, returns the immutable block
+  --     at the next filled slot;
+  --   - returns 'Nothing' if no block was found on disk at all.
+  --
+  -- Currently, the only use-case of this function is to verify the immutability
+  -- of a block from the big ledger peer snapshot file.
   , closeDB :: m ()
   -- ^ Close the ChainDB
   --

@@ -290,6 +290,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , addPerasCertAsync = getEnv1 h ChainSel.addPerasCertAsync
             , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot
             , getPerasCertSnapshot = getEnvSTM h Query.getPerasCertSnapshot
+            , waitForImmutableBlock = getEnv1 h Query.waitForImmutableBlock
             }
     addBlockTestFuse <- newFuse "test chain selection"
     copyTestFuse <- newFuse "test copy to immutable db"

@@ -1,8 +1,11 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 
 -- | Queries
@@ -26,6 +29,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query
   , getTipBlock
   , getTipHeader
   , getTipPoint
+  , waitForImmutableBlock
 
     -- * Low-level queries
   , getAnyBlockComponent
@@ -34,6 +38,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query
   , getChainSelStarvation
   ) where
 
+import Cardano.Ledger.BaseTypes (WithOrigin (..))
 import Control.ResourceRegistry (ResourceRegistry)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -296,6 +301,24 @@ getPerasCertSnapshot ::
   ChainDbEnv m blk -> STM m (PerasCertSnapshot blk)
 getPerasCertSnapshot CDB{..} = PerasCertDB.getCertSnapshot cdbPerasCertDB
 
+-- | Wait until the given point becomes immutable:
+--   - blocks until the immutable tip slot number is lower than the block's slot number;
+--   - ones the immutable tip is older than the slot of the target point:
+--     * returns the block at the target slot if it is occupied;n
+--     * otherwise, returns the block from the next occupied slot.
+waitForImmutableBlock ::
+  forall blk m. IOLike m => ChainDbEnv m blk -> RealPoint blk -> m (Maybe (RealPoint blk))
+waitForImmutableBlock CDB{cdbImmutableDB} targetRealPoint = do
+  -- first, wait until the target slot is older than the immutable tip
+  _ <- atomically $ do
+    ImmutableDB.getTip cdbImmutableDB >>= \case
+      Origin -> retry
+      At tip -> do
+        check (ImmutableDB.tipSlotNo tip >= realPointSlot targetRealPoint)
+        pure (ImmutableDB.tipToRealPoint tip)
+  -- then, query the DB for a point at or directly following the target slot
+  ImmutableDB.getBlockAtOrAfterPoint cdbImmutableDB targetRealPoint
+
 {-------------------------------------------------------------------------------
   Unifying interface over the immutable DB and volatile DB, but independent
   of the ledger DB. These functions therefore do not require the entire

@@ -45,6 +45,7 @@ module Ouroboros.Consensus.Storage.ImmutableDB.API
   , getBlockComponent
   , getTip
   , stream
+  , getBlockAtOrAfterPoint
 
     -- * Derived functionality
   , getKnownBlockComponent
@@ -174,6 +175,22 @@ data ImmutableDB m blk = ImmutableDB
   --
   -- The iterator is automatically closed when exhausted, and can be
   -- prematurely closed with 'iteratorClose'.
+  , getBlockAtOrAfterPoint_ ::
+      HasCallStack =>
+      (RealPoint blk) ->
+      m (Maybe (RealPoint blk))
+  -- ^ Query the ImmutableDB to for a block at the target slot. If the target slot is empty,
+  --   return the block at the next occupied slot.
+  --
+  --   Output:
+  --   - returns 'Nothing' if the target slot is younger than the immutable tip
+  --   - returns the block at the target slot if it's occupied
+  --   - returns the block at the next occupied slot if the target slot is empty
+  --
+  --   Note: in case a slot is occupied by two blocks, and EBB and a regular block,
+  --         return the first block, i.e. the EBB. In contemporary Cardano,
+  --         no new EBBs will be produced; hence, this implementation will always
+  --         return a regular block.
   }
   deriving NoThunks via OnlyCheckWhnfNamed "ImmutableDB" (ImmutableDB m blk)
 
@@ -475,6 +492,13 @@ stream ::
   m (Either (MissingBlock blk) (Iterator m blk b))
 stream = stream_
 
+getBlockAtOrAfterPoint ::
+  HasCallStack =>
+  ImmutableDB m blk ->
+  (RealPoint blk) ->
+  m (Maybe (RealPoint blk))
+getBlockAtOrAfterPoint = getBlockAtOrAfterPoint_
+
 {-------------------------------------------------------------------------------
   Derived functionality
 -------------------------------------------------------------------------------}

@@ -302,6 +302,7 @@ openDBInternal ImmutableDbArgs{immHasFS = SomeHasFS hasFS, ..} cont = cont $ do
           , getBlockComponent_ = getBlockComponentImpl dbEnv
           , appendBlock_ = appendBlockImpl dbEnv
           , stream_ = streamImpl dbEnv
+          , getBlockAtOrAfterPoint_ = getBlockAtOrAfterPointImpl dbEnv
           }
       internal =
         Internal

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -7,15 +8,18 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Iterator
   ( CurrentChunkInfo (..)
   , extractBlockComponent
   , getSlotInfo
   , streamImpl
+  , getBlockAtOrAfterPointImpl
   ) where
 
-import Cardano.Prelude (forceElemsToWHNF)
+import Cardano.Prelude (Natural, forceElemsToWHNF)
+import Cardano.Slotting.Slot (WithOrigin (..))
 import qualified Codec.CBOR.Read as CBOR
 import Control.Monad (unless, void, when)
 import Control.Monad.Except (ExceptT, runExceptT, throwError)
@@ -742,3 +746,79 @@ extractBlockComponent
       Left err ->
         throwUnexpectedFailure $
           ParseError (fsPathChunkFile chunk) pt err
+
+-- | Error type for 'seekBlockForwards'
+data SeekBlockError
+  = TargetNewerThanTip
+  deriving (Show, Eq)
+
+-- | Result type for 'seekBlockForwards'
+data SeekBlockResult blk
+  = Found Natural (RealPoint blk)
+  deriving (Show, Eq)
+
+-- | Find a filled slot, starting from the target slot and going forwards in the immutable DB
+--
+--   Because of EBBs, the new resulting slot may be filled with two blocks. This implementation
+--   returns the first one, even if it's an EBB. On mainned, no new EBBs will be produced; hence,
+--   this implementation will always return a regular block.
+seekBlockForwards ::
+  forall m blk h.
+  ( IOLike m
+  , HasHeader blk
+  , HasCallStack
+  ) =>
+  ImmutableDBEnv m blk ->
+  OpenState m blk h ->
+  Tip blk ->
+  RealPoint blk ->
+  m (Either SeekBlockError (SeekBlockResult blk))
+seekBlockForwards
+  ImmutableDBEnv{chunkInfo}
+  OpenState{currentIndex}
+  immutableTip = go 0
+   where
+    go !emptySlotsPassed targetPoint@(RealPoint !slot hash) =
+      runExceptT (getSlotInfo chunkInfo currentIndex (NotOrigin immutableTip) targetPoint) >>= \case
+        Left NewerThanTip{} ->
+          -- Stop if the target slot is newer then tip
+          pure . Left $ TargetNewerThanTip
+        Left (EmptySlot{}) -> do
+          if slot < (realPointSlot . tipToRealPoint $ immutableTip)
+            -- otherwise, skip this slot and repeat with the next one
+            then go (emptySlotsPassed + 1) (RealPoint (slot + 1) hash)
+            -- we're past the tip and did not fine any blocks, so we can only return the tip.
+            -- Note that this case is impossible, as the we would not get 'EmptySlot' from 'getSlotInfo',
+            -- but we still return the tip for completeness' sake.
+            else pure . Right $ Found emptySlotsPassed (tipToRealPoint immutableTip)
+        Left (WrongHash _ hashes) ->
+          case hashes of
+            -- always return the first found block, even if it's an EBB
+            (actualHash NE.:| _) ->
+              pure . Right . Found emptySlotsPassed $ RealPoint @blk (realPointSlot targetPoint) actualHash
+        Right{} ->
+          pure . Right $ Found emptySlotsPassed targetPoint
+
+-- | Query the immutable DB to for a block at the target slot. If the target slot is empty,
+--   return the block at the next occupied slot.
+--
+--   See the haddock of 'ChainDB.getBlockAtOrAfterPoint_' for more details.
+getBlockAtOrAfterPointImpl ::
+  forall m blk.
+  ( IOLike m
+  , HasHeader blk
+  , HasCallStack
+  ) =>
+  ImmutableDBEnv m blk ->
+  (RealPoint blk) ->
+  m (Maybe (RealPoint blk))
+getBlockAtOrAfterPointImpl dbEnv targetPoint =
+  withOpenState dbEnv $ \_hasFS dbState@OpenState{currentTip} -> do
+    case currentTip of
+      Origin -> pure Nothing
+      At tip -> do
+        seekBlockForwards dbEnv dbState tip targetPoint >>= \case
+          Left TargetNewerThanTip ->
+            -- requested a point that is not immutable yet
+            pure Nothing
+          Right (Found _ point) -> pure . Just $ point
@@ -266,6 +266,14 @@ data Cmd blk it flr
 -- something we are testing in 'prop_trace', see
 -- 'invalidBlockNeverValidatedAgain'.
 
+-- = No tests for waitForImmutableBlock
+--
+-- We do not test 'ChainDB.waitForImmutableBlock', because this test is
+-- sequential, and 'waitForImmutableBlock', which uses STM 'retry' and
+-- 'check', would block indefinitely.
+-- The core behaviour of 'waitForImmutableBlock' is tested in the ImmutableDB
+-- q-s-m test via testing 'ImmutableDB.getBlockAtOrAfterPoint'.
+
 deriving instance SOP.Generic (Cmd blk it flr)
 deriving instance SOP.HasDatatypeInfo (Cmd blk it flr)
 

@@ -40,6 +40,7 @@ openDBMock chunkInfo ccfg = do
       , appendBlock_ = updateE_ . appendBlockModel
       , stream_ =
           updateEE ...: \_rr bc s e -> fmap (fmap (first (iterator bc))) . streamModel s e
+      , getBlockAtOrAfterPoint_ = const (pure Nothing)
       }
    where
     iterator :: BlockComponent blk b -> IteratorId -> Iterator m blk b

@@ -35,6 +35,7 @@ module Test.Ouroboros.Storage.ImmutableDB.Model
   , reopenModel
   , streamAllModel
   , streamModel
+  , getBlockAtOrAfterPointModel
   ) where
 
 import qualified Codec.CBOR.Write as CBOR
@@ -46,6 +47,7 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NE
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes, listToMaybe)
 import qualified Data.Text as Text
 import Data.TreeDiff
 import Data.Word (Word64)
@@ -671,3 +673,25 @@ iteratorHasNextModel itId DBModel{dbmIterators} =
 iteratorCloseModel :: IteratorId -> DBModel blk -> DBModel blk
 iteratorCloseModel itId dbm@DBModel{dbmIterators} =
   dbm{dbmIterators = Map.delete itId dbmIterators}
+
+-- | Get the block at the target slot, or, if the target slot is empty,
+--   find the next block.
+--
+--   If a slot is occupied by an EBB only, return the EBB. If the slot is
+--   occupied by both an EBB and a normal block, check the hashes to disambiguate,
+--   and return the first block (i.e. the EBB) if the target hash does not match.
+getBlockAtOrAfterPointModel ::
+  forall blk. HasHeader blk => RealPoint blk -> DBModel blk -> Maybe (RealPoint blk)
+getBlockAtOrAfterPointModel (RealPoint targetSlot targetHash) DBModel{dbmSlots} =
+  let occupiedSlots = catMaybes . map getBlock . Map.toList $ dbmSlots
+      atOrAfterTarget = dropWhile ((< targetSlot) . fst) occupiedSlots
+   in (\(s, b) -> RealPoint s (blockHash b)) <$> listToMaybe atOrAfterTarget
+ where
+  getBlock :: (SlotNo, InSlot blk) -> Maybe (SlotNo, blk)
+  getBlock = \case
+    (slotNo, InSlotBlock b) -> Just (slotNo, b)
+    (slotNo, InSlotEBB ebb) -> Just (slotNo, ebb)
+    (slotNo, InSlotBoth ebb b)
+      | blockHash ebb == targetHash -> Just (slotNo, ebb)
+      | blockHash b == targetHash -> Just (slotNo, b)
+      | otherwise -> Just (slotNo, ebb)
@@ -143,6 +143,7 @@ data Cmd it
   | Migrate ValidationPolicy
   | DeleteAfter (WithOrigin (Tip TestBlock))
   | GetHashForSlot SlotNo
+  | GetBlockAtOrAfterPoint (RealPoint TestBlock)
   | Corruption Corruption
   deriving (Generic, Show, Functor, Foldable, Traversable)
 
@@ -174,6 +175,7 @@ data Success it
   | IterResults [AllComponents TestBlock]
   | ImmTip (WithOrigin (Tip TestBlock))
   | HashForSlot (Maybe TestHeaderHash)
+  | BlockAtOrAfterPoint (Maybe (RealPoint TestBlock))
   deriving (Eq, Show, Functor, Foldable, Traversable)
 
 -- | Product of all 'BlockComponent's. As this is a GADT, generating random
@@ -257,6 +259,7 @@ run
       IteratorNext it -> IterResult <$> iteratorNext (unWithEq it)
       IteratorHasNext it -> IterHasNext <$> atomically (iteratorHasNext (unWithEq it))
       IteratorClose it -> Unit <$> iteratorClose' it
+      GetBlockAtOrAfterPoint pt -> BlockAtOrAfterPoint <$> getBlockAtOrAfterPoint db pt
       DeleteAfter tip -> do
         closeOpenIterators varIters
         Unit <$> deleteAfter internal tip
@@ -345,6 +348,7 @@ runPure = \case
   IteratorClose it -> ok Unit $ update_ (iteratorCloseModel it)
   DeleteAfter tip -> ok Unit $ update_ (deleteAfterModel tip)
   GetHashForSlot slot -> ok HashForSlot $ query (getHashForSlotModel slot)
+  GetBlockAtOrAfterPoint pt -> ok BlockAtOrAfterPoint (query (getBlockAtOrAfterPointModel pt))
   Corruption corr -> ok ImmTip $ update (simulateCorruptions (getCorruptions corr))
   Reopen _ -> ok ImmTip $ update reopenModel
   Migrate _ -> ok ImmTip $ update reopenModel
@@ -561,6 +565,7 @@ generateCmd Model{..} =
       , (1, Migrate <$> genValPol)
       , (1, DeleteAfter <$> genTip)
       , (1, GetHashForSlot <$> genGetHashForSlot)
+      , (1, GetBlockAtOrAfterPoint <$> genRandomBeforeSlotOrExisting lastSlot)
       , (if null dbFiles then 0 else 1, Corruption <$> genCorruption)
       ]
  where
@@ -617,6 +622,12 @@ generateCmd Model{..} =
       <$> arbitrary
       <*> (TestHeaderHash <$> arbitrary)
 
+  genRandomPointBeforeSlot :: SlotNo -> Gen (RealPoint TestBlock)
+  genRandomPointBeforeSlot slotNo =
+    RealPoint
+      <$> (chooseSlot (0, slotNo))
+      <*> (TestHeaderHash <$> arbitrary)
+
   genGetBlock :: Gen (RealPoint TestBlock)
   genGetBlock =
     frequency
@@ -671,6 +682,14 @@ generateCmd Model{..} =
       , (if empty then 0 else 1, elements (map blockRealPoint blocks))
       ]
 
+  -- Both random points and existing points
+  genRandomBeforeSlotOrExisting :: SlotNo -> Gen (RealPoint TestBlock)
+  genRandomBeforeSlotOrExisting slotNo =
+    frequency
+      [ (1, genRandomPointBeforeSlot slotNo)
+      , (if empty then 0 else 1, elements (map blockRealPoint blocks))
+      ]
+
   genStreamFromWith :: Gen (RealPoint blk) -> Gen (StreamFrom blk)
   genStreamFromWith genPoint =
     oneof