From 2b11f09689cfcb9b39fa9244c013d2139055a9e9 Mon Sep 17 00:00:00 2001 From: Damian Nadales Date: Tue, 19 Nov 2024 14:10:35 +0100 Subject: [PATCH] Add a `Test.Util.HeaderValidation` module ... which contains an `AddBogusTime` type class, which allows to add bogus times to headers. This type class and its instances are meant to be used in test code. --- .../Genesis/Tests/DensityDisconnect.hs | 16 +++---- ouroboros-consensus/ouroboros-consensus.cabal | 2 + .../Test/Util/HeaderValidation.hs | 43 +++++++++++++++++++ .../Ouroboros/Storage/ChainDB/StateMachine.hs | 5 ++- 4 files changed, 55 insertions(+), 11 deletions(-) create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs index 1ad0e659bb..5b94e594c7 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs @@ -60,6 +60,7 @@ import Test.QuickCheck import Test.QuickCheck.Extras (unsafeMapSuchThatJust) import Test.Tasty import Test.Tasty.QuickCheck +import Test.Util.HeaderValidation (addBogusTimeToFragment) import Test.Util.Orphans.IOLike () import Test.Util.PartialAccessors import Test.Util.TersePrinting (terseHFragment, terseHeader) @@ -94,11 +95,6 @@ data StaticCandidates = } deriving Show -addTime :: - AnchoredFragment (Header TestBlock) - -> AnchoredFragment (HeaderWithTime TestBlock) -addTime = undefined - dropTime :: AnchoredFragment (HeaderWithTime blk) -> AnchoredFragment (Header blk) @@ -123,7 +119,7 @@ staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} = } where (loeFrag, suffixes) = - sharedCandidatePrefix curChain (second (addTime . toHeaders) <$> candidates) + sharedCandidatePrefix curChain (second (addBogusTimeToFragment . toHeaders) <$> candidates) selections = selection <$> branches @@ -144,7 +140,7 @@ staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} = prop_densityDisconnectStatic :: Property prop_densityDisconnectStatic = forAll gen $ \ StaticCandidates {k, sgen, suffixes, loeFrag} -> do - let (disconnect, _) = densityDisconnect sgen k (mkState <$> Map.fromList suffixes) (fmap (second addTime) suffixes) (addTime loeFrag) + let (disconnect, _) = densityDisconnect sgen k (mkState <$> Map.fromList suffixes) (fmap (second addBogusTimeToFragment) suffixes) (addBogusTimeToFragment loeFrag) counterexample "it should disconnect some node" (not (null disconnect)) .&&. counterexample "it should not disconnect the honest peers" @@ -153,7 +149,7 @@ prop_densityDisconnectStatic = mkState :: AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock mkState frag = ChainSyncState { - csCandidate = addTime frag, + csCandidate = addBogusTimeToFragment frag, csLatestSlot = SJust (AF.headSlot frag), csIdling = False } @@ -388,12 +384,12 @@ evolveBranches EvolvingPeers {k, sgen, peers = initialPeers, fullTree} = states = candidates <&> \ csCandidate -> ChainSyncState { - csCandidate = addTime csCandidate, + csCandidate = addBogusTimeToFragment csCandidate, csIdling = False, csLatestSlot = SJust (AF.headSlot csCandidate) } -- Run GDD. - (loeFrag, suffixes) = sharedCandidatePrefix curChain (Map.toList $ fmap addTime candidates) + (loeFrag, suffixes) = sharedCandidatePrefix curChain (Map.toList $ fmap addBogusTimeToFragment candidates) (killedNow, bounds) = first Set.fromList $ densityDisconnect sgen k states suffixes loeFrag event = UpdateEvent { target, diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index cce3ffa020..adb51157ea 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -349,6 +349,7 @@ library unstable-consensus-testlib Test.Util.FileLock Test.Util.HardFork.Future Test.Util.HardFork.OracularClock + Test.Util.HeaderValidation Test.Util.InvertedMap Test.Util.LogicalClock Test.Util.MockChain @@ -391,6 +392,7 @@ library unstable-consensus-testlib cardano-binary:testlib, cardano-crypto-class, cardano-prelude, + cardano-slotting, cardano-slotting:testlib, cardano-strict-containers, cborg, diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs new file mode 100644 index 0000000000..0162cf1911 --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Test.Util.HeaderValidation ( + -- * Bogus time + AddBogusTime + , addBogusTime + , addBogusTimeToFragment + ) where + +import Cardano.Slotting.Time (RelativeTime (..)) +import Data.Typeable (Typeable) +import Ouroboros.Consensus.Block (Header) +import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF + +{------------------------------------------------------------------------------- + Bogus time +-------------------------------------------------------------------------------} + +-- REVIEW: I'm not sure about the name of this type class, and how safe it is to use it in testing code. What if suddenly a test decides to rely on the header's time? +class AddBogusTime blk where + addBogusTime :: + Header blk + -> HeaderWithTime blk + +-- REVIEW: I even wonder if this instance should be defined here and +-- at all: there might be use cases in which the 'TestBlock's are used +-- in tests that depend on the header having a meaningful time +-- associated with them. +-- +instance AddBogusTime blk where + addBogusTime testHeader = HeaderWithTime { + hwtHeader = testHeader + , hwtSlotRelativeTime = RelativeTime (error "Header time should not be used!") + } + +addBogusTimeToFragment :: (AF.HasHeader (Header blk), Typeable blk) + => AnchoredFragment (Header blk) + -> AnchoredFragment (HeaderWithTime blk) +addBogusTimeToFragment = AF.mapAnchoredFragment addBogusTime 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 a9ae2c0e73..b871b0c382 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 @@ -155,6 +155,8 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.ChainDB import Test.Util.ChunkInfo +import Test.Util.HeaderValidation (AddBogusTime, + addBogusTimeToFragment) import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.ToExpr () import Test.Util.QuickCheck @@ -330,6 +332,7 @@ type TestConstraints blk = , ConvertRawHash blk , HasHardForkHistory blk , SerialiseDiskConstraints blk + , AddBogusTime blk ) deriving instance (TestConstraints blk, Eq it, Eq flr) @@ -442,7 +445,7 @@ run env@ChainDBEnv { varDB, .. } cmd = updateLoE :: ChainDBState m blk -> AnchoredFragment blk -> m (Point blk) updateLoE ChainDBState { chainDB } frag = do let headersFrag = AF.mapAnchoredFragment getHeader frag - atomically $ writeTVar varLoEFragment headersFrag + atomically $ writeTVar varLoEFragment $ addBogusTimeToFragment headersFrag ChainDB.triggerChainSelection chainDB atomically $ getTipPoint chainDB