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

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs

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