ouroboros-consensus: add ChainDB.waitForImmutableBlock

This function allows waiting until the immutables DB's tip is past the target
slot.

Author: geo2a

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs

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

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs

@@ -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"

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
@@ -26,6 +28,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query
   , getTipBlock
   , getTipHeader
   , getTipPoint
+  , waitForImmutableBlock
 
     -- * Low-level queries
   , getAnyBlockComponent
@@ -34,6 +37,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 +300,20 @@ 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 :: IOLike m => ChainDbEnv m blk -> RealPoint blk -> m (Maybe (RealPoint blk))
+waitForImmutableBlock CDB{cdbImmutableDB} targetRealPoint = do
+  atomically (ImmutableDB.getTip cdbImmutableDB) >>= \case
+    Origin -> pure Nothing
+    At tip ->
+      if ImmutableDB.tipSlotNo tip >= realPointSlot targetRealPoint
+        then ImmutableDB.getBlockAtOrAfterPoint cdbImmutableDB targetRealPoint
+        else pure Nothing
+
 {-------------------------------------------------------------------------------
   Unifying interface over the immutable DB and volatile DB, but independent
   of the ledger DB. These functions therefore do not require the entire