From 1357c1bd784bf52a68ed7ae2f0376845a28482f4 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 24 Jul 2024 17:01:51 +0200 Subject: [PATCH] ChainDB q-s-m test: add the LoE MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Nicolas “Niols” Jeannerod --- .../Test/Util/Orphans/Arbitrary.hs | 10 + .../Test/Util/Orphans/ToExpr.hs | 14 ++ .../Test/Ouroboros/Storage/ChainDB/Model.hs | 171 ++++++++++++++---- .../Ouroboros/Storage/ChainDB/Model/Test.hs | 31 ++-- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 121 ++++++++++--- .../ChainDB/StateMachine/Utils/RunOnRepl.hs | 14 +- .../Test/Ouroboros/Storage/ChainDB/Unit.hs | 17 +- 7 files changed, 295 insertions(+), 83 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs index b16791cff6..38559f5247 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs @@ -53,6 +53,7 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) +import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkNo (..), ChunkSize (..), RelativeSlot (..)) import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Layout @@ -407,3 +408,12 @@ instance Arbitrary Index.CacheConfig where -- TODO create a Cmd that advances time, so this is being exercised too. expireUnusedAfter <- (fromIntegral :: Int -> DiffTime) <$> choose (1, 100) return Index.CacheConfig {Index.pastChunksToCache, Index.expireUnusedAfter} + +{------------------------------------------------------------------------------- + LoE +-------------------------------------------------------------------------------} + +instance Arbitrary a => Arbitrary (LoE a) where + arbitrary = oneof [pure LoEDisabled, LoEEnabled <$> arbitrary] + shrink LoEDisabled = [] + shrink (LoEEnabled x) = LoEDisabled : map LoEEnabled (shrink x) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index cfec194c97..5be7e4b28c 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} @@ -18,9 +19,12 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB (InvalidBlockReason) +import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB import Ouroboros.Consensus.Storage.ImmutableDB import Ouroboros.Consensus.Util.STM (Fingerprint, WithFingerprint) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as Fragment import Ouroboros.Network.Block (MaxSlotNo) import Ouroboros.Network.Mock.Chain import Ouroboros.Network.Mock.ProducerState @@ -37,6 +41,14 @@ instance ToExpr (HeaderHash blk) => ToExpr (Point blk) instance ToExpr (HeaderHash blk) => ToExpr (RealPoint blk) instance (ToExpr slot, ToExpr hash) => ToExpr (Block slot hash) +deriving instance ( ToExpr blk + , ToExpr (HeaderHash blk) + ) + => ToExpr (Fragment.Anchor blk) + +instance (ToExpr blk, ToExpr (HeaderHash blk)) => ToExpr (AnchoredFragment blk) where + toExpr f = toExpr (Fragment.anchor f, Fragment.toOldestFirst f) + {------------------------------------------------------------------------------- ouroboros-consensus -------------------------------------------------------------------------------} @@ -73,6 +85,8 @@ instance ToExpr ChunkInfo where instance ToExpr FsError where toExpr fsError = App (show fsError) [] +deriving instance ToExpr a => ToExpr (LoE a) + {------------------------------------------------------------------------------- si-timers diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index b9fac6414f..80e1e34b47 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -70,9 +70,11 @@ module Test.Ouroboros.Storage.ChainDB.Model ( , garbageCollectable , garbageCollectableIteratorNext , garbageCollectablePoint + , getFragmentBetween , immutableDbChain , initLedger , reopen + , updateLoE , validChains , volatileDbBlocks , wipeVolatileDB @@ -81,8 +83,11 @@ module Test.Ouroboros.Storage.ChainDB.Model ( import Codec.Serialise (Serialise, serialise) import Control.Monad (unless) import Control.Monad.Except (runExcept) +import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as Lazy -import Data.Function (on) +import Data.Containers.ListUtils (nubOrdOn) +import Data.Function (on, (&)) +import Data.Functor (($>), (<&>)) import Data.List (isInfixOf, isPrefixOf, sortBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -104,8 +109,8 @@ import Ouroboros.Consensus.Protocol.MockChainSel import Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise (..), AddBlockResult (..), BlockComponent (..), ChainDbError (..), InvalidBlockReason (..), - IteratorResult (..), StreamFrom (..), StreamTo (..), - UnknownRange (..), validBounds) + IteratorResult (..), LoE (..), StreamFrom (..), + StreamTo (..), UnknownRange (..), validBounds) import Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel (olderThanK) import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.Util (repeatedly) @@ -119,7 +124,7 @@ import qualified Ouroboros.Network.Mock.Chain as Chain import Ouroboros.Network.Mock.ProducerState (ChainProducerState) import qualified Ouroboros.Network.Mock.ProducerState as CPS import Test.Cardano.Slotting.TreeDiff () - +import Test.Util.Orphans.ToExpr () type IteratorId = Int @@ -136,6 +141,7 @@ data Model blk = Model { , valid :: Set (HeaderHash blk) , invalid :: InvalidBlocks blk , currentSlot :: SlotNo + , loeFragment :: LoE (AnchoredFragment blk) , maxClockSkew :: Word64 -- ^ Max clock skew in terms of slots. A static configuration parameter. , isOpen :: Bool @@ -364,10 +370,12 @@ getLedgerDB cfg m@Model{..} = -------------------------------------------------------------------------------} empty :: - ExtLedgerState blk + HasHeader blk + => LoE () + -> ExtLedgerState blk -> Word64 -- ^ Max clock skew in number of blocks -> Model blk -empty initLedger maxClockSkew = Model { +empty loe initLedger maxClockSkew = Model { volatileDbBlocks = Map.empty , immutableDbChain = Chain.Genesis , cps = CPS.initChainProducerState Chain.Genesis @@ -379,6 +387,7 @@ empty initLedger maxClockSkew = Model { , currentSlot = 0 , maxClockSkew = maxClockSkew , isOpen = True + , loeFragment = loe $> Fragment.Empty Fragment.AnchorGenesis } -- | Advance the 'currentSlot' of the model to the given 'SlotNo' if the @@ -392,22 +401,13 @@ addBlock :: forall blk. LedgerSupportsProtocol blk => TopLevelConfig blk -> blk -> Model blk -> Model blk -addBlock cfg blk m = Model { - volatileDbBlocks = volatileDbBlocks' - , immutableDbChain = immutableDbChain m - , cps = CPS.switchFork newChain (cps m) - , currentLedger = newLedger - , initLedger = initLedger m - , iterators = iterators m - , valid = valid' - , invalid = invalid' - , currentSlot = currentSlot m - , maxClockSkew = maxClockSkew m - , isOpen = True - } +addBlock cfg blk m + | ignoreBlock = m + | otherwise = chainSelection cfg m { + volatileDbBlocks = Map.insert (blockHash blk) blk (volatileDbBlocks m) + } where secParam = configSecurityParam cfg - immBlockNo = immutableBlockNo secParam m hdr = getHeader blk @@ -419,25 +419,38 @@ addBlock cfg blk m = Model { -- If it's an invalid block we've seen before, ignore it. Map.member (blockHash blk) (invalid m) - volatileDbBlocks' :: Map (HeaderHash blk) blk - volatileDbBlocks' - | ignoreBlock - = volatileDbBlocks m - | otherwise - = Map.insert (blockHash blk) blk (volatileDbBlocks m) +chainSelection :: forall blk. LedgerSupportsProtocol blk + => TopLevelConfig blk + -> Model blk -> Model blk +chainSelection cfg m = Model { + volatileDbBlocks = volatileDbBlocks m + , immutableDbChain = immutableDbChain m + , cps = CPS.switchFork newChain (cps m) + , currentLedger = newLedger + , initLedger = initLedger m + , iterators = iterators m + , valid = valid' + , invalid = invalid' + , currentSlot = currentSlot m + , maxClockSkew = maxClockSkew m + , isOpen = True + , loeFragment = loeFragment m + } + where + secParam = configSecurityParam cfg -- @invalid'@ will be a (non-strict) superset of the previous value of -- @invalid@, see 'validChains', thus no need to union. invalid' :: InvalidBlocks blk candidates :: [(Chain blk, ExtLedgerState blk)] - (invalid', candidates) = - validChains cfg m (immutableDbBlocks m <> volatileDbBlocks') + (invalid', candidates) = validChains cfg m (blocks m) immutableChainHashes = map blockHash . Chain.toOldestFirst - . immutableChain secParam - $ m + $ immutableChain' + + immutableChain' = immutableChain secParam m extendsImmutableChain :: Chain blk -> Bool extendsImmutableChain fork = @@ -445,8 +458,66 @@ addBlock cfg blk m = Model { map blockHash (Chain.toOldestFirst fork) -- Note that this includes the currently selected chain, but that does not - -- influence chain selection via 'selectChain'. - consideredCandidates = filter (extendsImmutableChain . fst) candidates + -- influence chain selection via 'selectChain'. Note that duplicates might + -- be introduced by `trimToLoE` so we deduplicate explicitly here. + consideredCandidates = + candidates + & filter (extendsImmutableChain . fst) + & map (first trimToLoE) + & nubOrdOn (Chain.headPoint . fst) + + currentChain' = currentChain m + + -- | Trim a candidate fragment to the LoE fragment. + -- + -- - A (sanitized) LoE fragment @loe@ is some fragment containing the + -- immutable tip. + -- + -- - A candidate fragment @cf@ is valid according to the LoE in one of two + -- cases: + -- - @loe@ is an extension of @cf@. + -- - @cf@ is an extension of @loe@, and @cf@ has at most @k@ blocks after + -- the tip of loe. + -- + -- - Trimming a candidate fragment according to the LoE is defined to be the + -- longest prefix that is valid according to the LoE. + -- + -- NOTE: It is possible that `trimToLoE a == trimToLoE b` even though `a /= + -- b` if the longest prefix is the same. + trimToLoE :: Chain blk -> Chain blk + trimToLoE candidate = + case loeChain of + LoEDisabled -> candidate + LoEEnabled loeChain' -> + Chain.fromOldestFirst $ go (Chain.toOldestFirst candidate) loePoints + where + loePoints = blockPoint <$> Chain.toOldestFirst loeChain' + where + SecurityParam k = secParam + + go :: [blk] -> [Point blk] -> [blk] + -- The LoE chain is an extension of the candidate, return the candidate. + go [] _loePoints = [] + -- The candidate is an extension of the LoE chain, return at most the + -- next k blocks on the candidate. + go blks [] = take (fromIntegral k) blks + go (blk : blks) (pt : loePoints) + -- The candidate and the LoE chain agree on the next point, continue + -- recursively. + | blockPoint blk == pt = blk : go blks loePoints + -- The candidate forks off from the LoE chain; stop here. + | otherwise = [] + + -- If the LoE fragment does not intersect with the current volatile chain, + -- then we use the immutable chain instead. + loeChain = + loeFragment m <&> \loeFragment' -> fromMaybe immutableChain' $ do + _ <- Fragment.intersect volatileFrag loeFragment' + (_, loeChain') <- Fragment.cross currentFrag loeFragment' + Chain.fromAnchoredFragment loeChain' + where + currentFrag = Chain.toAnchoredFragment currentChain' + volatileFrag = volatileChain secParam id m newChain :: Chain blk newLedger :: ExtLedgerState blk @@ -491,6 +562,18 @@ addBlockPromise cfg blk m = (result, m') , blockProcessed = return $ SuccesfullyAddedBlock $ tipPoint m' } +-- | Update the LoE fragment, trigger chain selection and return the new tip +-- point. +updateLoE :: + forall blk. LedgerSupportsProtocol blk + => TopLevelConfig blk + -> AnchoredFragment blk + -> Model blk + -> (Point blk, Model blk) +updateLoE cfg f m = (tipPoint m', m') + where + m' = chainSelection cfg $ m {loeFragment = loeFragment m $> f} + {------------------------------------------------------------------------------- Iterators -------------------------------------------------------------------------------} @@ -756,7 +839,6 @@ validate cfg Model { currentSlot, maxClockSkew, initLedger, invalid } chain = | otherwise -> findInvalidBlockInTheFuture ledger' bs' - chains :: forall blk. (GetPrevHash blk) => Map (HeaderHash blk) blk -> [Chain blk] chains bs = go Chain.Genesis @@ -1041,3 +1123,26 @@ wipeVolatileDB cfg m = -> error "Did not select the ImmutableDB's chain" toHashes = map blockHash . Chain.toOldestFirst + +-- | Look in the given blocks database for a fragment spanning from the given +-- anchor to the given hash, and return the fragment in question, or 'Nothing'. +getFragmentBetween :: + forall blk. GetPrevHash blk + => Map (HeaderHash blk) blk + -- ^ A map of blocks; usually the 'volatileDbBlocks' of a 'Model'. + -> Fragment.Anchor blk + -- ^ The anchor of the fragment to get. + -> ChainHash blk + -- ^ The hash of the block to get the fragment up to. + -> Maybe (AnchoredFragment blk) +getFragmentBetween bs anchor = go + where + go :: ChainHash blk -> Maybe (AnchoredFragment blk) + go hash | hash == Fragment.anchorToHash anchor = + Just $ Fragment.Empty anchor + go GenesisHash = + Nothing + go (BlockHash hash) = do + block <- Map.lookup hash bs + prevFragment <- go $ blockPrevHash block + Just $ prevFragment Fragment.:> block diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs index 132008609b..a0e0e085f9 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs @@ -27,8 +27,8 @@ module Test.Ouroboros.Storage.ChainDB.Model.Test (tests) where import GHC.Stack import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config -import Ouroboros.Consensus.Storage.ChainDB.API (StreamFrom (..), - StreamTo (..)) +import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..), + StreamFrom (..), StreamTo (..)) import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF import qualified Ouroboros.Network.AnchoredFragment as AF import qualified Ouroboros.Network.Mock.Chain as Chain @@ -37,6 +37,7 @@ import Test.Ouroboros.Storage.ChainDB.Model (ModelSupportsBlock) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck +import Test.Util.Orphans.Arbitrary () import Test.Util.TestBlock tests :: TestTree @@ -47,32 +48,36 @@ tests = testGroup "Model" [ , testProperty "between_currentChain" prop_between_currentChain ] -addBlocks :: [TestBlock] -> M.Model TestBlock -addBlocks blks = M.addBlocks cfg blks m +addBlocks :: LoE () -> [TestBlock] -> M.Model TestBlock +addBlocks loe blks = M.addBlocks cfg blks m where cfg = singleNodeTestConfig -- Set the current slot to 'maxBound' so that no block is in the future - m = M.advanceCurSlot maxBound (M.empty testInitExtLedger 0) + m = M.advanceCurSlot maxBound (M.empty loe testInitExtLedger 0) -prop_getBlock_addBlock :: BlockTree -> Permutation -> Property -prop_getBlock_addBlock bt p = +prop_getBlock_addBlock :: LoE () -> BlockTree -> Permutation -> Property +prop_getBlock_addBlock loe bt p = M.getBlock (blockHash newBlock) (M.addBlock singleNodeTestConfig newBlock model) === if NotOrigin (blockNo newBlock) > M.immutableBlockNo secParam model then Just newBlock else Nothing where (newBlock:initBlocks) = permute p $ treeToBlocks bt - model = addBlocks initBlocks + model = addBlocks loe initBlocks secParam = configSecurityParam singleNodeTestConfig +-- | Test that, for any chain @bc@, adding its blocks to an empty model causes +-- the selection to be @bc@. This is only true with LoE disabled. prop_getChain_addChain :: BlockChain -> Property prop_getChain_addChain bc = counterexample ("model: " ++ show model) $ blockChain bc === M.currentChain model where blocks = chainToBlocks bc - model = addBlocks blocks + model = addBlocks LoEDisabled blocks +-- | Test that, no matter in which order we add blocks to the chain DB, we +-- always pick the most preferred chain. This is only true with LoE disabled. prop_alwaysPickPreferredChain :: BlockTree -> Permutation -> Property prop_alwaysPickPreferredChain bt p = counterexample ("blocks: " ++ show blocks) $ @@ -83,7 +88,7 @@ prop_alwaysPickPreferredChain bt p = ] where blocks = permute p $ treeToBlocks bt - model = addBlocks blocks + model = addBlocks LoEDisabled blocks current = M.currentChain model curFragment = Chain.toAnchoredFragment (getHeader <$> current) @@ -99,13 +104,13 @@ prop_alwaysPickPreferredChain bt p = candFragment = Chain.toAnchoredFragment (getHeader <$> candidate) -- TODO add properties about forks too -prop_between_currentChain :: BlockTree -> Property -prop_between_currentChain bt = +prop_between_currentChain :: LoE () -> BlockTree -> Property +prop_between_currentChain loe bt = Right (AF.toOldestFirst $ Chain.toAnchoredFragment $ M.currentChain model) === M.between secParam from to model where blocks = treeToBlocks bt - model = addBlocks blocks + model = addBlocks loe blocks from = StreamFromExclusive GenesisPoint to = StreamToInclusive $ cantBeGenesis (M.tipPoint model) secParam = configSecurityParam singleNodeTestConfig 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 bd395bb824..184f018a4b 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 @@ -87,6 +87,8 @@ import Data.Bifunctor import qualified Data.Bifunctor.TH as TH import Data.Bitraversable import Data.ByteString.Lazy (ByteString) +import Data.Function (on) +import Data.Functor (($>)) import Data.Functor.Classes (Eq1, Show1) import Data.Functor.Identity (Identity) import Data.List (sortOn) @@ -153,6 +155,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.ChainDB import Test.Util.ChunkInfo +import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.ToExpr () import Test.Util.QuickCheck import qualified Test.Util.RefEnv as RE @@ -171,7 +174,7 @@ import Test.Util.WithEq data Cmd blk it flr = AddBlock blk -- ^ Advance the current slot to the block's slot (unless smaller than the - -- current slot) and add the block. + -- current slot), add the block and run chain selection. | AddFutureBlock blk SlotNo -- ^ Advance the current slot to the given slot, which is guaranteed to be -- smaller than the block's slot number (such that the block is from the @@ -187,6 +190,8 @@ data Cmd blk it flr | GetMaxSlotNo | GetIsValid (RealPoint blk) | Stream (StreamFrom blk) (StreamTo blk) + | UpdateLoE (AnchoredFragment blk) + -- ^ Update the LoE fragment and run chain selection. | IteratorNext it | IteratorNextGCed it -- ^ Only for blocks that may have been garbage collected. @@ -358,6 +363,7 @@ data ChainDBEnv m blk = ChainDBEnv { , varVolatileDbFs :: StrictTVar m MockFS , args :: ChainDbArgs Identity m blk -- ^ Needed to reopen a ChainDB, i.e., open a new one. + , varLoEFragment :: StrictTVar m (AnchoredFragment (Header blk)) } open :: @@ -400,6 +406,7 @@ run env@ChainDBEnv { varDB, .. } cmd = GetGCedBlockComponent pt -> mbGCedAllComponents <$> getBlockComponent allComponents pt GetIsValid pt -> isValidResult <$> ($ pt) <$> atomically getIsValid GetMaxSlotNo -> MaxSlot <$> atomically getMaxSlotNo + UpdateLoE frag -> Point <$> updateLoE st frag Stream from to -> iter =<< stream registry allComponents from to IteratorNext it -> IterResult <$> iteratorNext (unWithEq it) IteratorNextGCed it -> iterResultGCed <$> iteratorNext (unWithEq it) @@ -427,10 +434,18 @@ run env@ChainDBEnv { varDB, .. } cmd = atomically $ modifyTVar varCurSlot (max newCurSlot) -- `blockProcessed` always returns 'Just' res <- addBlock chainDB InvalidBlockPunishment.noPunishment blk + ChainDB.triggerChainSelection chainDB return $ case res of FailedToAddBlock f -> error $ "advanceAndAdd: block not added - " ++ f SuccesfullyAddedBlock pt -> pt + updateLoE :: ChainDBState m blk -> AnchoredFragment blk -> m (Point blk) + updateLoE ChainDBState { chainDB } frag = do + let headersFrag = AF.mapAnchoredFragment getHeader frag + atomically $ writeTVar varLoEFragment headersFrag + ChainDB.triggerChainSelection chainDB + atomically $ getTipPoint chainDB + wipeVolatileDB :: ChainDBState m blk -> m (Point blk) wipeVolatileDB st = do close st @@ -635,6 +650,7 @@ runPure cfg = \case GetGCedBlockComponent pt -> err mbGCedAllComponents $ query (Model.getBlockComponentByPoint allComponents pt) GetMaxSlotNo -> ok MaxSlot $ query Model.getMaxSlotNo GetIsValid pt -> ok isValidResult $ query (Model.isValid pt) + UpdateLoE frag -> ok Point $ update (Model.updateLoE cfg frag) Stream from to -> err iter $ updateE (Model.stream k from to) IteratorNext it -> ok IterResult $ update (Model.iteratorNext it allComponents) IteratorNextGCed it -> ok iterResultGCed $ update (Model.iteratorNext it allComponents) @@ -753,12 +769,14 @@ data Model blk m r = Model deriving instance (TestConstraints blk, Show1 r) => Show (Model blk m r) -- | Initial model -initModel :: TopLevelConfig blk +initModel :: HasHeader blk + => LoE () + -> TopLevelConfig blk -> ExtLedgerState blk -> MaxClockSkew -> Model blk m r -initModel cfg initLedger (MaxClockSkew maxClockSkew) = Model - { dbModel = Model.empty initLedger maxClockSkew +initModel loe cfg initLedger (MaxClockSkew maxClockSkew) = Model + { dbModel = Model.empty loe initLedger maxClockSkew , knownIters = RE.empty , knownFollowers = RE.empty , modelConfig = QSM.Opaque cfg @@ -876,10 +894,11 @@ type BlockGen blk m = Model blk m Symbolic -> Gen blk -- | Generate a 'Cmd' generator :: forall blk m. TestConstraints blk - => BlockGen blk m + => LoE () + -> BlockGen blk m -> Model blk m Symbolic -> Gen (At Cmd blk m Symbolic) -generator genBlock m@Model {..} = At <$> frequency +generator loe genBlock m@Model {..} = At <$> frequency [ (30, genAddBlock) , (if empty then 1 else 10, return GetCurrentChain) , (if empty then 1 else 10, return GetLedgerDB) @@ -890,6 +909,11 @@ generator genBlock m@Model {..} = At <$> frequency , (if empty then 1 else 10, return GetMaxSlotNo) , (if empty then 1 else 10, genGetIsValid) + , let freq = case loe of + LoEDisabled -> 0 + LoEEnabled () -> if empty then 1 else 10 + in (freq, UpdateLoE <$> genLoEFragment) + -- Iterators , (if empty then 1 else 10, uncurry Stream <$> genBounds) , (if null iterators then 0 else 20, genIteratorNext) @@ -933,8 +957,36 @@ generator genBlock m@Model {..} = At <$> frequency genRandomPoint :: Gen (RealPoint blk) genRandomPoint = blockRealPoint <$> genBlock m + blocksInDB :: Map.Map (HeaderHash blk) blk + blocksInDB = Model.blocks dbModel + pointsInDB :: [RealPoint blk] - pointsInDB = blockRealPoint <$> Map.elems (Model.blocks dbModel) + pointsInDB = blockRealPoint <$> Map.elems blocksInDB + + genLoEFragment :: Gen (AnchoredFragment blk) + genLoEFragment = frequency + [ (1, return $ AF.Empty AF.AnchorGenesis) + , (20, flip suchThatMap id $ do + -- Generate a fragment between an anchor in the ImmutableDB and a + -- tip corresponding to either the immutable tip, a volatile block + -- or a block not yet in the ChainDB. + anchor <- elements $ + AF.AnchorGenesis : fmap AF.anchorFromBlock immutableBlocks + blk <- genBlock m + tip <- frequency + [ (1, pure $ Chain.headHash immutableChain) + , (5, pure $ BlockHash (blockHash blk)) + , ( if null volatileBlocks then 0 else 5 + , elements $ BlockHash . blockHash <$> volatileBlocks + ) + ] + let blks = Map.insert (blockHash blk) blk blocksInDB + pure $ Model.getFragmentBetween blks anchor tip) + ] + where + immutableChain = Model.immutableChain secParam dbModel + immutableBlocks = Chain.toNewestFirst immutableChain + volatileBlocks = Map.elems $ Model.volatileDbBlocks dbModel empty :: Bool empty = null pointsInDB @@ -1180,7 +1232,8 @@ semantics env (At cmd) = -- | The state machine proper sm :: TestConstraints blk - => ChainDBEnv IO blk + => LoE () + -> ChainDBEnv IO blk -> BlockGen blk IO -> TopLevelConfig blk -> ExtLedgerState blk @@ -1189,12 +1242,12 @@ sm :: TestConstraints blk (At Cmd blk IO) IO (At Resp blk IO) -sm env genBlock cfg initLedger maxClockSkew = StateMachine - { initModel = initModel cfg initLedger maxClockSkew +sm loe env genBlock cfg initLedger maxClockSkew = StateMachine + { initModel = initModel loe cfg initLedger maxClockSkew , transition = transition , precondition = precondition , postcondition = postcondition - , generator = Just . generator genBlock + , generator = Just . generator loe genBlock , shrinker = shrinker , semantics = semantics env , mock = mock @@ -1221,7 +1274,6 @@ deriving instance ( ToExpr blk , ToExpr (ExtValidationError blk) ) => ToExpr (Model blk IO Concrete) - {------------------------------------------------------------------------------- Labelling -------------------------------------------------------------------------------} @@ -1256,6 +1308,8 @@ deriving instance SOP.HasDatatypeInfo (VolatileDB.TraceEvent blk) data Tag = TagGetIsValidJust | TagGetIsValidNothing + | TagChainSelReprocessChangedSelection + | TagChainSelReprocessKeptSelection deriving (Show, Eq) -- | Predicate on events @@ -1279,6 +1333,8 @@ tag :: forall m. [Event Blk m Symbolic] -> [Tag] tag = C.classify [ tagGetIsValidJust , tagGetIsValidNothing + , tagChainSelReprocess TagChainSelReprocessChangedSelection (/=) + , tagChainSelReprocess TagChainSelReprocessKeptSelection (==) ] where tagGetIsValidJust :: EventPred m @@ -1293,6 +1349,14 @@ tag = C.classify [ Left TagGetIsValidNothing _ -> Right tagGetIsValidNothing + tagChainSelReprocess :: + Tag -> (Point TestBlock -> Point TestBlock -> Bool) -> EventPred m + tagChainSelReprocess t test = successful $ \ev _r -> case unAt $ eventCmd ev of + UpdateLoE{} + | (test `on` Model.tipPoint . dbModel) (eventBefore ev) (eventAfter ev) + -> Left t + _ -> Right $ tagChainSelReprocess t test + -- | Step the model using a 'QSM.Command' (i.e., a command associated with -- an explicit set of variables) execCmd :: Model Blk m Symbolic @@ -1438,28 +1502,31 @@ mkTestCfg (ImmutableDB.UniformChunkSize chunkSize) = envUnused :: ChainDBEnv m blk envUnused = error "ChainDBEnv used during command generation" -smUnused :: MaxClockSkew +smUnused :: LoE () + -> MaxClockSkew -> ImmutableDB.ChunkInfo -> StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO) -smUnused maxClockSkew chunkInfo = +smUnused loe maxClockSkew chunkInfo = sm + loe envUnused (genBlk chunkInfo) (mkTestCfg chunkInfo) testInitExtLedger maxClockSkew -prop_sequential :: MaxClockSkew -> SmallChunkInfo -> Property -prop_sequential maxClockSkew smallChunkInfo@(SmallChunkInfo chunkInfo) = - forAllCommands (smUnused maxClockSkew chunkInfo) Nothing $ - runCmdsLockstep maxClockSkew smallChunkInfo +prop_sequential :: LoE () -> MaxClockSkew -> SmallChunkInfo -> Property +prop_sequential loe maxClockSkew smallChunkInfo@(SmallChunkInfo chunkInfo) = + forAllCommands (smUnused loe maxClockSkew chunkInfo) Nothing $ + runCmdsLockstep loe maxClockSkew smallChunkInfo runCmdsLockstep :: - MaxClockSkew + LoE () + -> MaxClockSkew -> SmallChunkInfo -> QSM.Commands (At Cmd Blk IO) (At Resp Blk IO) -> Property -runCmdsLockstep maxClockSkew (SmallChunkInfo chunkInfo) cmds = +runCmdsLockstep loe maxClockSkew (SmallChunkInfo chunkInfo) cmds = QC.monadicIO $ do let -- Current test case command names. @@ -1467,10 +1534,10 @@ runCmdsLockstep maxClockSkew (SmallChunkInfo chunkInfo) cmds = ctcCmdNames = fmap (show . cmdName . QSM.getCommand) $ QSM.unCommands cmds (hist, prop) <- QC.run $ test cmds - prettyCommands (smUnused maxClockSkew chunkInfo) hist + prettyCommands (smUnused loe maxClockSkew chunkInfo) hist $ tabulate "Tags" - (map show $ tag (execCmds (QSM.initModel (smUnused maxClockSkew chunkInfo)) cmds)) + (map show $ tag (execCmds (QSM.initModel (smUnused loe maxClockSkew chunkInfo)) cmds)) $ tabulate "Command sequence length" [show $ length ctcCmdNames] $ tabulate "Commands" ctcCmdNames $ prop @@ -1489,6 +1556,7 @@ runCmdsLockstep maxClockSkew (SmallChunkInfo chunkInfo) cmds = varCurSlot <- uncheckedNewTVarM 0 varNextId <- uncheckedNewTVarM 0 nodeDBs <- emptyNodeDBs + varLoEFragment <- newTVarIO $ AF.Empty AF.AnchorGenesis let args = mkArgs testCfg chunkInfo @@ -1498,6 +1566,7 @@ runCmdsLockstep maxClockSkew (SmallChunkInfo chunkInfo) cmds = tracer maxClockSkew varCurSlot + (loe $> varLoEFragment) (hist, model, res, trace) <- bracket (open args >>= newTVarIO) @@ -1513,9 +1582,10 @@ runCmdsLockstep maxClockSkew (SmallChunkInfo chunkInfo) cmds = , varCurSlot , varNextId , varVolatileDbFs = nodeDBsVol nodeDBs + , varLoEFragment , args } - sm' = sm env (genBlk chunkInfo) testCfg testInitExtLedger maxClockSkew + sm' = sm loe env (genBlk chunkInfo) testCfg testInitExtLedger maxClockSkew (hist, model, res) <- QSM.runCommands' sm' cmds' trace <- getTrace return (hist, model, res, trace) @@ -1538,6 +1608,7 @@ runCmdsLockstep maxClockSkew (SmallChunkInfo chunkInfo) cmds = let modelChain = Model.currentChain $ dbModel model prop = + counterexample (show (configSecurityParam testCfg)) $ counterexample ("Model chain: " <> condense modelChain) $ counterexample ("TraceEvents: " <> unlines (map show trace)) $ tabulate "Chain length" [show (Chain.length modelChain)] $ @@ -1641,8 +1712,9 @@ mkArgs :: IOLike m -> CT.Tracer m (TraceEvent Blk) -> MaxClockSkew -> StrictTVar m SlotNo + -> LoE (StrictTVar m (AnchoredFragment (Header Blk))) -> ChainDbArgs Identity m Blk -mkArgs cfg chunkInfo initLedger registry nodeDBs tracer (MaxClockSkew maxClockSkew) varCurSlot = +mkArgs cfg chunkInfo initLedger registry nodeDBs tracer (MaxClockSkew maxClockSkew) varCurSlot varLoEFragment = let args = fromMinimalChainDbArgs MinimalChainDbArgs { mcdbTopLevelConfig = cfg , mcdbChunkInfo = chunkInfo @@ -1654,6 +1726,7 @@ mkArgs cfg chunkInfo initLedger registry nodeDBs tracer (MaxClockSkew maxClockSk args { cdbsArgs = (cdbsArgs args) { ChainDB.cdbsCheckInFuture = InFuture.miracle (readTVar varCurSlot) maxClockSkew , ChainDB.cdbsBlocksToAddSize = 2 + , ChainDB.cdbsLoE = traverse (atomically . readTVar) varLoEFragment } , cdbImmDbArgs = (cdbImmDbArgs args) { ImmutableDB.immCheckIntegrity = testBlockIsValid diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs index 87f6c9829a..54303d23f2 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs @@ -30,10 +30,11 @@ -- Then, the model and system under tests can be tested for lockstep agreement -- by running: -- --- > quickCheckCmdsLockStep someClockSkew someChunkInfo counterexample +-- > quickCheckCmdsLockStep someLoE someClockSkew someChunkInfo counterexample -- -- Where 'someClockSkew' and 'someChunkInfo' are the ones given by the --- counterexample found by quickcheck-statemachine. +-- counterexample found by quickcheck-statemachine, and 'someLoE' is @LoEEnabled +-- ()@ or @LoEDisabled@. module Test.Ouroboros.Storage.ChainDB.StateMachine.Utils.RunOnRepl ( -- * Running the counterexamples quickCheckCmdsLockStep @@ -78,7 +79,7 @@ import Ouroboros.Consensus.Block (BlockNo (BlockNo), ChainHash (BlockHash, GenesisHash), EpochNo (EpochNo), SlotNo (SlotNo)) import Ouroboros.Consensus.Storage.ChainDB - (ChainType (TentativeChain)) + (ChainType (TentativeChain), LoE) import Ouroboros.Consensus.Storage.ImmutableDB (ChunkInfo (UniformChunkSize), ChunkSize (ChunkSize, chunkCanContainEBB, numRegularBlocks)) @@ -113,9 +114,10 @@ pattern Command cmd rsp xs = StateMachine.Types.Command (StateMachine.At cmd) (StateMachine.At rsp) xs quickCheckCmdsLockStep :: - MaxClockSkew + LoE () + -> MaxClockSkew -> SmallChunkInfo -> Commands (StateMachine.At Cmd TestBlock IO) (StateMachine.At Resp TestBlock IO) -> IO () -quickCheckCmdsLockStep maxClockSkew chunkInfo cmds = - quickCheck $ runCmdsLockstep maxClockSkew chunkInfo cmds +quickCheckCmdsLockStep loe maxClockSkew chunkInfo cmds = + quickCheck $ runCmdsLockstep loe maxClockSkew chunkInfo cmds diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs index a0922ef467..ebed9ed523 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs @@ -42,6 +42,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks as ImmutableDB import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry (closeRegistry, unsafeNewRegistry) +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (ChainUpdate (..), Point, blockPoint) import qualified Ouroboros.Network.Mock.Chain as Mock import qualified Test.Ouroboros.Storage.ChainDB.Model as Model @@ -61,19 +62,19 @@ import Test.Util.Tracer (recordingTracerTVar) tests :: TestTree tests = testGroup "Unit tests" [ testGroup "First follower instruction isJust on empty ChainDB" - [ testCase "model" $ runModelIO followerInstructionOnEmptyChain + [ testCase "model" $ runModelIO API.LoEDisabled followerInstructionOnEmptyChain , testCase "system" $ runSystemIO followerInstructionOnEmptyChain ] , testGroup "Follower switches to new chain" - [ testCase "model" $ runModelIO followerSwitchesToNewChain + [ testCase "model" $ runModelIO API.LoEDisabled followerSwitchesToNewChain , testCase "system" $ runSystemIO followerSwitchesToNewChain ] , testGroup (ouroborosNetworkIssue 4183) - [ testCase "model" $ runModelIO ouroboros_network_4183 + [ testCase "model" $ runModelIO API.LoEDisabled ouroboros_network_4183 , testCase "system" $ runSystemIO ouroboros_network_4183 ] , testGroup (ouroborosNetworkIssue 3999) - [ testCase "model" $ runModelIO ouroboros_network_3999 + [ testCase "model" $ runModelIO API.LoEDisabled ouroboros_network_3999 , testCase "system" $ runSystemIO ouroboros_network_3999 ] ] @@ -218,11 +219,11 @@ extractBlock (blk, _, _, _, _, _, _, _, _, _, _) = blk -- | Helper function to run the test against the model and translate to something -- that HUnit likes. -runModelIO :: ModelM TestBlock a -> IO () -runModelIO expr = toAssertion (runModel newModel topLevelConfig expr) +runModelIO :: API.LoE () -> ModelM TestBlock a -> IO () +runModelIO loe expr = toAssertion (runModel newModel topLevelConfig expr) where chunkInfo = ImmutableDB.simpleChunkInfo 100 - newModel = Model.empty testInitExtLedger 0 + newModel = Model.empty loe testInitExtLedger 0 topLevelConfig = mkTestCfg chunkInfo @@ -408,6 +409,7 @@ withTestChainDbEnv topLevelConfig chunkInfo extLedgerState cont iteratorRegistry <- unsafeNewRegistry varCurSlot <- uncheckedNewTVarM 0 varNextId <- uncheckedNewTVarM 0 + varLoEFragment <- newTVarIO $ AF.Empty AF.AnchorGenesis nodeDbs <- emptyNodeDBs (tracer, getTrace) <- recordingTracerTVar let args = chainDbArgs threadRegistry nodeDbs tracer @@ -419,6 +421,7 @@ withTestChainDbEnv topLevelConfig chunkInfo extLedgerState cont , varNextId , varVolatileDbFs = nodeDBsVol nodeDbs , args + , varLoEFragment } pure (env, getTrace)