From f7d9d8cb606f8b91648fae061084efa9c504dc8b Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 3 Feb 2020 18:11:24 +0100 Subject: [PATCH] ImmutableDB: truncate blocks from the future During validation, truncate any blocks >= the current (wall clock) slot. --- .../Ouroboros/Storage/ChainDB/Impl/Args.hs | 1 + .../Ouroboros/Storage/ChainDB/Impl/ImmDB.hs | 5 + .../src/Ouroboros/Storage/ImmutableDB/Impl.hs | 15 +- .../Storage/ImmutableDB/Impl/State.hs | 2 + .../Storage/ImmutableDB/Impl/Validation.hs | 3 +- .../Ouroboros/Storage/ImmutableDB/Parser.hs | 155 +++++++++++++----- .../Ouroboros/Storage/ImmutableDB/Types.hs | 14 +- .../Test/Ouroboros/Storage/ChainDB/ImmDB.hs | 2 + .../Test/Ouroboros/Storage/ImmutableDB.hs | 2 + .../Ouroboros/Storage/ImmutableDB/Model.hs | 27 +++ .../Storage/ImmutableDB/StateMachine.hs | 68 ++++++-- ouroboros-consensus/tools/db-analyse/Main.hs | 3 + 12 files changed, 228 insertions(+), 69 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Args.hs index 6e5e0217ee8..058e5730def 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Args.hs @@ -177,6 +177,7 @@ fromChainDbArgs ChainDbArgs{..} = ( , immAddHdrEnv = cdbAddHdrEnv , immCacheConfig = cdbImmDbCacheConfig , immRegistry = cdbRegistry + , immBlockchainTime = cdbBlockchainTime } , VolDB.VolDbArgs { volHasFS = cdbHasFSVolDb diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ImmDB.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ImmDB.hs index db707192578..f3b57f99359 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ImmDB.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ImmDB.hs @@ -78,6 +78,7 @@ import Ouroboros.Network.Block (pattern BlockPoint, ChainHash (..), import Ouroboros.Network.Point (WithOrigin (..)) import Ouroboros.Consensus.Block (GetHeader (..), IsEBB (..)) +import Ouroboros.Consensus.BlockchainTime (BlockchainTime) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) @@ -157,6 +158,7 @@ data ImmDbArgs m blk = forall h. ImmDbArgs { , immTracer :: Tracer m (TraceEvent blk) , immCacheConfig :: Index.CacheConfig , immRegistry :: ResourceRegistry m + , immBlockchainTime :: BlockchainTime m } -- | Default arguments when using the 'IO' monad @@ -175,6 +177,7 @@ data ImmDbArgs m blk = forall h. ImmDbArgs { -- * 'immCheckIntegrity' -- * 'immAddHdrEnv' -- * 'immRegistry' +-- * 'immBlockchainTime' defaultArgs :: FilePath -> ImmDbArgs IO blk defaultArgs fp = ImmDbArgs{ immErr = EH.exceptions @@ -194,6 +197,7 @@ defaultArgs fp = ImmDbArgs{ , immCheckIntegrity = error "no default for immCheckIntegrity" , immAddHdrEnv = error "no default for immAddHdrEnv" , immRegistry = error "no default for immRegistry" + , immBlockchainTime = error "no default for immBlockchainTime" } where -- Cache 250 past epochs by default. This will take roughly 250 MB of RAM. @@ -228,6 +232,7 @@ openDB ImmDbArgs{..} = do parser immTracer immCacheConfig + immBlockchainTime return ImmDB { immDB = immDB , decHeader = immDecodeHeader diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl.hs b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl.hs index ca8fe6393a6..53597fa7f59 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl.hs @@ -110,6 +110,8 @@ import Control.Monad.Class.MonadThrow (bracket, bracketOnError, finally) import Ouroboros.Consensus.Block (IsEBB (..)) +import Ouroboros.Consensus.BlockchainTime (BlockchainTime, + getCurrentSlot) import Ouroboros.Consensus.Util (SomePair (..)) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) @@ -175,14 +177,15 @@ withDB -> EpochFileParser e m (Secondary.Entry hash) hash -> Tracer m (TraceEvent e hash) -> Index.CacheConfig + -> BlockchainTime m -> (ImmutableDB hash m -> m a) -> m a -withDB registry hasFS err epochInfo hashInfo valPol parser tracer cacheConfig = +withDB registry hasFS err epochInfo hashInfo valPol parser tracer cacheConfig btime = bracket open closeDB where open = fst <$> openDBInternal registry hasFS err epochInfo hashInfo valPol parser tracer - cacheConfig + cacheConfig btime {------------------------------------------------------------------------------ Exposed internals and/or extra functionality for testing purposes @@ -239,9 +242,11 @@ openDBInternal -> EpochFileParser e m (Secondary.Entry hash) hash -> Tracer m (TraceEvent e hash) -> Index.CacheConfig + -> BlockchainTime m -> m (ImmutableDB hash m, Internal hash m) openDBInternal registry hasFS@HasFS{..} err epochInfo hashInfo valPol parser - tracer cacheConfig = do + tracer cacheConfig btime = do + currentSlot <- atomically $ getCurrentSlot btime let validateEnv = ValidateEnv { hasFS , err @@ -251,6 +256,7 @@ openDBInternal registry hasFS@HasFS{..} err epochInfo hashInfo valPol parser , tracer , registry , cacheConfig + , currentSlot } !ost <- validateAndReopen validateEnv valPol @@ -266,6 +272,7 @@ openDBInternal registry hasFS@HasFS{..} err epochInfo hashInfo valPol parser , _dbTracer = tracer , _dbRegistry = registry , _dbCacheConfig = cacheConfig + , _dbBlockchainTime = btime } db = mkDBRecord dbEnv internal = Internal @@ -312,6 +319,7 @@ reopenImpl ImmutableDBEnv {..} valPol = bracketOnError -- Closed, so we can try to reopen DbClosed -> do + currentSlot <- atomically $ getCurrentSlot _dbBlockchainTime let validateEnv = ValidateEnv { hasFS = _dbHasFS , err = _dbErr @@ -321,6 +329,7 @@ reopenImpl ImmutableDBEnv {..} valPol = bracketOnError , tracer = _dbTracer , registry = _dbRegistry , cacheConfig = _dbCacheConfig + , currentSlot = currentSlot } ost <- validateAndReopen validateEnv valPol putMVar _dbInternalState (DbOpen ost) diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/State.hs b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/State.hs index a79da82e2b1..8b7627aceab 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/State.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/State.hs @@ -31,6 +31,7 @@ import Cardano.Prelude (NoUnexpectedThunks (..)) import Control.Monad.Class.MonadThrow hiding (onException) +import Ouroboros.Consensus.BlockchainTime (BlockchainTime) import Ouroboros.Consensus.Util (SomePair (..)) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry, @@ -67,6 +68,7 @@ data ImmutableDBEnv m hash = forall h e. ImmutableDBEnv , _dbTracer :: !(Tracer m (TraceEvent e hash)) , _dbRegistry :: !(ResourceRegistry m) , _dbCacheConfig :: !Index.CacheConfig + , _dbBlockchainTime :: !(BlockchainTime m) } data InternalState m hash h = diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/Validation.hs b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/Validation.hs index c009091611d..acee18b2d26 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/Validation.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/Validation.hs @@ -64,6 +64,7 @@ data ValidateEnv m hash h e = ValidateEnv , tracer :: !(Tracer m (TraceEvent e hash)) , registry :: !(ResourceRegistry m) , cacheConfig :: !Index.CacheConfig + , currentSlot :: !SlotNo } -- | Perform validation as per the 'ValidationPolicy' using 'validate' and @@ -296,7 +297,7 @@ validateEpoch ValidateEnv{..} shouldBeFinalised epoch mbPrevHash = do -- expensive integrity check of a block. let expectedChecksums = map Secondary.checksum entriesFromSecondaryIndex (entriesWithPrevHashes, mbErr) <- lift $ - runEpochFileParser parser epochFile expectedChecksums $ \stream -> + runEpochFileParser parser epochFile currentSlot expectedChecksums $ \stream -> (\(es :> mbErr) -> (es, mbErr)) <$> S.toList stream -- Check whether the first block of this epoch fits onto the last block of diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Parser.hs b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Parser.hs index 55e96c572cd..25db8f0f16c 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Parser.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Parser.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- | The ImmutableDB doesn't care about the serialisation format, but in -- practice we use CBOR. If we were to change the serialisation format, we -- would have to write a new 'EpochFileParser' implementation, but the rest of @@ -25,7 +26,7 @@ import qualified Streaming as S import qualified Streaming.Prelude as S import Ouroboros.Network.Block (ChainHash (..), HasHeader (..), - HeaderHash) + HeaderHash, SlotNo) import Ouroboros.Network.Point (WithOrigin (..)) import qualified Ouroboros.Consensus.Util.CBOR as Util.CBOR @@ -55,6 +56,12 @@ data EpochFileError hash = -- 'BlockOrEBB' number returned 'False', indicating that the block got -- corrupted. | EpochErrCorrupt hash BlockOrEBB + + -- | The block has a slot number equal to or greater than the current slot + -- (wall clock). This block is in the future, so we must truncate it. + | EpochErrFutureBlock + SlotNo -- ^ Current slot (wall clock) + SlotNo -- ^ Slot number of the block deriving (Eq, Show) epochFileParser' @@ -75,9 +82,14 @@ epochFileParser' hash epochFileParser' getSlotNo getHash getPrevHash hasFS decodeBlock isEBB getBinaryInfo isNotCorrupt = - EpochFileParser $ \fsPath expectedChecksums k -> + EpochFileParser $ \fsPath currentSlotNo expectedChecksums k -> Util.CBOR.withStreamIncrementalOffsets hasFS decoder fsPath - (k . checkIfHashesLineUp . checkEntries expectedChecksums) + ( k + . checkIfHashesLineUp + . checkEntries expectedChecksums + . checkFutureSlot currentSlotNo + . fmap (fmap (first EpochErrRead)) + ) where decoder :: forall s. Decoder s (BL.ByteString -> (blk, CRC)) decoder = decodeBlock <&> \mkBlk bs -> @@ -85,6 +97,21 @@ epochFileParser' getSlotNo getHash getPrevHash hasFS decodeBlock isEBB !checksum = computeCRC bs in (blk, checksum) + -- | Stop when a block has slot number >= the current slot, return + -- 'EpochErrFutureBlock'. + checkFutureSlot + :: SlotNo -- ^ Current slot (wall clock). + -> Stream (Of (Word64, (Word64, (blk, CRC)))) + m + (Maybe (EpochFileError hash, Word64)) + -> Stream (Of (Word64, (Word64, (blk, CRC)))) + m + (Maybe (EpochFileError hash, Word64)) + checkFutureSlot currentSlotNo = mapS $ \x@(offset, (_, (blk, _))) -> + if getSlotNo blk >= currentSlotNo + then Left $ Just (EpochErrFutureBlock currentSlotNo (getSlotNo blk), offset) + else Right x + -- | Go over the expected checksums and blocks in parallel. Stop with an -- error when a block is corrupt. Yield correct entries along the way. -- @@ -100,33 +127,36 @@ epochFileParser' getSlotNo getHash getPrevHash hasFS decodeBlock isEBB -- ^ Expected checksums -> Stream (Of (Word64, (Word64, (blk, CRC)))) m - (Maybe (Util.CBOR.ReadIncrementalErr, Word64)) + (Maybe (EpochFileError hash, Word64)) -- ^ Input stream of blocks (with additional info) -> Stream (Of (Secondary.Entry hash, WithOrigin hash)) m (Maybe (EpochFileError hash, Word64)) - checkEntries = go + checkEntries = \expected -> mapAccumS expected handle where - go expected blkAndInfos = S.lift (S.next blkAndInfos) >>= \case - -- No more blocks, but maybe some expected entries. We ignore them. - Left mbErr -> return $ first EpochErrRead <$> mbErr - -- A block - Right (blkAndInfo@(offset, (_, (blk, checksum))), blkAndInfos') -> - case expected of - expectedChecksum:expected' - | expectedChecksum == checksum - -> S.yield entryAndPrevHash *> go expected' blkAndInfos' - -- No expected entry or a mismatch - _ | isNotCorrupt blk - -- The (expensive) integrity check passed, so continue - -> S.yield entryAndPrevHash *> go (drop 1 expected) blkAndInfos' - | otherwise - -- The block is corrupt, stop - -> return $ Just (EpochErrCorrupt headerHash blockOrEBB, offset) - where - entryAndPrevHash@(actualEntry, _) = - entryForBlockAndInfo blkAndInfo - Secondary.Entry { headerHash, blockOrEBB } = actualEntry + handle + :: [CRC] + -> (Word64, (Word64, (blk, CRC))) + -> Either (Maybe (EpochFileError hash, Word64)) + ( (Secondary.Entry hash, WithOrigin hash) + , [CRC] + ) + handle expected blkAndInfo@(offset, (_, (blk, checksum))) = + case expected of + expectedChecksum:expected' + | expectedChecksum == checksum + -> Right (entryAndPrevHash, expected') + -- No expected entry or a mismatch + _ | isNotCorrupt blk + -- The (expensive) integrity check passed, so continue + -> Right (entryAndPrevHash, drop 1 expected) + | otherwise + -- The block is corrupt, stop + -> Left $ Just (EpochErrCorrupt headerHash blockOrEBB, offset) + where + entryAndPrevHash@(actualEntry, _) = + entryForBlockAndInfo blkAndInfo + Secondary.Entry { headerHash, blockOrEBB } = actualEntry entryForBlockAndInfo :: (Word64, (Word64, (blk, CRC))) @@ -154,26 +184,19 @@ epochFileParser' getSlotNo getHash getPrevHash hasFS decodeBlock isEBB -> Stream (Of (Secondary.Entry hash, WithOrigin hash)) m (Maybe (EpochFileError hash, Word64)) - checkIfHashesLineUp = \input -> S.lift (S.next input) >>= \case - Left mbErr -> - return mbErr - Right ((entry, prevHash), input') -> - S.yield (entry, prevHash) *> - go (At (Secondary.headerHash entry)) input' + checkIfHashesLineUp = mapAccumS0 checkFirst checkNext where - -- Loop invariant: the @hashOfPrevBlock@ is the hash of the most - -- recently checked block. - go hashOfPrevBlock input = S.lift (S.next input) >>= \case - Left mbErr - -> return mbErr - Right ((entry, prevHash), input') - | prevHash == hashOfPrevBlock - -> S.yield (entry, prevHash) *> - go (At (Secondary.headerHash entry)) input' - | otherwise - -> let err = EpochErrHashMismatch hashOfPrevBlock prevHash - offset = Secondary.unBlockOffset $ Secondary.blockOffset entry - in return $ Just (err, offset) + -- We pass the hash of the previous block around as the state (@s@). + checkFirst x@(entry, _) = Right (x, Secondary.headerHash entry) + + checkNext hashOfPrevBlock x@(entry, prevHash) + | prevHash == At hashOfPrevBlock + = Right (x, Secondary.headerHash entry) + | otherwise + = Left (Just (err, offset)) + where + err = EpochErrHashMismatch (At hashOfPrevBlock) prevHash + offset = Secondary.unBlockOffset $ Secondary.blockOffset entry -- | A version of 'epochFileParser'' for blocks that implement 'HasHeader'. epochFileParser @@ -195,3 +218,47 @@ epochFileParser = convertPrevHash :: ChainHash blk -> WithOrigin (HeaderHash blk) convertPrevHash GenesisHash = Origin convertPrevHash (BlockHash h) = At h + +{------------------------------------------------------------------------------- + Streaming utilities +-------------------------------------------------------------------------------} + +-- | Thread some state through a 'Stream'. An early return is possible by +-- returning 'Left'. +mapAccumS + :: Monad m + => s -- ^ Initial state + -> (s -> a -> Either r (b, s)) + -> Stream (Of a) m r + -> Stream (Of b) m r +mapAccumS st0 handle = go st0 + where + go st input = S.lift (S.next input) >>= \case + Left r -> return r + Right (a, input') -> case handle st a of + Left r -> return r + Right (b, st') -> S.yield b *> go st' input' + +-- | Variant of 'mapAccumS' that calls the first function argument on the +-- first element in the stream to construct the initial state. For all +-- elements in the stream after the first one, the second function argument is +-- used. +mapAccumS0 + :: forall m a b r s. Monad m + => (a -> Either r (b, s)) + -> (s -> a -> Either r (b, s)) + -> Stream (Of a) m r + -> Stream (Of b) m r +mapAccumS0 handleFirst handleNext = mapAccumS Nothing handle + where + handle :: Maybe s -> a -> Either r (b, Maybe s) + handle mbSt = fmap (fmap Just) . maybe handleFirst handleNext mbSt + +-- | Map over elements of a stream, allowing an early return by returning +-- 'Left'. +mapS + :: Monad m + => (a -> Either r b) + -> Stream (Of a) m r + -> Stream (Of b) m r +mapS handle = mapAccumS () (\() a -> (, ()) <$> handle a) diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Types.hs b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Types.hs index 4969e33e696..cd9bdee0e2d 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Types.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Types.hs @@ -107,13 +107,15 @@ newtype EpochFileParser e m entry hash = EpochFileParser { runEpochFileParser :: forall r. FsPath - -> [CRC] - -- The expected checksums are given as input. This list can be empty - -- when the secondary index file is missing. If the expected - -- checksum matches the actual checksum, we can avoid the expensive - -- integrity check of the block. + -> SlotNo + -- Current slot (wall clock) + -> [CRC] + -- The expected checksums are given as input. This list can be empty + -- when the secondary index file is missing. If the expected checksum + -- matches the actual checksum, we can avoid the expensive integrity + -- check of the block. -> (Stream (Of (entry, WithOrigin hash)) m (Maybe (e, Word64)) -> m r) - -- Continuation to ensure the file is closed + -- Continuation to ensure the file is closed -> m r } diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs index a77e005a634..912284945c0 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs @@ -20,6 +20,7 @@ import Ouroboros.Network.Block (BlockNo (..), ChainHash (..), SlotNo (..), blockPoint) import Ouroboros.Consensus.Block (BlockProtocol) +import Ouroboros.Consensus.BlockchainTime.Mock (fixedBlockchainTime) import Ouroboros.Consensus.Ledger.Byron (ByronBlock) import Ouroboros.Consensus.Ledger.Byron.Forge (forgeEBB) import Ouroboros.Consensus.Node.ProtocolInfo @@ -85,6 +86,7 @@ withImmDB k = withRegistry $ \registry -> do , immTracer = nullTracer , immCacheConfig = ImmDB.CacheConfig 2 60 , immRegistry = registry + , immBlockchainTime = fixedBlockchainTime 0 } testCfg :: NodeConfig (BlockProtocol ByronBlock) diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB.hs index 7308aaf5dcd..fdfb9dd2b18 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB.hs @@ -17,6 +17,7 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck (testProperty) import Ouroboros.Consensus.Block (getHeader) +import Ouroboros.Consensus.BlockchainTime.Mock (fixedBlockchainTime) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry @@ -77,6 +78,7 @@ openTestDB registry hasFS err = fst <$> openDBInternal parser nullTracer (Index.CacheConfig 2 60) + (fixedBlockchainTime maxBound) where parser = epochFileParser hasFS (const <$> S.decode) isEBB getBinaryInfo testBlockIsValid diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/Model.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/Model.hs index 0fe076e0cbd..08d06b0c2d4 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/Model.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/Model.hs @@ -28,6 +28,7 @@ module Test.Ouroboros.Storage.ImmutableDB.Model -- * ImmutableDB implementation , getTipModel , reopenModel + , reopenInThePastModel , deleteAfterModel , getBlockComponentModel , getEBBComponentModel @@ -420,6 +421,32 @@ getTipModel = dbmTip reopenModel :: DBModel hash -> (ImmTipWithHash hash, DBModel hash) reopenModel dbm = (dbmTip dbm, closeAllIterators dbm) +-- | Close all open iterators, truncate all blocks <= the given slot, and +-- return the current tip. +reopenInThePastModel :: SlotNo -- ^ Current slot + -> DBModel hash + -> (ImmTipWithHash hash, DBModel hash) +reopenInThePastModel curSlot dbm = (dbmTip dbm', dbm') + where + tipsInThePast :: NonEmpty (Tip EpochSlot) + tipsInThePast = TipGen NE.:| + [ snd <$> tip' + | tip <- NE.toList (tips dbm) + , let tip' = case tip of + TipGen -> TipGen + Tip (Block slot) -> Tip (slot, slotToEpochSlot dbm slot) + Tip (EBB epoch) -> Tip (epochSlotToSlot dbm epochSlot, epochSlot) + where + epochSlot = EpochSlot epoch 0 + , (fst <$> tip') < Tip curSlot + ] + + rollBackPoint = case NE.last tipsInThePast of + TipGen -> RollBackToGenesis + Tip epochSlot -> RollBackToEpochSlot epochSlot + + dbm' = rollBack rollBackPoint $ closeAllIterators dbm + deleteAfterModel :: ImmTip -> DBModel hash -> DBModel hash deleteAfterModel tip = -- First roll back to the given tip (which is not guaranteed to be diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs index 3966a67fa7c..041388ffb41 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs @@ -65,6 +65,8 @@ import Test.Tasty.QuickCheck (testProperty) import Text.Show.Pretty (ppShow) import Ouroboros.Consensus.Block (IsEBB (..), fromIsEBB, getHeader) +import Ouroboros.Consensus.BlockchainTime.Mock + (settableBlockchainTime) import qualified Ouroboros.Consensus.Util.Classify as C import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry @@ -126,6 +128,7 @@ data Cmd it | IteratorHasNext it | IteratorClose it | Reopen ValidationPolicy + | ReopenInThePast ValidationPolicy SlotNo -- ^ Current slot | DeleteAfter ImmTip | Corruption Corruption deriving (Generic, Show, Functor, Foldable, Traversable) @@ -214,7 +217,7 @@ run :: HasCallStack -> [TestIterator IO] -> Cmd (TestIterator IO) -> IO (Success (TestIterator IO)) -run ImmutableDBEnv { db, internal, registry, varNextId } runCorruption its cmd = case cmd of +run ImmutableDBEnv { db, internal, registry, varNextId, varCurSlot } runCorruption its cmd = case cmd of GetBlockComponent s -> MbAllComponents <$> getBlockComponent db allComponents s GetEBBComponent e -> MbAllComponents <$> getEBBComponent db allComponents e GetBlockOrEBBComponent s h -> MbAllComponents <$> getBlockOrEBBComponent db allComponents s h @@ -233,6 +236,15 @@ run ImmutableDBEnv { db, internal, registry, varNextId } runCorruption its cmd = closeDB db reopen db valPol Tip <$> getTip db + ReopenInThePast valPol curSlot -> do + mapM_ iteratorClose (unWithEq <$> its) + closeDB db + atomically $ writeTVar varCurSlot curSlot + reopen db valPol + -- Reset the current slot back to a value that won't get us into trouble + -- when we try to reopen the database + atomically $ writeTVar varCurSlot maxBound + Tip <$> getTip db Corruption corr -> do mapM_ iteratorClose (unWithEq <$> its) runCorruption db internal corr @@ -276,6 +288,7 @@ runPure = \case DeleteAfter tip -> ok Unit $ update_ (deleteAfterModel tip) Corruption corr -> ok Tip $ update (simulateCorruptions (getCorruptions corr)) Reopen _ -> ok Tip $ update reopenModel + ReopenInThePast _ s -> ok Tip $ update (reopenInThePastModel s) where query f m = (Right (f m), m) queryE f m = (f m, m) @@ -313,13 +326,15 @@ runPureErr dbm (CmdErr mbErrors cmd _its) = -- of the database will erase any changes. (Just _, (_resp, dbm')) -> -- We ignore the updated @dbm'@, because we have to roll back to the - -- state before executing cmd. The only exception is the DeleteAfter - -- cmd, in which case we have to roll back to the requested tip. + -- state before executing cmd. Exception: DeleteAfter and + -- ReopenInThePast cmd, in which case we have may have to truncate the + -- tip. -- -- As the implementation closes all iterators, we do the same. let dbm'' = closeAllIterators $ case cmd of - DeleteAfter _ -> dbm' - _ -> dbm + DeleteAfter {} -> dbm' + ReopenInThePast {} -> dbm' + _ -> dbm in (Resp $ Right $ Tip $ dbmTip dbm'', dbm'') {------------------------------------------------------------------------------- @@ -457,8 +472,9 @@ generator m@Model {..} = do where -- Don't simulate an error during corruption, because we don't want an -- error to happen while we corrupt a file. - errorFor Corruption {} = False - errorFor _ = True + errorFor Corruption {} = False + errorFor ReopenInThePast {} = False + errorFor _ = True -- | Generate a 'Cmd'. generateCmd :: Model m Symbolic -> Gen (At Cmd m Symbolic) @@ -531,6 +547,8 @@ generateCmd Model {..} = At <$> frequency , (1, return $ IteratorClose iter) ]) , (1, Reopen <$> genValPol) + , (1, ReopenInThePast <$> genValPol <*> chooseSlot (0, lastSlot)) + , (4, DeleteAfter <$> genTip) -- Only if there are files on disk can we generate commands that corrupt @@ -661,6 +679,7 @@ shrinkCmd Model {..} (At cmd) = fmap At $ case cmd of DeleteAfter tip -> [DeleteAfter tip' | tip' <- shrinkTip tip] Reopen {} -> [] + ReopenInThePast {} -> [] Corruption corr -> [Corruption corr' | corr' <- shrinkCorruption corr] where @@ -719,6 +738,8 @@ precondition Model {..} (At (CmdErr { _cmd = cmd })) = DeleteAfter tip -> tip `elem` NE.toList (tips dbModel) Corruption corr -> forall (corruptionFiles corr) (`elem` getDBFiles dbModel) + ReopenInThePast _ curSlot -> + 0 .<= curSlot .&& curSlot .<= lastSlot _ -> Top where corruptionFiles (MkCorruption corrs) = map snd $ NE.toList corrs @@ -728,6 +749,9 @@ precondition Model {..} (At (CmdErr { _cmd = cmd })) = Nothing -> blockPrevHash b .== Block.GenesisHash Just bPrev -> blockPrevHash b .== Block.BlockHash (blockHash bPrev) + lastSlot :: SlotNo + lastSlot = fromIntegral $ length $ dbmChain dbModel + transition :: (Show1 r, Eq1 r) => Model m r -> At CmdErr m r -> At Resp m r -> Model m r transition model cmdErr = eventAfter . lockstep model cmdErr @@ -743,12 +767,13 @@ postcondition model cmdErr resp = -- | Environment to run commands against the real ImmutableDB implementation. data ImmutableDBEnv h = ImmutableDBEnv - { varErrors :: StrictTVar IO Errors - , varNextId :: StrictTVar IO Id - , registry :: ResourceRegistry IO - , hasFS :: HasFS IO h - , db :: ImmutableDB Hash IO - , internal :: ImmDB.Internal Hash IO + { varErrors :: StrictTVar IO Errors + , varNextId :: StrictTVar IO Id + , varCurSlot :: StrictTVar IO SlotNo + , registry :: ResourceRegistry IO + , hasFS :: HasFS IO h + , db :: ImmutableDB Hash IO + , internal :: ImmDB.Internal Hash IO } semantics :: ImmutableDBEnv h @@ -891,6 +916,8 @@ data Tag | TagCorruption + | TagReopenInThePast + | TagErrorDuringAppendBlock | TagErrorDuringAppendEBB @@ -973,6 +1000,7 @@ tag = C.classify , tagIteratorStreamedN Map.empty , tagIteratorWithoutBounds , tagCorruption + , tagReopenInThePast , tagErrorDuring TagErrorDuringAppendBlock $ \case { At (AppendBlock {}) -> True; _ -> False } , tagErrorDuring TagErrorDuringAppendEBB $ \case @@ -1072,6 +1100,14 @@ tag = C.classify , C.predFinish = Nothing } + tagReopenInThePast :: EventPred m + tagReopenInThePast = C.Predicate + { C.predApply = \ev -> case eventCmd ev of + At (ReopenInThePast {}) -> Left TagReopenInThePast + _ -> Right tagReopenInThePast + , C.predFinish = Nothing + } + tagErrorDuring :: Tag -> (At Cmd m Symbolic -> Bool) -> EventPred m tagErrorDuring t isErr = simulatedError $ \ev -> if isErr (eventCmd ev) then Left t else Right $ tagErrorDuring t isErr @@ -1204,19 +1240,21 @@ test cacheConfig cmds = do fsVar <- QC.run $ uncheckedNewTVarM Mock.empty varErrors <- QC.run $ uncheckedNewTVarM mempty varNextId <- QC.run $ uncheckedNewTVarM 0 + varCurSlot <- QC.run $ uncheckedNewTVarM maxBound (tracer, getTrace) <- QC.run $ recordingTracerIORef registry <- QC.run $ unsafeNewRegistry let hasFS = mkSimErrorHasFS EH.monadCatch fsVar varErrors parser = epochFileParser hasFS (const <$> decode) isEBB getBinaryInfo testBlockIsValid + btime = settableBlockchainTime varCurSlot (db, internal) <- QC.run $ openDBInternal registry hasFS EH.monadCatch (fixedSizeEpochInfo fixedEpochSize) testHashInfo - ValidateMostRecentEpoch parser tracer cacheConfig + ValidateMostRecentEpoch parser tracer cacheConfig btime let env = ImmutableDBEnv - { varErrors, varNextId, registry, hasFS, db, internal } + { varErrors, varNextId, varCurSlot, registry, hasFS, db, internal } sm' = sm env dbm (hist, model, res) <- runCommands sm' cmds diff --git a/ouroboros-consensus/tools/db-analyse/Main.hs b/ouroboros-consensus/tools/db-analyse/Main.hs index cd600d59735..ee37ce2a4b8 100644 --- a/ouroboros-consensus/tools/db-analyse/Main.hs +++ b/ouroboros-consensus/tools/db-analyse/Main.hs @@ -26,6 +26,7 @@ import qualified Cardano.Crypto as Crypto import Ouroboros.Network.Block (HasHeader (..), SlotNo (..), genesisPoint) +import Ouroboros.Consensus.BlockchainTime.Mock (fixedBlockchainTime) import Ouroboros.Consensus.Ledger.Byron (ByronBlock, ByronConsensusProtocol, ByronHash) import qualified Ouroboros.Consensus.Ledger.Byron as Byron @@ -266,4 +267,6 @@ withImmDB fp cfg epochInfo registry = ImmDB.withImmDB args , immCheckIntegrity = nodeCheckIntegrity cfg , immAddHdrEnv = nodeAddHeaderEnvelope (Proxy @ByronBlock) , immRegistry = registry + -- We don't want to truncate blocks from the future + , immBlockchainTime = fixedBlockchainTime maxBound }