diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 8b89764c2c..45883d87b8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/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 -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index a49173a15a..e81e17132a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/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" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 1dbd00c530..7ab1bbe70b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs index 96ee7d4d57..6c7fe71a1e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs @@ -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 -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs index 1719ae57f2..1218facb1c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs @@ -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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs index 9e8fa29c80..d4ce15e74b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs @@ -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 diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 13d9735c5f..ed72b5a018 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/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) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Mock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Mock.hs index 99395fedf5..aaf02bac3c 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Mock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Mock.hs @@ -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 diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs index 64097cef37..f8bdc80820 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs @@ -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) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs index fe6f6d1dc3..25d94f7fc0 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs @@ -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