diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 86fa8bfaf..2de428975 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -92,6 +92,7 @@ library Ouroboros.Consensus.Byron.Protocol Ouroboros.Consensus.Cardano Ouroboros.Consensus.Cardano.Block + Ouroboros.Consensus.Cardano.IssueTestBlock Ouroboros.Consensus.Cardano.CanHardFork Ouroboros.Consensus.Cardano.Condense Ouroboros.Consensus.Cardano.Ledger @@ -158,6 +159,10 @@ library mtl, nothunks, ouroboros-consensus ^>=0.27, + ouroboros-consensus-diffusion:unstable-consensus-conformance-testlib, + cardano-ledger-shelley-test, + cardano-ledger-binary:testlib, + cardano-ledger-core:{cardano-ledger-core, testlib}, ouroboros-consensus-protocol ^>=0.12, ouroboros-network-api ^>=0.14, serialise ^>=0.2, diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/IssueTestBlock.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/IssueTestBlock.hs new file mode 100644 index 000000000..152c44e71 --- /dev/null +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/IssueTestBlock.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ouroboros.Consensus.Cardano.IssueTestBlock () where + +import Cardano.Crypto.Hash as Hash +import Cardano.Crypto.KES as KES +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Keys hiding (hashVerKeyVRF) +import Cardano.Ledger.Shelley.API hiding (hashVerKeyVRF) +import Cardano.Ledger.Shelley.Core +import Cardano.Protocol.Crypto +import Cardano.Protocol.TPraos.BHeader +import Cardano.Protocol.TPraos.OCert +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.Proxy +import qualified Data.Sequence.Strict as StrictSeq +import Ouroboros.Consensus.Cardano.Block (CardanoBlock, + pattern BlockShelley) +import Ouroboros.Consensus.Shelley.Eras +import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock (..), + ShelleyHash (..)) +import Ouroboros.Consensus.Shelley.Protocol.TPraos () +import Test.Cardano.Ledger.Binary.Random (mkDummyHash) +import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..)) +import Test.Cardano.Ledger.Shelley.Examples.Consensus +import Test.Cardano.Ledger.Shelley.Generator.Core +import Test.Cardano.Ledger.Shelley.Utils hiding (mkVRFKeyPair) +import Test.Consensus.Genesis.Setup.GenChains (IssueTestBlock (..)) + + +instance IssueTestBlock (CardanoBlock StandardCrypto) where + issueFirstBlock fork slot = makeCardanoBlock (Just fork) 0 slot Nothing + issueSuccessorBlock fork slot (BlockShelley (ShelleyBlock (Block (BHeader (BHBody {bheaderBlockNo}) _) _) (ShelleyHash hh))) = + makeCardanoBlock fork (bheaderBlockNo + 1) slot $ Just $ HashHeader hh + issueSuccessorBlock _ _ _ = + -- Impossible because we only ever produce 'BlockShelley' in + -- 'makeCardanoBlock'. + error "issueSuccessorBlock: impossible" + + +-- | Construct a fake 'CardanoBlock' with all of its crypto intact. +makeCardanoBlock + :: Maybe Int + -> BlockNo + -> SlotNo + -> Maybe HashHeader + -> CardanoBlock StandardCrypto +makeCardanoBlock fork blockNo slot mhash = BlockShelley $ + let blk = + shelleyLedgerBlock slot blockNo mhash + (exampleTx + (mkWitnessesPreAlonzo (Proxy @ShelleyEra)) + exampleTxBodyShelley + $ forkToAuxData fork) + in ShelleyBlock blk $ ShelleyHash $ unHashHeader $ bhHash $ bheader blk + + +-- | Construct a made-up (but believable) cardano block for the Shelley era. +shelleyLedgerBlock :: + SlotNo -> + BlockNo -> + Maybe HashHeader -> + -- ^ The parent hash, if there is one. + Tx ShelleyEra -> + -- ^ Some transaction to stick in the block. + Block (BHeader StandardCrypto) ShelleyEra +shelleyLedgerBlock slot blockNo prev tx = Block blockHeader blockBody + where + keys :: AllIssuerKeys StandardCrypto 'StakePool + keys = exampleKeys + + hotKey = kesSignKey $ snd $ NE.head $ aikHot keys + KeyPair vKeyCold _ = aikCold keys + + blockHeader :: BHeader StandardCrypto + blockHeader = BHeader blockHeaderBody (unsoundPureSignedKES () 0 blockHeaderBody hotKey) + + blockHeaderBody :: BHBody StandardCrypto + blockHeaderBody = + BHBody + { bheaderBlockNo = blockNo + , bheaderSlotNo = slot + , bheaderPrev = maybe GenesisHash BlockHash prev + , bheaderVk = coerceKeyRole vKeyCold + , bheaderVrfVk = vrfVerKey $ aikVrf keys + , bheaderEta = mkCertifiedVRF (mkBytes 0) (vrfSignKey $ aikVrf keys) + , bheaderL = mkCertifiedVRF (mkBytes 1) (vrfSignKey $ aikVrf keys) + , bsize = 2345 + , bhash = hashTxSeq blockBody + , bheaderOCert = mkOCert keys 0 (KESPeriod 0) + , bprotver = ProtVer (natVersion @2) 0 + } + + blockBody = toTxSeq @ShelleyEra (StrictSeq.fromList [tx]) + + mkBytes :: Int -> Cardano.Ledger.BaseTypes.Seed + mkBytes = Seed . mkDummyHash @Blake2b_256 + + +-- | We need to do something with our fork number to futz the resulting hash. +-- So we stick it into the auxilliary data that gets attached to the block. +forkToAuxData :: Maybe Int -> TxAuxData ShelleyEra +forkToAuxData + = ShelleyTxAuxData + . foldMap (\i -> M.singleton 1 $ I $ fromIntegral i) + diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree.hs index a7cb703a7..8bd346801 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree.hs @@ -18,30 +18,29 @@ module Test.Consensus.BlockTree ( , addBranch , addBranch' , allFragments + , deforestBlockTree , findFragment , findPath + , isAncestorOf , mkTrunk - , prettyBlockTree - , deforestBlockTree , nonemptyPrefixesOf + , prettyBlockTree ) where -import Cardano.Slotting.Slot (SlotNo (unSlotNo)) +import Cardano.Slotting.Slot (SlotNo (unSlotNo), WithOrigin (..)) import Data.Foldable (asum) import Data.Function ((&)) import Data.Functor ((<&>)) -import Data.List (sortOn, insert, inits) +import Data.List (inits, sortOn) import qualified Data.Map as M -import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import Data.Maybe (fromJust, fromMaybe) import Data.Ord (Down (Down)) -import Data.Proxy import qualified Data.Vector as Vector -import Ouroboros.Consensus.Block.Abstract (blockNo, blockSlot, blockHash, - fromWithOrigin, pointSlot, unBlockNo, HeaderHash, HasHeader) +import Ouroboros.Consensus.Block.Abstract (HasHeader, HeaderHash, + blockHash, blockNo, blockSlot, fromWithOrigin, pointSlot, + unBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Text.Printf (printf) -import qualified Test.QuickCheck as QC -import qualified Test.Util.TestBlock -- | Represent a branch of a block tree by a prefix and a suffix. The full -- fragment (the prefix and suffix catenated) and the trunk suffix (the rest of @@ -278,7 +277,31 @@ deforestBlockTree (BlockTree trunk branches) = -> M.Map (HeaderHash blk) (AF.AnchoredFragment blk) -> M.Map (HeaderHash blk) (AF.AnchoredFragment blk) addPrefix fragment mapSoFar = case fragment of - AF.Empty _ -> mapSoFar + AF.Empty _ -> mapSoFar _ AF.:> tip -> M.insert (blockHash tip) fragment mapSoFar in foldr addPrefix mempty allPrefixes + + +-- | More efficient implementation of a check used in some of the handlers, +-- determining whether the first argument is on the chain that ends in the +-- second argument. +-- We would usually call @withinFragmentBounds@ for this, but since we're +-- using 'TestBlock', looking at the hash is cheaper. +-- +-- TODO: Unify with 'Test.UtilTestBlock.isAncestorOf' which basically does the +-- same thing except not on 'WithOrigin'. +isAncestorOf :: + (HasHeader blk, Eq blk) => + BlockTree blk -> + WithOrigin blk -> + WithOrigin blk -> + Bool +isAncestorOf bt (At ancestor) (At descendant) = + fromMaybe False $ do + let m = deforestBlockTree bt + afD <- M.lookup (blockHash descendant) m + afA <- M.lookup (blockHash ancestor) m + pure $ AF.isPrefixOf afA afD +isAncestorOf _ (At _) Origin = False +isAncestorOf _ Origin _ = True diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs index 632249c89..8caac7d0d 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -18,12 +19,25 @@ import Control.Monad.Class.MonadAsync import Control.Monad.IOSim (IOSim, runSimStrictShutdown) import Control.Tracer (debugTracer, traceWith) import Data.Maybe (mapMaybe) +import Ouroboros.Consensus.Block.Abstract (ConvertRawHash, Header) +import Ouroboros.Consensus.Block.SupportsDiffusionPipelining + (BlockSupportsDiffusionPipelining) +import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode) +import Ouroboros.Consensus.HardFork.Abstract +import Ouroboros.Consensus.Ledger.Basics (LedgerState) +import Ouroboros.Consensus.Ledger.Inspect (InspectLedger) +import Ouroboros.Consensus.Ledger.SupportsProtocol + (LedgerSupportsProtocol) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientException (..)) +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB +import Ouroboros.Consensus.Storage.LedgerDB.API + (CanUpgradeLedgerTables) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IOLike (Exception, fromException) import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (ExceededTimeLimit)) +import Ouroboros.Network.Util.ShowProxy import Test.Consensus.Genesis.Setup.Classifiers (Classifiers (..), ResultClassifiers (..), ScheduleClassifiers (..), classifiers, resultClassifiers, scheduleClassifiers) @@ -33,9 +47,11 @@ import Test.Consensus.PeerSimulator.StateView import Test.Consensus.PeerSimulator.Trace (traceLinesWith, tracerTestBlock) import Test.Consensus.PointSchedule +import Test.Consensus.PointSchedule.NodeState (NodeState) import Test.QuickCheck import Test.Util.Orphans.IOLike () import Test.Util.QuickCheck (forAllGenRunShrinkCheck) +import Test.Util.TersePrinting (Terse) import Test.Util.TestBlock (TestBlock) import Test.Util.Tracer (recordingTracerM) import Text.Printf (printf) @@ -53,9 +69,26 @@ runSimStrictShutdownOrThrow action = -- | Runs the given 'GenesisTest' and 'PointSchedule' and evaluates the given -- property on the final 'StateView'. runGenesisTest :: - SchedulerConfig -> - GenesisTestFull TestBlock -> - RunGenesisTestResult + ( Condense (StateView blk) + , CondenseList (NodeState blk) + , ShowProxy blk + , ShowProxy (Header blk) + , ConfigSupportsNode blk + , LedgerSupportsProtocol blk + , ChainDB.SerialiseDiskConstraints blk + , BlockSupportsDiffusionPipelining blk + , InspectLedger blk + , HasHardForkHistory blk + , ConvertRawHash blk + , CanUpgradeLedgerTables (LedgerState blk) + , Eq (Header blk) + , Eq blk + , Terse blk + , Condense (NodeState blk) + ) + => SchedulerConfig -> + GenesisTestFull blk -> + RunGenesisTestResult blk runGenesisTest schedulerConfig genesisTest = runSimStrictShutdownOrThrow $ do (recordingTracer, getTrace) <- recordingTracerM @@ -87,12 +120,29 @@ runGenesisTest' schedulerConfig genesisTest makeProperty = -- | All-in-one helper that generates a 'GenesisTest' and a 'Peers -- PeerSchedule', runs them with 'runGenesisTest', check whether the given -- property holds on the resulting 'StateView'. -forAllGenesisTest :: - Testable prop => - Gen (GenesisTestFull TestBlock) -> +forAllGenesisTest :: forall blk prop. + (Testable prop + , Condense (StateView blk) + , CondenseList (NodeState blk) + , ShowProxy blk + , ShowProxy (Header blk) + , ConfigSupportsNode blk + , LedgerSupportsProtocol blk + , ChainDB.SerialiseDiskConstraints blk + , BlockSupportsDiffusionPipelining blk + , InspectLedger blk + , HasHardForkHistory blk + , ConvertRawHash blk + , CanUpgradeLedgerTables (LedgerState blk) + , Eq (Header blk) + , Eq blk + , Terse blk + , Condense (NodeState blk) + ) => + Gen (GenesisTestFull blk) -> SchedulerConfig -> - (GenesisTestFull TestBlock -> StateView TestBlock -> [GenesisTestFull TestBlock]) -> - (GenesisTestFull TestBlock -> StateView TestBlock -> prop) -> + (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]) -> + (GenesisTestFull blk -> StateView blk -> prop) -> Property forAllGenesisTest generator schedulerConfig shrinker mkProperty = forAllGenRunShrinkCheck generator runner shrinker' $ \genesisTest result -> diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/Classifiers.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/Classifiers.hs index 76be99cf9..970b175d9 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/Classifiers.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/Classifiers.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -34,7 +35,8 @@ import Ouroboros.Network.AnchoredFragment (anchor, anchorToSlotNo, import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (ExceededTimeLimit)) -import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..)) +import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..), + isAncestorOf) import Test.Consensus.Network.AnchoredFragment.Extras (slotLength) import Test.Consensus.PeerSimulator.StateView (PeerSimulatorResult (..), StateView (..), pscrToException) @@ -42,8 +44,7 @@ import Test.Consensus.PointSchedule import Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (..)) import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..)) import Test.Util.Orphans.IOLike () -import Test.Util.TestBlock (TestBlock, TestHash (TestHash), - isAncestorOf) +import Test.Util.TestBlock (TestHash (TestHash)) -- | Interesting categories to classify test inputs data Classifiers = @@ -151,7 +152,7 @@ data ResultClassifiers = nullResultClassifier :: ResultClassifiers nullResultClassifier = ResultClassifiers 0 0 0 0 -resultClassifiers :: GenesisTestFull blk -> RunGenesisTestResult -> ResultClassifiers +resultClassifiers :: GenesisTestFull blk -> RunGenesisTestResult blk -> ResultClassifiers resultClassifiers GenesisTest{gtSchedule} RunGenesisTestResult{rgtrStateView} = if adversariesCount > 0 then ResultClassifiers { @@ -210,8 +211,8 @@ data ScheduleClassifiers = allAdversariesTrivial :: Bool } -scheduleClassifiers :: GenesisTestFull TestBlock -> ScheduleClassifiers -scheduleClassifiers GenesisTest{gtSchedule = schedule} = +scheduleClassifiers :: forall blk. (AF.HasHeader blk, Eq blk) => GenesisTestFull blk -> ScheduleClassifiers +scheduleClassifiers GenesisTest{gtSchedule = schedule, gtBlockTree} = ScheduleClassifiers { adversaryRollback , honestRollback @@ -219,32 +220,20 @@ scheduleClassifiers GenesisTest{gtSchedule = schedule} = , allAdversariesTrivial } where - hasRollback :: PeerSchedule TestBlock -> Bool + hasRollback :: PeerSchedule blk -> Bool hasRollback peerSch' = any (not . isSorted) [tips, headers, blocks] where peerSch = sortOn fst peerSch' + isSorted :: [WithOrigin blk] -> Bool isSorted l = and [x `ancestor` y | (x:y:_) <- tails l] - ancestor Origin Origin = True - ancestor Origin (At _) = True - ancestor (At _) Origin = False - ancestor (At p1) (At p2) = p1 `isAncestorOf` p2 - tips = mapMaybe - (\(_, point) -> case point of - ScheduleTipPoint blk -> Just blk - _ -> Nothing - ) - peerSch - headers = mapMaybe - (\(_, point) -> case point of - ScheduleHeaderPoint blk -> Just blk - _ -> Nothing - ) - peerSch - blocks = mapMaybe + ancestor = isAncestorOf gtBlockTree + tips, headers, blocks :: [WithOrigin blk] + (tips, headers, blocks) = foldMap (\(_, point) -> case point of - ScheduleBlockPoint blk -> Just blk - _ -> Nothing + ScheduleTipPoint blk -> (pure blk, mempty, mempty) + ScheduleHeaderPoint blk -> (mempty, pure blk, mempty) + ScheduleBlockPoint blk -> (mempty, mempty, pure blk) ) peerSch @@ -256,7 +245,7 @@ scheduleClassifiers GenesisTest{gtSchedule = schedule} = allAdversariesEmpty = all id $ adversarialPeers $ null <$> psSchedule schedule - isTrivial :: PeerSchedule TestBlock -> Bool + isTrivial :: PeerSchedule blk -> Bool isTrivial = \case [] -> True (t0, _):points -> all ((== t0) . fst) points diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs index cc2ef2eac..1244fa889 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs @@ -9,9 +9,9 @@ module Test.Consensus.Genesis.Setup.GenChains ( GenesisTest (..) + , IssueTestBlock (..) , genChains , genChainsWithExtraHonestPeers - , IssueTestBlock(..) ) where import Cardano.Ledger.BaseTypes (nonZeroOr) @@ -48,8 +48,8 @@ import qualified Test.QuickCheck as QC import Test.QuickCheck.Extras (unsafeMapSuchThatJust) import Test.QuickCheck.Random (QCGen) import Test.Util.Orphans.IOLike () -import Test.Util.TestBlock (TestBlockWith(..), TestBlock) import qualified Test.Util.TestBlock as TB +import Test.Util.TestBlock (TestBlock, TestBlockWith (..)) -- | Random generator for an honest chain recipe and schema. genHonestChainSchema :: QC.Gen (Asc, H.HonestRecipe, H.SomeHonestChainSchema) @@ -68,9 +68,10 @@ genHonestChainSchema = do -- | Random generator for one alternative chain schema forking off a given -- honest chain schema. The alternative chain schema is returned as the pair of --- a slot number on the honest chain schema and a list of active slots. +-- a block number (representing the common prefix block count) on the honest +-- chain schema and a list of active slots. -- --- REVIEW: Use 'SlotNo' instead of 'Int'? +-- REVIEW: Use 'BlockNo' instead of 'Int'? genAlternativeChainSchema :: (H.HonestRecipe, H.ChainSchema base hon) -> QC.Gen (Int, [S]) genAlternativeChainSchema (testRecipeH, arHonest) = unsafeMapSuchThatJust $ do @@ -153,6 +154,11 @@ genChainsWithExtraHonestPeers genNumExtraHonest genNumForks = do -- those values for individual tests? -- Also, we might want to generate these randomly. gtCSJParams = CSJParams $ fromIntegral scg, + -- The generated alternative chains (branches added to the @goodChain@) + -- can end up having the same /common prefix count/, meaning they fork + -- at the same block. Note that the assigned fork number has no relation + -- with the order in which the branching happens, rather it is just a + -- means to tag branches. gtBlockTree = List.foldl' (flip BT.addBranch') (BT.mkTrunk goodChain) $ zipWith (genAdversarialFragment goodBlocks) [1..] alternativeChainSchemas, gtExtraHonestPeers, gtSchedule = () @@ -170,6 +176,9 @@ genChainsWithExtraHonestPeers genNumExtraHonest genNumForks = do mkTestFragment = AF.fromNewestFirst AF.AnchorGenesis + -- Cons new blocks acoording to the given active block schema + -- and mark the first with the corresponding fork number; the + -- next blocks get a zero fork number. mkTestBlocks :: [blk] -> [S] -> Int -> [blk] mkTestBlocks pre active forkNo = fst (List.foldl' folder ([], 0) active) @@ -178,21 +187,21 @@ genChainsWithExtraHonestPeers genNumExtraHonest genNumForks = do folder (chain, inc) s | S.test S.notInverted s = (issue inc chain, 0) | otherwise = (chain, inc + 1) issue :: SlotNo -> [blk] -> [blk] - issue inc (h : t) = successorBlock Nothing inc h : h : t + issue inc (h : t) = issueSuccessorBlock Nothing inc h : h : t issue inc [] = case pre of - [] -> [firstBlock forkNo inc] - (h : t) -> successorBlock (Just forkNo) inc h : h : t + [] -> [issueFirstBlock forkNo inc] + (h : t) -> issueSuccessorBlock (Just forkNo) inc h : h : t -- | Class of block types for which we can issue test blocks. class IssueTestBlock blk where - firstBlock + issueFirstBlock :: Int -- ^ The fork number -> SlotNo -- ^ The amount of lapsed slots before this block was issued. -> blk - successorBlock + issueSuccessorBlock :: Maybe Int -- ^ A new fork number, if this block should fork off the trunk. -> SlotNo @@ -201,11 +210,11 @@ class IssueTestBlock blk where -> blk instance IssueTestBlock TestBlock where - firstBlock fork slot = + issueFirstBlock fork slot = incSlot slot $ TB.firstBlock $ fromIntegral fork - successorBlock fork slot blk = + issueSuccessorBlock fork slot blk = incSlot slot $ TB.modifyFork (maybe id (const . fromIntegral) fork) $ TB.successorBlock blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index b4a111d24..54fec10f5 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -25,15 +25,18 @@ import Network.TypedProtocol.Codec (ActiveState, AnyMessage, StateToken, notActiveState) import Ouroboros.Consensus.Block (HasHeader) import Ouroboros.Consensus.Block.Abstract (Header, Point (..)) +import Ouroboros.Consensus.Block.SupportsDiffusionPipelining + (BlockSupportsDiffusionPipelining) import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) +import Ouroboros.Consensus.Ledger.SupportsProtocol + (LedgerSupportsProtocol) import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandleCollection) import Ouroboros.Consensus.Node.Genesis (GenesisConfig (..), enableGenesisConfigDefault) -import Ouroboros.Consensus.Node.ProtocolInfo - (NumCoreNodes (NumCoreNodes)) import Ouroboros.Consensus.Storage.ChainDB.API import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Consensus.Util.IOLike @@ -69,23 +72,22 @@ import Test.Consensus.PeerSimulator.Trace import Test.Consensus.PointSchedule (BlockFetchTimeout (..)) import Test.Consensus.PointSchedule.Peers (PeerId) import Test.Util.Orphans.IOLike () -import Test.Util.TestBlock (BlockConfig (TestBlockConfig), TestBlock) startBlockFetchLogic :: - forall m. - (IOLike m, MonadTimer m) + forall m blk. + (IOLike m, MonadTimer m, LedgerSupportsProtocol blk, BlockSupportsDiffusionPipelining blk, ConfigSupportsNode blk) => Bool -- ^ Whether to enable chain selection starvation -> ResourceRegistry m - -> Tracer m (TraceEvent TestBlock) - -> ChainDB m TestBlock - -> FetchClientRegistry PeerId (HeaderWithTime TestBlock) TestBlock m - -> ChainSyncClientHandleCollection PeerId m TestBlock + -> Tracer m (TraceEvent blk) + -> ChainDB m blk + -> FetchClientRegistry PeerId (HeaderWithTime blk) blk m + -> ChainSyncClientHandleCollection PeerId m blk -> m () startBlockFetchLogic enableChainSelStarvation registry tracer chainDb fetchClientRegistry csHandlesCol = do let blockFetchConsensusInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface nullTracer -- FIXME - (TestBlockConfig $ NumCoreNodes 0) -- Only needed when minting blocks + (error "blk cfg") --(TestBlockConfig $ NumCoreNodes 0) -- Only needed when minting blocks (BlockFetchClientInterface.defaultChainDbView chainDb) csHandlesCol -- The size of headers in bytes is irrelevant because our tests diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Handlers.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Handlers.hs index d289665db..4bffe2446 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Handlers.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Handlers.hs @@ -22,11 +22,9 @@ import Cardano.Slotting.Slot (WithOrigin (..)) import Control.Monad.Trans (lift) import Control.Monad.Writer.Strict (MonadWriter (tell), WriterT (runWriterT)) -import Data.List (isSuffixOf) -import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromJust, fromMaybe) -import Ouroboros.Consensus.Block (HasHeader, HeaderHash, - Point (GenesisPoint), blockHash, getHeader, withOrigin) +import Ouroboros.Consensus.Block (GetHeader, HasHeader, + Point (GenesisPoint), getHeader, withOrigin) import Ouroboros.Consensus.Util.IOLike (IOLike, STM, StrictTVar, readTVar, writeTVar) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) @@ -36,7 +34,7 @@ import Ouroboros.Network.Block (Tip (TipGenesis), blockPoint, import Ouroboros.Network.BlockFetch.ClientState (ChainRange (ChainRange)) import qualified Test.Consensus.BlockTree as BT -import Test.Consensus.BlockTree (BlockTree) +import Test.Consensus.BlockTree (BlockTree, isAncestorOf) import Test.Consensus.Network.AnchoredFragment.Extras (intersectWith) import Test.Consensus.PeerSimulator.ScheduledBlockFetchServer (BlockFetch (..), SendBlocks (..)) @@ -48,31 +46,6 @@ import Test.Consensus.PeerSimulator.Trace TraceScheduledChainSyncServerEvent (..)) import Test.Consensus.PointSchedule.NodeState import Test.Util.Orphans.IOLike () -import Test.Util.TestBlock (TestBlock, TestHash (TestHash)) - --- | More efficient implementation of a check used in some of the handlers, --- determining whether the first argument is on the chain that ends in the --- second argument. --- We would usually call @withinFragmentBounds@ for this, but since we're --- using 'TestBlock', looking at the hash is cheaper. --- --- TODO: Unify with 'Test.UtilTestBlock.isAncestorOf' which basically does the --- same thing except not on 'WithOrigin'. -isAncestorOf :: - HasHeader blk1 => - HasHeader blk2 => - HeaderHash blk1 ~ TestHash => - HeaderHash blk2 ~ TestHash => - WithOrigin blk1 -> - WithOrigin blk2 -> - Bool -isAncestorOf (At ancestor) (At descendant) = - isSuffixOf (NonEmpty.toList hashA) (NonEmpty.toList hashD) - where - TestHash hashA = blockHash ancestor - TestHash hashD = blockHash descendant -isAncestorOf (At _) Origin = False -isAncestorOf Origin _ = True -- | Handle a @MsgFindIntersect@ message. -- @@ -106,12 +79,12 @@ handlerFindIntersection currentIntersection blockTree clientPoints points = do -- - header point before intersection (special case for the point scheduler architecture) -- - Anchor != intersection handlerRequestNext :: - forall m. - (IOLike m) => - StrictTVar m (Point TestBlock) -> - BlockTree TestBlock -> - NodeState TestBlock -> - STM m (Maybe (RequestNext TestBlock), [TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock]) + forall m blk. + (IOLike m, HasHeader blk, GetHeader blk, Eq blk) => + StrictTVar m (Point blk) -> + BlockTree blk -> + NodeState blk -> + STM m (Maybe (RequestNext blk), [TraceScheduledChainSyncServerEvent (NodeState blk) blk]) handlerRequestNext currentIntersection blockTree points = runWriterT $ do intersection <- lift $ readTVar currentIntersection @@ -119,12 +92,12 @@ handlerRequestNext currentIntersection blockTree points = withHeader intersection (nsHeader points) where withHeader :: - Point TestBlock -> - WithOrigin TestBlock -> + Point blk -> + WithOrigin blk -> WriterT - [TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock] + [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) - (Maybe (RequestNext TestBlock)) + (Maybe (RequestNext blk)) withHeader intersection h = maybe noPathError analysePath (BT.findPath intersection hp blockTree) where @@ -139,7 +112,7 @@ handlerRequestNext currentIntersection blockTree points = -- also the tip point or a descendent of it (because we served our whole -- chain, or we are stalling as an adversarial behaviour), then we ask the -- client to wait; otherwise we just do nothing. - (BT.PathAnchoredAtSource True, AF.Empty _) | isAncestorOf (nsTip points) (nsHeader points) -> do + (BT.PathAnchoredAtSource True, AF.Empty _) | isAncestorOf blockTree (nsTip points) (nsHeader points) -> do trace TraceChainIsFullyServed pure (Just AwaitReply) (BT.PathAnchoredAtSource True, AF.Empty _) -> do @@ -302,12 +275,13 @@ The cases to consider follow: -} handlerSendBlocks :: - forall m . - IOLike m => - [TestBlock] -> - NodeState TestBlock -> - STM m (Maybe (SendBlocks TestBlock), [TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock]) -handlerSendBlocks blocks NodeState {nsHeader, nsBlock} = + forall m blk. + (IOLike m, HasHeader blk, Eq blk) => + BlockTree blk -> + [blk] -> + NodeState blk -> + STM m (Maybe (SendBlocks blk), [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]) +handlerSendBlocks bt blocks NodeState {nsHeader, nsBlock} = runWriterT (checkDone blocks) where checkDone = \case @@ -318,7 +292,7 @@ handlerSendBlocks blocks NodeState {nsHeader, nsBlock} = blocksLeft next future blocksLeft next future - | isAncestorOf (At next) nsBlock + | isAncestorOf bt (At next) nsBlock || compensateForScheduleRollback next = do trace $ TraceSendingBlock next @@ -347,8 +321,8 @@ handlerSendBlocks blocks NodeState {nsHeader, nsBlock} = -- -- Precondition: @not (isAncestorOf (At next) bp)@ compensateForScheduleRollback next = - not (isAncestorOf (At next) nsHeader) - && isAncestorOf nsBlock nsHeader - && not (isAncestorOf nsBlock (At next)) + not (isAncestorOf bt (At next) nsHeader) + && isAncestorOf bt nsBlock nsHeader + && not (isAncestorOf bt nsBlock (At next)) trace = tell . pure diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs index dc99e61c6..32be225bb 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,7 +22,14 @@ import qualified Data.Set as Set import Data.Typeable (Typeable) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (TopLevelConfig (..)) +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) +import Ouroboros.Consensus.Ledger.Basics (LedgerState) +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) +import Ouroboros.Consensus.Ledger.Inspect (InspectLedger) +import Ouroboros.Consensus.Ledger.SupportsProtocol + (LedgerSupportsProtocol) +import Ouroboros.Consensus.Ledger.Tables.MapKind (ValuesMK) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandleCollection (..)) import Ouroboros.Consensus.Storage.ChainDB.API @@ -29,6 +37,10 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import Ouroboros.Consensus.Storage.ChainDB.Impl.Args (cdbsLoE, updateTracer) +import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal + (ChunkInfo) +import Ouroboros.Consensus.Storage.LedgerDB.API + (CanUpgradeLedgerTables) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -40,7 +52,6 @@ import Test.Consensus.PeerSimulator.Trace import Test.Consensus.PointSchedule.Peers (PeerId) import Test.Util.ChainDB import Test.Util.Orphans.IOLike () -import Test.Util.TestBlock (TestBlock, testInitExtLedger) -- | Resources used for a single live interval of the node, constructed when the -- node is started. @@ -78,21 +89,23 @@ data LiveIntervalResult blk = LiveIntervalResult { -- shut down running components, construct tracers used for single intervals, -- and reset and persist state. data LiveResources blk m = LiveResources { - lrRegistry :: ResourceRegistry m - , lrPeerSim :: PeerSimulatorResources m blk - , lrTracer :: Tracer m (TraceEvent blk) - , lrSTracer :: ChainDB m blk -> m (Tracer m ()) - , lrConfig :: TopLevelConfig blk + lrRegistry :: ResourceRegistry m + , lrPeerSim :: PeerSimulatorResources m blk + , lrTracer :: Tracer m (TraceEvent blk) + , lrSTracer :: ChainDB m blk -> m (Tracer m ()) + , lrConfig :: TopLevelConfig blk + , lrChunkInfo :: ChunkInfo + , lrInitLedger :: ExtLedgerState blk ValuesMK -- | The chain DB state consists of several transient parts and the -- immutable DB's virtual file system. -- After 'lnCopyToImmDb' was executed, the latter will contain the final -- state of an interval. -- The rest is reset when the chain DB is recreated. - , lrCdb :: NodeDBs (StrictTMVar m MockFS) + , lrCdb :: NodeDBs (StrictTMVar m MockFS) -- | The LoE fragment must be reset for each live interval. - , lrLoEVar :: LoE (StrictTVar m (AnchoredFragment (HeaderWithTime blk))) + , lrLoEVar :: LoE (StrictTVar m (AnchoredFragment (HeaderWithTime blk))) } data LiveInterval blk m = LiveInterval { @@ -119,8 +132,16 @@ data NodeLifecycle blk m = NodeLifecycle { -- candidate fragments. mkChainDb :: IOLike m => - LiveResources TestBlock m -> - m (ChainDB m TestBlock, m (WithOrigin SlotNo)) + ( LedgerSupportsProtocol blk + , ChainDB.SerialiseDiskConstraints blk + , BlockSupportsDiffusionPipelining blk + , InspectLedger blk + , HasHardForkHistory blk + , ConvertRawHash blk + , CanUpgradeLedgerTables (LedgerState blk) + ) => + LiveResources blk m -> + m (ChainDB m blk, m (WithOrigin SlotNo)) mkChainDb resources = do atomically $ do -- Reset only the non-persisted state of the ChainDB's file system mocks: @@ -133,8 +154,8 @@ mkChainDb resources = do (Tracer (traceWith lrTracer . TraceChainDBEvent)) (fromMinimalChainDbArgs MinimalChainDbArgs { mcdbTopLevelConfig = lrConfig - , mcdbChunkInfo = mkTestChunkInfo lrConfig - , mcdbInitLedger = testInitExtLedger + , mcdbChunkInfo = lrChunkInfo + , mcdbInitLedger = lrInitLedger , mcdbRegistry = lrRegistry , mcdbNodeDBs = lrCdb }) @@ -149,15 +170,23 @@ mkChainDb resources = do void $ forkLinkedThread lrRegistry "AddBlockRunner" (void intAddBlockRunner) pure (chainDB, intCopyToImmutableDB) where - LiveResources {lrRegistry, lrTracer, lrConfig, lrCdb, lrLoEVar} = resources + LiveResources {lrRegistry, lrTracer, lrConfig, lrCdb, lrLoEVar, lrChunkInfo, lrInitLedger} = resources -- | Allocate all the resources that depend on the results of previous live -- intervals, the ChainDB and its persisted state. restoreNode :: - IOLike m => - LiveResources TestBlock m -> - LiveIntervalResult TestBlock -> - m (LiveNode TestBlock m) + (IOLike m + , LedgerSupportsProtocol blk + , ChainDB.SerialiseDiskConstraints blk + , BlockSupportsDiffusionPipelining blk + , InspectLedger blk + , HasHardForkHistory blk + , ConvertRawHash blk + , CanUpgradeLedgerTables (LedgerState blk) + ) => + LiveResources blk m -> + LiveIntervalResult blk -> + m (LiveNode blk m) restoreNode resources LiveIntervalResult {lirPeerResults, lirActive} = do lnStateViewTracers <- stateViewTracersWithInitial lirPeerResults (lnChainDb, lnCopyToImmDb) <- mkChainDb resources @@ -173,12 +202,20 @@ restoreNode resources LiveIntervalResult {lirPeerResults, lirActive} = do -- | Allocate resources with 'restoreNode' and pass them to the callback that -- starts the node's threads. lifecycleStart :: - forall m. - IOLike m => - (LiveInterval TestBlock m -> m ()) -> - LiveResources TestBlock m -> - LiveIntervalResult TestBlock -> - m (LiveNode TestBlock m) + forall m blk. + ( IOLike m + , LedgerSupportsProtocol blk + , ChainDB.SerialiseDiskConstraints blk + , BlockSupportsDiffusionPipelining blk + , InspectLedger blk + , HasHardForkHistory blk + , ConvertRawHash blk + , CanUpgradeLedgerTables (LedgerState blk) + ) => + (LiveInterval blk m -> m ()) -> + LiveResources blk m -> + LiveIntervalResult blk -> + m (LiveNode blk m) lifecycleStart start liResources liResult = do trace (TraceSchedulerEvent TraceNodeStartupStart) liNode <- restoreNode liResources liResult diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Resources.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Resources.hs index a594d9059..f73c67cdf 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Resources.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Resources.hs @@ -23,7 +23,10 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Traversable (for) import Ouroboros.Consensus.Block (WithOrigin (Origin)) -import Ouroboros.Consensus.Block.Abstract (Header, Point (..)) +import Ouroboros.Consensus.Block.Abstract (GetHeader, Header, + Point (..)) +import Ouroboros.Consensus.Ledger.SupportsProtocol + (LedgerSupportsProtocol) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandleCollection, newChainSyncClientHandleCollection) @@ -44,7 +47,6 @@ import Test.Consensus.PeerSimulator.Trace (TraceEvent) import Test.Consensus.PointSchedule.NodeState import Test.Consensus.PointSchedule.Peers (PeerId) import Test.Util.Orphans.IOLike () -import Test.Util.TestBlock (TestBlock) -- | Resources used by both ChainSync and BlockFetch for a single peer. data SharedResources m blk = @@ -116,15 +118,17 @@ data PeerSimulatorResources m blk = -- | Handles to interact with the ChainSync client of each peer. -- See 'ChainSyncClientHandle' for more details. - psrHandles :: ChainSyncClientHandleCollection PeerId m TestBlock + psrHandles :: ChainSyncClientHandleCollection PeerId m blk } -- | Create 'ChainSyncServerHandlers' for our default implementation using 'NodeState'. makeChainSyncServerHandlers :: - (IOLike m) => - StrictTVar m (Point TestBlock) -> - BlockTree TestBlock -> - ChainSyncServerHandlers m (NodeState TestBlock) TestBlock + (IOLike m, GetHeader blk, AF.HasHeader blk + , Eq blk + ) => + StrictTVar m (Point blk) -> + BlockTree blk -> + ChainSyncServerHandlers m (NodeState blk) blk makeChainSyncServerHandlers currentIntersection blockTree = ChainSyncServerHandlers { csshFindIntersection = handlerFindIntersection currentIntersection blockTree, @@ -137,10 +141,12 @@ makeChainSyncServerHandlers currentIntersection blockTree = -- -- TODO move server construction to Run? makeChainSyncResources :: - (IOLike m) => + (IOLike m, GetHeader blk, AF.HasHeader blk + , Eq blk + ) => STM m () -> - SharedResources m TestBlock -> - m (ChainSyncResources m TestBlock) + SharedResources m blk -> + m (ChainSyncResources m blk) makeChainSyncResources csrTickStarted SharedResources {srPeerId, srTracer, srBlockTree, srCurrentState} = do csrCurrentIntersection <- uncheckedNewTVarM $ AF.Point Origin let @@ -149,10 +155,12 @@ makeChainSyncResources csrTickStarted SharedResources {srPeerId, srTracer, srBlo pure ChainSyncResources {csrTickStarted, csrServer, csrCurrentIntersection} makeBlockFetchResources :: - IOLike m => + (IOLike m, AF.HasHeader blk + , Eq blk + ) => STM m () -> - SharedResources m TestBlock -> - BlockFetchResources m TestBlock + SharedResources m blk -> + BlockFetchResources m blk makeBlockFetchResources bfrTickStarted SharedResources {srPeerId, srTracer, srBlockTree, srCurrentState} = BlockFetchResources { bfrTickStarted, @@ -161,7 +169,7 @@ makeBlockFetchResources bfrTickStarted SharedResources {srPeerId, srTracer, srBl where handlers = BlockFetchServerHandlers { bfshBlockFetch = handlerBlockFetch srBlockTree, - bfshSendBlocks = handlerSendBlocks + bfshSendBlocks = handlerSendBlocks srBlockTree } bfrServer = runScheduledBlockFetchServer srPeerId bfrTickStarted (readTVar srCurrentState) @@ -184,8 +192,8 @@ makeBlockFetchResources bfrTickStarted SharedResources {srPeerId, srTracer, srBl -- TVar. updateState :: IOLike m => - StrictTVar m (Maybe (NodeState TestBlock)) -> - m (NodeState TestBlock -> STM m (), STM m (), STM m ()) + StrictTVar m (Maybe (NodeState blk)) -> + m (NodeState blk -> STM m (), STM m (), STM m ()) updateState srCurrentState = atomically $ do publisher <- newBroadcastTChan @@ -210,11 +218,13 @@ updateState srCurrentState = -- -- TODO pass BFR and CSR to runScheduled... rather than passing the individual resources in and storing the result makePeerResources :: - IOLike m => - Tracer m (TraceEvent TestBlock) -> - BlockTree TestBlock -> + (IOLike m, AF.HasHeader blk, GetHeader blk + , Eq blk + ) => + Tracer m (TraceEvent blk) -> + BlockTree blk -> PeerId -> - m (PeerResources m TestBlock) + m (PeerResources m blk) makePeerResources srTracer srBlockTree srPeerId = do srCurrentState <- uncheckedNewTVarM Nothing (prUpdateState, csrTickStarted, bfrTickStarted) <- updateState srCurrentState @@ -225,11 +235,13 @@ makePeerResources srTracer srBlockTree srPeerId = do -- | Create resources for all given peers operating on the given block tree. makePeerSimulatorResources :: - IOLike m => - Tracer m (TraceEvent TestBlock) -> - BlockTree TestBlock -> + (IOLike m, LedgerSupportsProtocol blk + , Eq blk + ) => + Tracer m (TraceEvent blk) -> + BlockTree blk -> NonEmpty PeerId -> - m (PeerSimulatorResources m TestBlock) + m (PeerSimulatorResources m blk) makePeerSimulatorResources tracer blockTree peers = do resources <- for peers $ \ peerId -> do peerResources <- makePeerResources tracer blockTree peerId diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index 1fec1c128..ac6f74746 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -23,12 +23,19 @@ import Data.List (sort) import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Typeable import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (TopLevelConfig (..)) +import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode) import Ouroboros.Consensus.Genesis.Governor (gddWatcher) +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) +import Ouroboros.Consensus.Ledger.Basics (LedgerState) +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) +import Ouroboros.Consensus.Ledger.Inspect (InspectLedger) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) +import Ouroboros.Consensus.Ledger.Tables.MapKind (ValuesMK) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (CSJConfig (..), CSJEnabledConfig (..), ChainDbView, ChainSyncClientHandle, @@ -39,6 +46,11 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.Node.GsmState as GSM import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB +import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal + (ChunkInfo) +import Ouroboros.Consensus.Storage.LedgerDB.API + (CanUpgradeLedgerTables) import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM (forkLinkedWatcher) @@ -53,7 +65,6 @@ import Ouroboros.Network.Protocol.ChainSync.Codec import Ouroboros.Network.Util.ShowProxy (ShowProxy) import qualified Test.Consensus.PeerSimulator.BlockFetch as BlockFetch import qualified Test.Consensus.PeerSimulator.ChainSync as ChainSync -import Test.Consensus.PeerSimulator.Config import qualified Test.Consensus.PeerSimulator.CSJInvariants as CSJInvariants import Test.Consensus.PeerSimulator.NodeLifecycle import Test.Consensus.PeerSimulator.Resources @@ -71,7 +82,6 @@ import Test.Consensus.PointSchedule.Peers (Peer (..), PeerId, import Test.Util.ChainDB import Test.Util.Header (dropTimeFromFragment) import Test.Util.Orphans.IOLike () -import Test.Util.TestBlock (TestBlock) -- | Behavior config for the scheduler. data SchedulerConfig = @@ -324,9 +334,14 @@ runScheduler tracer varHandles ps@PointSchedule{psMinEndTime} peers lifecycle@No -- | Create the shared resource for the LoE if the feature is enabled in the config. -- This is used by the ChainDB and the GDD governor. mkLoEVar :: - IOLike m => + (IOLike m + , StandardHash blk + , NoThunks (Header blk) + , HasHeader (Header blk) + , Typeable blk + ) => SchedulerConfig -> - m (LoE (StrictTVar m (AnchoredFragment (HeaderWithTime TestBlock)))) + m (LoE (StrictTVar m (AnchoredFragment (HeaderWithTime blk)))) mkLoEVar SchedulerConfig {scEnableLoE} | scEnableLoE = LoEEnabled <$> newTVarIO (AF.Empty AF.AnchorGenesis) @@ -335,10 +350,11 @@ mkLoEVar SchedulerConfig {scEnableLoE} mkStateTracer :: IOLike m => + (GetHeader blk, HasHeader blk, Eq (Header blk)) => SchedulerConfig -> - GenesisTest TestBlock s -> - PeerSimulatorResources m TestBlock -> - ChainDB m TestBlock -> + GenesisTest blk s -> + PeerSimulatorResources m blk -> + ChainDB m blk -> m (Tracer m ()) mkStateTracer schedulerConfig GenesisTest {gtBlockTree} PeerSimulatorResources {psrHandles, psrPeers} chainDb | scTraceState schedulerConfig @@ -358,14 +374,20 @@ mkStateTracer schedulerConfig GenesisTest {gtBlockTree} PeerSimulatorResources { -- Only start peers that haven't been disconnected in a previous interval, -- provided by 'LiveIntervalResult'. startNode :: - forall m. + forall m blk. ( IOLike m , MonadTime m , MonadTimer m + , LedgerSupportsProtocol blk + , ShowProxy blk + , ShowProxy (Header blk) + , BlockSupportsDiffusionPipelining blk + , ConfigSupportsNode blk + , HasHardForkHistory blk ) => SchedulerConfig -> - GenesisTestFull TestBlock -> - LiveInterval TestBlock m -> + GenesisTestFull blk -> + LiveInterval blk m -> m () startNode schedulerConfig genesisTest interval = do let handles = psrHandles lrPeerSim @@ -485,13 +507,25 @@ startNode schedulerConfig genesisTest interval = do -- | Set up all resources related to node start/shutdown. nodeLifecycle :: - (IOLike m, MonadTime m, MonadTimer m) => + (IOLike m, MonadTime m, MonadTimer m + , ShowProxy blk + , ShowProxy (Header blk) + , ConfigSupportsNode blk + , LedgerSupportsProtocol blk + , ChainDB.SerialiseDiskConstraints blk + , BlockSupportsDiffusionPipelining blk + , InspectLedger blk + , HasHardForkHistory blk + , ConvertRawHash blk + , CanUpgradeLedgerTables (LedgerState blk) + , Eq (Header blk) + ) => SchedulerConfig -> - GenesisTestFull TestBlock -> - Tracer m (TraceEvent TestBlock) -> + GenesisTestFull blk -> + Tracer m (TraceEvent blk) -> ResourceRegistry m -> - PeerSimulatorResources m TestBlock -> - m (NodeLifecycle TestBlock m) + PeerSimulatorResources m blk -> + m (NodeLifecycle blk m) nodeLifecycle schedulerConfig genesisTest lrTracer lrRegistry lrPeerSim = do lrCdb <- emptyNodeDBs lrLoEVar <- mkLoEVar schedulerConfig @@ -501,7 +535,9 @@ nodeLifecycle schedulerConfig genesisTest lrTracer lrRegistry lrPeerSim = do lrRegistry , lrTracer , lrSTracer = mkStateTracer schedulerConfig genesisTest lrPeerSim - , lrConfig + , lrConfig = error "defaultCfg k gtForecastRange gtGenesisWindow" + , lrInitLedger = error "testInitExtLedger" + , lrChunkInfo = error "mkTestChunkInfo lrConfig" , lrPeerSim , lrCdb , lrLoEVar @@ -512,8 +548,6 @@ nodeLifecycle schedulerConfig genesisTest lrTracer lrRegistry lrPeerSim = do , nlShutdown = lifecycleStop resources } where - lrConfig = defaultCfg k gtForecastRange gtGenesisWindow - GenesisTest { gtSecurityParam = k , gtForecastRange @@ -523,12 +557,25 @@ nodeLifecycle schedulerConfig genesisTest lrTracer lrRegistry lrPeerSim = do -- | Construct STM resources, set up ChainSync and BlockFetch threads, and -- send all ticks in a 'PointSchedule' to all given peers in turn. runPointSchedule :: - forall m. - (IOLike m, MonadTime m, MonadTimer m) => + forall m blk. + (IOLike m, MonadTime m, MonadTimer m + , ShowProxy blk + , ShowProxy (Header blk) + , ConfigSupportsNode blk + , LedgerSupportsProtocol blk + , ChainDB.SerialiseDiskConstraints blk + , BlockSupportsDiffusionPipelining blk + , InspectLedger blk + , HasHardForkHistory blk + , ConvertRawHash blk + , CanUpgradeLedgerTables (LedgerState blk) + , Eq (Header blk) + , Eq blk + ) => SchedulerConfig -> - GenesisTestFull TestBlock -> - Tracer m (TraceEvent TestBlock) -> - m (StateView TestBlock) + GenesisTestFull blk -> + Tracer m (TraceEvent blk) -> + m (StateView blk) runPointSchedule schedulerConfig genesisTest tracer0 = withRegistry $ \registry -> do peerSim <- makePeerSimulatorResources tracer gtBlockTree (NonEmpty.fromList $ getPeerIds $ psSchedule gtSchedule) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs index 7e1fe33e1..455109c7e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs @@ -3,7 +3,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | A pretty-printer and tracer that shows the current peer simulator state in -- a block tree, highlighting the candidate fragments, selection, and forks in @@ -28,13 +32,14 @@ import Control.Monad.State.Strict (State, gets, modify', runState, import Control.Tracer (Tracer (Tracer), debugTracer, traceWith) import Data.Bifunctor (first) import Data.Foldable as Foldable (foldl', foldr') -import Data.List (find, intersperse, mapAccumL, sort, transpose) +import Data.List (intersperse, mapAccumL, sort, transpose) import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, (<|)) import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import Data.Map.Strict ((!?)) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, mapMaybe) +import Data.Monoid (First (..)) import Data.String (IsString (fromString)) import Data.Vector (Vector) import qualified Data.Vector as Vector @@ -42,9 +47,9 @@ import qualified Data.Vector.Mutable as MV import Data.Word (Word64) import qualified Debug.Trace as Debug import GHC.Exts (IsList (..)) -import Ouroboros.Consensus.Block (ChainHash (BlockHash), Header, - WithOrigin (NotOrigin), blockHash, blockNo, blockSlot, - getHeader) +import Ouroboros.Consensus.Block (ChainHash (BlockHash), GetHeader, + Header, StandardHash, WithOrigin (NotOrigin), blockHash, + blockNo, blockSlot, getHeader) import Ouroboros.Consensus.Util (eitherToMaybe) import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike (IOLike, MonadSTM (STM), @@ -53,11 +58,11 @@ import Ouroboros.Network.AnchoredFragment (anchor, anchorToSlotNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (HeaderHash) import Test.Consensus.BlockTree (BlockTree (btBranches, btTrunk), - BlockTreeBranch (btbSuffix), prettyBlockTree) + BlockTreeBranch (btbSuffix), deforestBlockTree, + prettyBlockTree) import Test.Consensus.PointSchedule.NodeState (NodeState (..), genesisNodeState) import Test.Consensus.PointSchedule.Peers (PeerId (..)) -import Test.Util.TestBlock (TestBlock, TestHash (TestHash)) enableDebug :: Bool enableDebug = False @@ -300,14 +305,15 @@ instance Condense Slot where -- Slots vectors ---------------------------------------------------------------------------------------------------- -data BranchSlots = +data BranchSlots blk = BranchSlots { - frag :: AF.AnchoredFragment (Header TestBlock), + frag :: AF.AnchoredFragment (Header blk), slots :: Vector Slot, cands :: [PeerId], forkNo :: Word64 } - deriving (Show) + +deriving instance (Show (Header blk), StandardHash blk) => Show (BranchSlots blk) addAspect :: Aspect -> Range -> Bool -> Vector Slot -> Vector Slot addAspect slotAspect (Range l u) overFork slots = @@ -328,7 +334,7 @@ addAspect slotAspect (Range l u) overFork slots = count = u - l + 1 -initSlots :: Int -> Range -> AF.AnchoredFragment TestBlock -> Vector Slot +initSlots :: AF.HasHeader blk => Int -> Range -> AF.AnchoredFragment blk -> Vector Slot initSlots lastSlot (Range l u) blocks = Vector.fromList (snd (mapAccumL step (AF.toOldestFirst blocks) [-1 .. lastSlot])) where @@ -350,32 +356,62 @@ initSlots lastSlot (Range l u) blocks = mkSlot num capacity = Slot {num = At num, capacity, aspects = []} -hashForkNo :: HeaderHash TestBlock -> Word64 -hashForkNo (TestHash h) = - fromMaybe 0 (find (/= 0) h) - -blockForkNo :: ChainHash TestBlock -> Word64 -blockForkNo = \case - BlockHash h -> hashForkNo h +-- | Get the fork number of the 'BlockTreeBranch' a block is on. /Some/ fork +-- numbers are generated during the creation of the test 'BlockTree' in +-- 'Test.Consensus.Genesis.Setup.GenChains.genChainsWithExtraHonestPeers'. +-- There, for 'TestBlock's, these fork numbers are stored in the 'TestHash' +-- by the 'IssueTestBlock' operations. +-- Here, new fork numbers are created so that the pretty printing machinery +-- works independently of the block type; this poses no problem because the +-- exact fork numbers stored in 'TestBlock's are irrelevant as long as they +-- uniquely determine each 'BlockTreeBranch'. +-- +-- POSTCONDITION: All blocks on the same branch suffix share fork number. +-- POSTCONDITION: Each 'BlockTreeBranch' has a distinct fork number. +hashForkNo :: AF.HasHeader blk => BlockTree blk -> HeaderHash blk -> Word64 +hashForkNo bt hash = + let forkFirstBlocks = + -- A map assigning numbers to forked nodes. If any of these is in our + -- ancestry, we are on a branch and have a fork number. + Map.fromList $ do + -- `btBranches` are not sorted in a meaningful way, so the fork + -- numbers assigned here are meant only to distinguish them. + (btb, ix) <- zip (btBranches bt) [1..] + -- The first block in a branch is the /last/ (i.e. leftmost or oldest) one. + -- See the documentation of `Test.Util.TestBlock.TestHash` + -- in relation to this order. + let firstBlockHash = either AF.anchorToHash (BlockHash . blockHash) . AF.last $ btbSuffix btb + pure $ (firstBlockHash, ix) + blockAncestry = foldMap AF.toNewestFirst $ Map.lookup hash $ deforestBlockTree bt + in + -- Get the fork number of the most recent forked node in the ancestry. + fromMaybe 0 $ getFirst $ flip foldMap blockAncestry $ + \blk -> First $ let h = BlockHash $ blockHash blk + in Map.lookup h forkFirstBlocks + +blockForkNo :: AF.HasHeader blk => BlockTree blk -> ChainHash blk -> Word64 +blockForkNo bt = \case + BlockHash h -> hashForkNo bt h _ -> 0 -initBranch :: Int -> Range -> AF.AnchoredFragment TestBlock -> BranchSlots -initBranch lastSlot fragRange fragment = +initBranch :: forall blk. (GetHeader blk, AF.HasHeader blk) => BlockTree blk -> Int -> Range -> AF.AnchoredFragment blk -> BranchSlots blk +initBranch bt lastSlot fragRange fragment = BranchSlots { frag = AF.mapAnchoredFragment getHeader fragment, slots = initSlots lastSlot fragRange fragment, cands = [], - forkNo = blockForkNo (AF.headHash fragment) + forkNo = blockForkNo bt (AF.headHash fragment) } -data TreeSlots = +data TreeSlots blk = TreeSlots { lastSlot :: Int, - branches :: [BranchSlots] + branches :: [BranchSlots blk] } - deriving (Show) -initTree :: BlockTree TestBlock -> TreeSlots +deriving instance (StandardHash blk, Show (Header blk)) => Show (TreeSlots blk) + +initTree :: (AF.HasHeader blk, GetHeader blk) => BlockTree blk -> TreeSlots blk initTree blockTree = TreeSlots {lastSlot, branches = trunk : branches} where @@ -383,7 +419,7 @@ initTree blockTree = branches = initFR <$> branchRanges - initFR = uncurry (initBranch lastSlot) + initFR = uncurry (initBranch blockTree lastSlot) lastSlot = foldr' (max . (to . fst)) 0 (trunkRange : branchRanges) @@ -399,7 +435,9 @@ initTree blockTree = l = withOrigin 0 slotInt (AF.lastSlot f) u = withOrigin 0 slotInt (AF.headSlot f) -commonRange :: AF.AnchoredFragment (Header TestBlock) -> AF.AnchoredFragment (Header TestBlock) -> Maybe (Range, Bool) +commonRange + :: (Eq (Header blk), AF.HasHeader (Header blk)) + => AF.AnchoredFragment (Header blk) -> AF.AnchoredFragment (Header blk) -> Maybe (Range, Bool) commonRange branch segment = do (preB, preS, _, _) <- AF.intersect branch segment lower <- findLower (AF.toNewestFirst preB) (AF.toNewestFirst preS) @@ -420,7 +458,7 @@ commonRange branch segment = do step prev (b1, b2) | b1 == b2 = Just b1 | otherwise = prev -addFragRange :: Aspect -> AF.AnchoredFragment (Header TestBlock) -> TreeSlots -> TreeSlots +addFragRange :: (Eq (Header blk), AF.HasHeader (Header blk)) => Aspect -> AF.AnchoredFragment (Header blk) -> TreeSlots blk -> TreeSlots blk addFragRange aspect selection TreeSlots {lastSlot, branches} = TreeSlots {lastSlot, branches = forBranch <$> branches} where @@ -432,7 +470,7 @@ addFragRange aspect selection TreeSlots {lastSlot, branches} = addCandidate old | Candidate peerId <- aspect = peerId : old | otherwise = old -addCandidateRange :: TreeSlots -> (PeerId, AF.AnchoredFragment (Header TestBlock)) -> TreeSlots +addCandidateRange :: (Eq (Header blk), AF.HasHeader (Header blk)) => TreeSlots blk -> (PeerId, AF.AnchoredFragment (Header blk)) -> TreeSlots blk addCandidateRange treeSlots (pid, candidate) = addFragRange (Candidate pid) candidate treeSlots @@ -440,7 +478,7 @@ updateSlot :: Int -> (Slot -> Slot) -> Vector Slot -> Vector Slot updateSlot i f = Vector.modify (\ mv -> MV.modify mv f i) -addForks :: TreeSlots -> TreeSlots +addForks :: TreeSlots blk -> TreeSlots blk addForks treeSlots@TreeSlots {branches} = treeSlots {branches = addFork <$> branches} where @@ -457,8 +495,8 @@ addForks treeSlots@TreeSlots {branches} = } s = slotInt (withOrigin 0 (+ 1) (anchorToSlotNo (anchor frag))) -addTipPoint :: PeerId -> WithOrigin TestBlock -> TreeSlots -> TreeSlots -addTipPoint pid (NotOrigin b) TreeSlots {lastSlot, branches} = +addTipPoint :: forall blk. AF.HasHeader blk => BlockTree blk -> PeerId -> WithOrigin blk -> TreeSlots blk -> TreeSlots blk +addTipPoint bt pid (NotOrigin b) TreeSlots {lastSlot, branches} = TreeSlots {lastSlot, branches = tryBranch <$> branches} where tryBranch branch@BranchSlots {forkNo, slots} @@ -470,15 +508,15 @@ addTipPoint pid (NotOrigin b) TreeSlots {lastSlot, branches} = update slot = slot {aspects = SlotAspect {slotAspect = TipPoint pid, edge = NoEdge} : aspects slot} - tipForkNo = hashForkNo (blockHash b) + tipForkNo = hashForkNo bt (blockHash b) -addTipPoint _ _ treeSlots = treeSlots +addTipPoint _ _ _ treeSlots = treeSlots -addPoints :: Map PeerId (NodeState TestBlock) -> TreeSlots -> TreeSlots -addPoints peerPoints treeSlots = +addPoints :: AF.HasHeader blk => BlockTree blk -> Map PeerId (NodeState blk) -> TreeSlots blk -> TreeSlots blk +addPoints bt peerPoints treeSlots = Foldable.foldl' step treeSlots (Map.toList peerPoints) where - step z (pid, ap) = addTipPoint pid (nsTip ap) z + step z (pid, ap) = addTipPoint bt pid (nsTip ap) z ---------------------------------------------------------------------------------------------------- -- Cells @@ -547,7 +585,7 @@ prependList = \case [] -> id h : t -> ((h :| t) <>) -branchCells :: BranchSlots -> NonEmpty Cell +branchCells :: BranchSlots blk -> NonEmpty Cell branchCells BranchSlots {cands, slots} = prependList (fragCell <$> Vector.toList slots) (pure peers) where @@ -569,7 +607,7 @@ slotNoCells :: Int -> NonEmpty Cell slotNoCells lastSlot = CellSlotNo Origin :| (CellSlotNo . At <$> [0 .. lastSlot]) ++ [CellEmpty] -treeCells :: TreeSlots -> NonEmpty (NonEmpty Cell) +treeCells :: TreeSlots blk -> NonEmpty (NonEmpty Cell) treeCells TreeSlots {lastSlot, branches} = slotNoCells lastSlot :| (branchCells <$> branches) @@ -826,12 +864,12 @@ renderColBlocks RenderConfig {candidateColors, selectionColor, slotNumberColor, ------------------------------------------------------------------------------------------------------ -- | All inputs for the state diagram printer. -data PeerSimState = +data PeerSimState blk = PeerSimState { - pssBlockTree :: BlockTree TestBlock, - pssSelection :: AF.AnchoredFragment (Header TestBlock), - pssCandidates :: Map PeerId (AF.AnchoredFragment (Header TestBlock)), - pssPoints :: Map PeerId (NodeState TestBlock) + pssBlockTree :: BlockTree blk, + pssSelection :: AF.AnchoredFragment (Header blk), + pssCandidates :: Map PeerId (AF.AnchoredFragment (Header blk)), + pssPoints :: Map PeerId (NodeState blk) } -- TODO add an aspect for the last block of each branch? @@ -839,7 +877,9 @@ data PeerSimState = -- | Pretty-print the current peer simulator state in a block tree, highlighting -- the candidate fragments, selection, and forks in different colors, omitting -- uninteresting segments. -peerSimStateDiagramWith :: RenderConfig -> PeerSimState -> (String, Map PeerId Word64) +peerSimStateDiagramWith + :: (Eq (Header blk), AF.HasHeader blk, GetHeader blk) + => RenderConfig -> PeerSimState blk -> (String, Map PeerId Word64) peerSimStateDiagramWith config PeerSimState {pssBlockTree, pssSelection, pssCandidates, pssPoints} = debugRender (unlines (prettyBlockTree pssBlockTree)) $ (unlines blocks, cache) @@ -849,7 +889,7 @@ peerSimStateDiagramWith config PeerSimState {pssBlockTree, pssSelection, pssCand frags = pruneCells $ treeCells $ - addPoints pssPoints $ + addPoints pssBlockTree pssPoints $ addForks $ flip (Foldable.foldl' addCandidateRange) (Map.toList pssCandidates) $ addFragRange Selection pssSelection $ @@ -871,7 +911,7 @@ defaultRenderConfig = slotNumberColor = 166 } -peerSimStateDiagram :: PeerSimState -> String +peerSimStateDiagram :: (AF.HasHeader blk, Eq (Header blk), GetHeader blk) => PeerSimState blk -> String peerSimStateDiagram = fst . peerSimStateDiagramWith defaultRenderConfig @@ -879,8 +919,9 @@ peerSimStateDiagram = -- a block tree, highlighting the candidate fragments, selection, and forks in -- different colors, omitting uninteresting segments. peerSimStateDiagramTracer :: + (AF.HasHeader blk, Eq (Header blk), GetHeader blk) => Tracer m String -> - Tracer m PeerSimState + Tracer m (PeerSimState blk) peerSimStateDiagramTracer tracer = Tracer (traceWith tracer . peerSimStateDiagram) @@ -892,11 +933,12 @@ peerSimStateDiagramTracer tracer = -- @()@ value as its argument. peerSimStateDiagramSTMTracer :: IOLike m => + (AF.HasHeader blk, Eq (Header blk), GetHeader blk) => Tracer m String -> - BlockTree TestBlock -> - STM m (AF.AnchoredFragment (Header TestBlock)) -> - STM m (Map PeerId (AF.AnchoredFragment (Header TestBlock))) -> - STM m (Map PeerId (Maybe (NodeState TestBlock))) -> + BlockTree blk -> + STM m (AF.AnchoredFragment (Header blk)) -> + STM m (Map PeerId (AF.AnchoredFragment (Header blk))) -> + STM m (Map PeerId (Maybe (NodeState blk))) -> m (Tracer m ()) peerSimStateDiagramSTMTracer stringTracer pssBlockTree selectionVar candidatesVar pointsVar = do peerCache <- uncheckedNewTVarM mempty @@ -921,10 +963,11 @@ peerSimStateDiagramSTMTracer stringTracer pssBlockTree selectionVar candidatesVa -- This variant uses the global debug tracer. peerSimStateDiagramSTMTracerDebug :: IOLike m => - BlockTree TestBlock -> - STM m (AF.AnchoredFragment (Header TestBlock)) -> - STM m (Map PeerId (AF.AnchoredFragment (Header TestBlock))) -> - STM m (Map PeerId (Maybe (NodeState TestBlock))) -> + (AF.HasHeader blk, Eq (Header blk), GetHeader blk) => + BlockTree blk -> + STM m (AF.AnchoredFragment (Header blk)) -> + STM m (Map PeerId (AF.AnchoredFragment (Header blk))) -> + STM m (Map PeerId (Maybe (NodeState blk))) -> m (Tracer m ()) peerSimStateDiagramSTMTracerDebug = peerSimStateDiagramSTMTracer debugTracer diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs index c5c2cad18..e5b88543b 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -- | The scheduled ChainSync and BlockFetch servers are supposed to be linked, @@ -28,6 +29,7 @@ import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.IOLike () +import Test.Util.TestBlock (TestBlock) tests :: TestTree tests = testProperty "ChainSync kills BlockFetch" prop_chainSyncKillsBlockFetch @@ -39,7 +41,7 @@ tests = testProperty "ChainSync kills BlockFetch" prop_chainSyncKillsBlockFetch -- the corresponding block. We check that the block is not served. prop_chainSyncKillsBlockFetch :: Property prop_chainSyncKillsBlockFetch = do - forAllGenesisTest + forAllGenesisTest @TestBlock (do gt@GenesisTest{gtBlockTree} <- genChains (pure 0) pure $ enableMustReplyTimeout $ gt $> dullSchedule (btTrunk gtBlockTree) ) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Rollback.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Rollback.hs index d11b33631..0ec136291 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Rollback.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Rollback.hs @@ -2,12 +2,13 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Test.Consensus.PeerSimulator.Tests.Rollback (tests) where -import qualified Data.Map as M import Cardano.Ledger.BaseTypes (unNonZero) import Control.Monad.Class.MonadTime.SI (Time (Time)) +import qualified Data.Map as M import Ouroboros.Consensus.Block (ChainHash (..), Header) import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Network.AnchoredFragment (AnchoredFragment, @@ -28,6 +29,7 @@ import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.IOLike () +import Test.Util.TestBlock (TestBlock) import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree @@ -44,7 +46,7 @@ tests = testGroup "rollback" [ -- before the current selection. prop_rollback :: Property prop_rollback = do - forAllGenesisTest + forAllGenesisTest @TestBlock (do -- Create a block tree with @1@ alternative chain, such that we can rollback @@ -68,7 +70,7 @@ prop_rollback = do -- blocks before the current selection. prop_cannotRollback :: Property prop_cannotRollback = - forAllGenesisTest + forAllGenesisTest @TestBlock (do gt@GenesisTest{gtSecurityParam, gtBlockTree} <- genChains (pure 1) pure gt {gtSchedule = rollbackSchedule (fromIntegral (unNonZero $ maxRollbacks gtSecurityParam) + 1) gtBlockTree}) @@ -111,5 +113,5 @@ hashOnTrunk :: (AF.HasHeader blk, Eq blk) => BlockTree blk -> ChainHash (Header hashOnTrunk _ GenesisHash = True hashOnTrunk bt (BlockHash hash) = do case M.lookup hash (deforestBlockTree bt) of - Nothing -> error "impossible! hash not at all in block tree" + Nothing -> error "impossible! hash not at all in block tree" Just path -> AF.isPrefixOf path $ btTrunk bt diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs index 5d45137f0..e4e615a6f 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Test.Consensus.PeerSimulator.Tests.Timeouts (tests) where @@ -27,6 +28,7 @@ import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.IOLike () +import Test.Util.TestBlock (TestBlock) import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree @@ -37,7 +39,7 @@ tests = testGroup "timeouts" [ prop_timeouts :: Bool -> Property prop_timeouts mustTimeout = do - forAllGenesisTest + forAllGenesisTest @TestBlock (do gt@GenesisTest{gtBlockTree} <- genChains (pure 0) pure $ enableMustReplyTimeout $ gt $> dullSchedule (btTrunk gtBlockTree) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs index a53eb98a0..bc9ef95c0 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -25,6 +27,7 @@ import Data.Bifunctor (second) import Data.List (intersperse) import qualified Data.List.NonEmpty as NE import Data.Time.Clock (DiffTime, diffTimeToPicoseconds) +import Data.Typeable (Typeable) import Network.TypedProtocol.Codec (AnyMessage (..)) import Ouroboros.Consensus.Block (GenesisWindow (..), Header, Point, WithOrigin (NotOrigin, Origin), succWithOrigin) @@ -44,7 +47,7 @@ import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import Ouroboros.Consensus.Storage.ChainDB.Impl.Types (TraceAddBlockEvent (..)) -import Ouroboros.Consensus.Util.Condense (condense) +import Ouroboros.Consensus.Util.Condense (Condense, condense) import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike (IOLike, MonadMonotonicTime, Time (Time), atomically, getMonotonicTime, readTVarIO, @@ -58,10 +61,9 @@ import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync, Message (..)) import Test.Consensus.PointSchedule.NodeState (NodeState) import Test.Consensus.PointSchedule.Peers (Peer (Peer), PeerId) -import Test.Util.TersePrinting (terseAnchor, terseBlock, +import Test.Util.TersePrinting (Terse (..), terseAnchor, terseBlock, terseFragment, terseHFragment, terseHeader, tersePoint, terseRealPoint, terseTip, terseWithOrigin) -import Test.Util.TestBlock (TestBlock) import Text.Printf (printf) -- * Trace events for the peer simulator @@ -145,9 +147,14 @@ data TraceEvent blk -- * 'TestBlock'-specific tracers for the peer simulator tracerTestBlock :: - (IOLike m) => + (IOLike m + , AF.HasHeader blk + , AF.HasHeader (Header blk) + , Condense (NodeState blk) + , Terse blk + ) => Tracer m String -> - m (Tracer m (TraceEvent TestBlock)) + m (Tracer m (TraceEvent blk)) tracerTestBlock tracer0 = do -- NOTE: Mostly, we read the traces on a per-tick basis, so it is important -- that ticks are visually separated. Also, giving the time on each line can @@ -169,19 +176,24 @@ tracerTestBlock tracer0 = do pure $ Tracer $ traceEventTestBlockWith setTickTime tracer0 tracer mkGDDTracerTestBlock :: - Tracer m (TraceEvent TestBlock) -> - Tracer m (TraceGDDEvent PeerId TestBlock) + Tracer m (TraceEvent blk) -> + Tracer m (TraceGDDEvent PeerId blk) mkGDDTracerTestBlock = contramap TraceGenesisDDEvent traceEventTestBlockWith :: - (MonadMonotonicTime m) => + (MonadMonotonicTime m + , AF.HasHeader blk + , AF.HasHeader (Header blk) + , Condense (NodeState blk) + , Terse blk + ) => (Time -> m ()) -> Tracer m String -> -- ^ Underlying, non-time- and tick-aware tracer. To be used only with lines -- that should not be prefixed by time. Tracer m String -> -- ^ Normal, time- and tick-aware tracer. Should be used by default. - TraceEvent TestBlock -> + TraceEvent blk -> m () traceEventTestBlockWith setTickTime tracer0 tracer = \case TraceSchedulerEvent traceEvent -> traceSchedulerEventTestBlockWith setTickTime tracer0 tracer traceEvent @@ -198,11 +210,17 @@ traceEventTestBlockWith setTickTime tracer0 tracer = \case TraceOther msg -> traceWith tracer msg traceSchedulerEventTestBlockWith :: - (MonadMonotonicTime m) => + forall blk m. + (MonadMonotonicTime m + , AF.HasHeader (Header blk) + , Condense (NodeState blk) + , Terse blk + , Typeable blk + ) => (Time -> m ()) -> Tracer m String -> Tracer m String -> - TraceSchedulerEvent TestBlock -> + TraceSchedulerEvent blk -> m () traceSchedulerEventTestBlockWith setTickTime tracer0 tracer = \case TraceBeginningOfTime -> @@ -244,10 +262,10 @@ traceSchedulerEventTestBlockWith setTickTime tracer0 tracer = \case traceWith tracer (" Node startup complete with selection " ++ terseHFragment selection) where - traceJumpingStates :: [(PeerId, ChainSyncJumpingState m TestBlock)] -> String + traceJumpingStates :: forall m. [(PeerId, ChainSyncJumpingState m blk)] -> String traceJumpingStates = unlines . map (\(pid, state) -> " " ++ condense pid ++ ": " ++ traceJumpingState state) - traceJumpingState :: ChainSyncJumpingState m TestBlock -> String + traceJumpingState :: forall m. ChainSyncJumpingState m blk -> String traceJumpingState = \case Dynamo initState lastJump -> let showInitState = case initState of @@ -258,12 +276,12 @@ traceSchedulerEventTestBlockWith setTickTime tracer0 tracer = \case [ "Objector" , show initState , terseJumpInfo goodJumpInfo - , tersePoint (castPoint badPoint) + , tersePoint @blk (castPoint badPoint) ] Disengaged initState -> "Disengaged " ++ show initState Jumper _ st -> "Jumper _ " ++ traceJumperState st - traceJumperState :: ChainSyncJumpingJumperState TestBlock -> String + traceJumperState :: ChainSyncJumpingJumperState blk -> String traceJumperState = \case Happy initState mGoodJumpInfo -> "Happy " ++ show initState ++ " " ++ maybe "Nothing" terseJumpInfo mGoodJumpInfo @@ -271,15 +289,16 @@ traceSchedulerEventTestBlockWith setTickTime tracer0 tracer = \case [ "(FoundIntersection" , show initState , terseJumpInfo goodJumpInfo - , tersePoint $ castPoint point, ")" + , tersePoint @blk $ castPoint point, ")" ] LookingForIntersection goodJumpInfo badJumpInfo -> unwords ["(LookingForIntersection", terseJumpInfo goodJumpInfo, terseJumpInfo badJumpInfo, ")"] traceScheduledServerHandlerEventTestBlockWith :: + Condense (NodeState blk) => Tracer m String -> String -> - TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock -> + TraceScheduledServerHandlerEvent (NodeState blk) blk -> m () traceScheduledServerHandlerEventTestBlockWith tracer unit = \case TraceHandling handler state -> @@ -296,9 +315,13 @@ traceScheduledServerHandlerEventTestBlockWith tracer unit = \case traceLines = traceUnitLinesWith tracer unit traceScheduledChainSyncServerEventTestBlockWith :: + ( AF.HasHeader blk + , Condense (NodeState blk) + , Terse blk + ) => Tracer m String -> PeerId -> - TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock -> + TraceScheduledChainSyncServerEvent (NodeState blk) blk -> m () traceScheduledChainSyncServerEventTestBlockWith tracer peerId = \case TraceHandlerEventCS traceEvent -> traceScheduledServerHandlerEventTestBlockWith tracer unit traceEvent @@ -337,9 +360,14 @@ traceScheduledChainSyncServerEventTestBlockWith tracer peerId = \case traceLines = traceUnitLinesWith tracer unit traceScheduledBlockFetchServerEventTestBlockWith :: + ( AF.HasHeader (Header blk) + , AF.HasHeader blk + , Condense (NodeState blk) + , Terse blk + ) => Tracer m String -> PeerId -> - TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock -> + TraceScheduledBlockFetchServerEvent (NodeState blk) blk -> m () traceScheduledBlockFetchServerEventTestBlockWith tracer peerId = \case TraceHandlerEventBF traceEvent -> traceScheduledServerHandlerEventTestBlockWith tracer unit traceEvent @@ -361,8 +389,9 @@ traceScheduledBlockFetchServerEventTestBlockWith tracer peerId = \case traceChainDBEventTestBlockWith :: (Monad m) => + Terse blk => Tracer m String -> - ChainDB.TraceEvent TestBlock -> + ChainDB.TraceEvent blk -> m () traceChainDBEventTestBlockWith tracer = \case ChainDB.TraceAddBlockEvent event -> @@ -392,9 +421,14 @@ traceChainDBEventTestBlockWith tracer = \case trace = traceUnitWith tracer "ChainDB" traceChainSyncClientEventTestBlockWith :: + forall blk m. + ( AF.HasHeader (Header blk) + , Terse blk + , Typeable blk + ) => PeerId -> Tracer m String -> - TraceChainSyncClientEvent TestBlock -> + TraceChainSyncClientEvent blk -> m () traceChainSyncClientEventTestBlockWith pid tracer = \case TraceRolledBack point -> @@ -437,15 +471,15 @@ traceChainSyncClientEventTestBlockWith pid tracer = \case where trace = traceUnitWith tracer ("ChainSyncClient " ++ condense pid) - showInstr :: Instruction TestBlock -> String + showInstr :: Instruction blk -> String showInstr = \case JumpInstruction (JumpTo ji) -> "JumpTo " ++ terseJumpInfo ji JumpInstruction (JumpToGoodPoint ji) -> "JumpToGoodPoint " ++ terseJumpInfo ji RunNormally -> "RunNormally" Restart -> "Restart" -terseJumpInfo :: JumpInfo TestBlock -> String -terseJumpInfo ji = tersePoint (castPoint $ headPoint $ jTheirFragment ji) +terseJumpInfo :: forall blk. (AF.HasHeader (Header blk), Terse blk, Typeable blk) => JumpInfo blk -> String +terseJumpInfo ji = tersePoint @blk (castPoint $ headPoint $ jTheirFragment ji) traceChainSyncClientTerminationEventTestBlockWith :: PeerId -> @@ -480,10 +514,11 @@ traceBlockFetchClientTerminationEventTestBlockWith pid tracer = \case -- | Trace all the SendRecv events of the ChainSync mini-protocol. traceChainSyncSendRecvEventTestBlockWith :: Applicative m => + Terse blk => PeerId -> String -> Tracer m String -> - TraceSendRecv (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)) -> + TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)) -> m () traceChainSyncSendRecvEventTestBlockWith pid ptp tracer = \case TraceSendMsg amsg -> traceMsg "send" amsg @@ -512,9 +547,10 @@ traceDbjEventWith tracer = traceWith tracer . \case RotatedDynamo old new -> "Rotated dynamo from " ++ condense old ++ " to " ++ condense new traceCsjEventWith :: + Terse blk => PeerId -> Tracer m String -> - TraceEventCsj PeerId TestBlock -> + TraceEventCsj PeerId blk -> m () traceCsjEventWith peer tracer = f . \case BecomingObjector mbOld -> "is now the Objector" ++ replacing mbOld @@ -538,7 +574,7 @@ traceCsjEventWith peer tracer = f . \case Nothing -> "" Just old -> ", replacing: " ++ condense old -prettyDensityBounds :: [(PeerId, DensityBounds TestBlock)] -> [String] +prettyDensityBounds :: forall blk. (AF.HasHeader (Header blk), Terse blk) => [(PeerId, DensityBounds blk)] -> [String] prettyDensityBounds bounds = showPeers (second showBounds <$> bounds) where @@ -555,7 +591,7 @@ prettyDensityBounds bounds = -- the density comparison should not be applied to two peers if they share any headers after the LoE fragment. lastPoint = "point: " ++ - tersePoint (castPoint @(Header TestBlock) @TestBlock (AF.lastPoint clippedFragment)) ++ + tersePoint (castPoint @(Header blk) @blk (AF.lastPoint clippedFragment)) ++ ", " showLatestSlot = \case @@ -569,7 +605,7 @@ showPeers :: [(PeerId, String)] -> [String] showPeers = map (\ (peer, v) -> " " ++ condense peer ++ ": " ++ v) -- * Other utilities -terseGDDEvent :: TraceGDDEvent PeerId TestBlock -> String +terseGDDEvent :: forall blk. (AF.HasHeader (Header blk), Terse blk) => TraceGDDEvent PeerId blk -> String terseGDDEvent = \case TraceGDDDisconnected peers -> "GDD | Disconnected " <> show (NE.toList peers) TraceGDDDebug GDDDebugInfo { @@ -585,7 +621,7 @@ terseGDDEvent = \case " Selection: " ++ terseHFragment curChain, " Candidates:" ] ++ - showPeers (second (tersePoint . castPoint . AF.headPoint) <$> candidates) ++ + showPeers (second (tersePoint @blk . castPoint . AF.headPoint) <$> candidates) ++ [ " Candidate suffixes (bounds):" ] ++ @@ -593,10 +629,10 @@ terseGDDEvent = \case [" Density bounds:"] ++ prettyDensityBounds bounds ++ [" New candidate tips:"] ++ - showPeers (second (tersePoint . castPoint . AF.headPoint) <$> candidateSuffixes) ++ + showPeers (second (tersePoint @blk . castPoint . AF.headPoint) <$> candidateSuffixes) ++ [ " Losing peers: " ++ show losingPeers, - " Setting loeFrag: " ++ terseAnchor (AF.castAnchor loeHead) + " Setting loeFrag: " ++ terseAnchor @blk (AF.castAnchor loeHead) ] where diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs index a9cc75909..1490cde3c 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs @@ -34,6 +34,7 @@ module Test.Consensus.PointSchedule ( , PointSchedule (..) , PointsGeneratorParams (..) , RunGenesisTestResult (..) + , deforestBlockTree , enrichedWith , ensureScheduleDuration , genesisNodeState @@ -46,11 +47,8 @@ module Test.Consensus.PointSchedule ( , prettyPointSchedule , stToGen , uniformPoints - , deforestBlockTree ) where -import qualified Data.Map as M -import Data.Map (Map) import Cardano.Ledger.BaseTypes (unNonZero) import Cardano.Slotting.Time (SlotLength) import Control.Monad (replicateM) @@ -64,7 +62,8 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Time (DiffTime) import Data.Word (Word64) -import Ouroboros.Consensus.Block.Abstract (withOriginToMaybe) +import Ouroboros.Consensus.Block.Abstract (HasHeader, HeaderHash, + withOriginToMaybe) import Ouroboros.Consensus.Ledger.SupportsProtocol (GenesisWindow (..)) import Ouroboros.Consensus.Network.NodeToNode (ChainSyncTimeout (..)) @@ -78,7 +77,7 @@ import Ouroboros.Network.Point (withOrigin) import qualified System.Random.Stateful as Random import System.Random.Stateful (STGenM, StatefulGen, runSTGen_) import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..), - allFragments, prettyBlockTree, deforestBlockTree) + allFragments, deforestBlockTree, prettyBlockTree) import Test.Consensus.PeerSimulator.StateView (StateView) import Test.Consensus.PointSchedule.NodeState (NodeState (..), genesisNodeState) @@ -93,10 +92,8 @@ import Test.Consensus.PointSchedule.SinglePeer.Indices import Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (Delta)) import Test.QuickCheck (Gen, arbitrary) import Test.QuickCheck.Random (QCGen) -import Test.Util.TersePrinting (terseFragment) -import Test.Util.TestBlock (TestBlock) +import Test.Util.TersePrinting (Terse, terseFragment) import Text.Printf (printf) -import Ouroboros.Consensus.Block.Abstract (HeaderHash, HasHeader) prettyPointSchedule :: @@ -536,12 +533,12 @@ data GenesisTest blk schedule = GenesisTest type GenesisTestFull blk = GenesisTest blk (PointSchedule blk) -- | All the data describing the result of a test -data RunGenesisTestResult = RunGenesisTestResult +data RunGenesisTestResult blk = RunGenesisTestResult { rgtrTrace :: String, - rgtrStateView :: StateView TestBlock + rgtrStateView :: StateView blk } -prettyGenesisTest :: (schedule -> [String]) -> GenesisTest TestBlock schedule -> [String] +prettyGenesisTest :: (HasHeader blk, Terse blk) => (schedule -> [String]) -> GenesisTest blk schedule -> [String] prettyGenesisTest prettySchedule genesisTest = [ "GenesisTest:" , " gtSecurityParam: " ++ show (maxRollbacks gtSecurityParam) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Util/TersePrinting.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Util/TersePrinting.hs index 180ae0dd0..5f4c7b70a 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Util/TersePrinting.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Util/TersePrinting.hs @@ -1,19 +1,17 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} -- | Helpers for printing various objects in a terse way. Terse printing is -- similar to that provided by the 'Condense' typeclass except it can be -- sometimes even more compact and it is very specific to tests. module Test.Util.TersePrinting ( - terseAnchor - , terseBlock - , terseFragment - , terseHFragment - , terseHWTFragment - , terseHeader + Terse (..) + , terseAnchor , terseMaybe - , tersePoint , terseRealPoint - , terseTip , terseWithOrigin ) where @@ -33,6 +31,53 @@ import Ouroboros.Network.Point (WithOrigin (..)) import Test.Util.TestBlock (Header (TestHeader), TestBlock, TestHash (TestHash), unTestHash) +terseRealPoint :: Terse blk => RealPoint blk -> String +terseRealPoint = tersePoint . realPointToPoint + +-- | Same as 'tersePoint' for anchors. +terseAnchor :: Terse blk => Anchor blk -> String +terseAnchor = tersePoint . anchorToPoint + +-- | Given a printer for elements of type @a@, prints a @WithOrigin a@ in a +-- terse way. Origin shows as @G@. +terseWithOrigin :: (a -> String) -> WithOrigin a -> String +terseWithOrigin _ Origin = "G" +terseWithOrigin terseA (At a) = terseA a + +class Terse blk where + tersePoint :: Point blk -> String + terseFragment :: AnchoredFragment blk -> String + terseHFragment :: AnchoredFragment (Header blk) -> String + terseHWTFragment :: AnchoredFragment (HeaderWithTime blk) -> String + terseBlock :: blk -> String + terseTip :: Tip blk -> String + terseHeader :: Header blk -> String + +-- | Same as 'terseWithOrigin' for 'Maybe'. +terseMaybe :: (a -> String) -> Maybe a -> String +terseMaybe _ Nothing = "X" +terseMaybe terseA (Just a) = terseA a + + +instance Terse TestBlock where + terseHWTFragment = terseHFragment . mapAnchoredFragment hwtHeader + terseHFragment = terseFragment . mapAnchoredFragment (\(TestHeader block) -> block) + terseFragment fragment = + terseAnchor (anchor fragment) ++ renderBlocks + where + renderBlocks = case toOldestFirst fragment of + [] -> "" + blocks -> " | " ++ unwords (map terseBlock' blocks) + terseBlock' block = terseBlockSlotHash' (blockNo block) (blockSlot block) (blockHash block) + terseTip TipGenesis = "G" + terseTip (Tip sno hash bno) = terseBlockSlotHash bno sno hash + tersePoint GenesisPoint = "G" + tersePoint (BlockPoint slot hash) = + terseBlockSlotHash (BlockNo (fromIntegral (length (unTestHash hash)))) slot hash + terseHeader (TestHeader block) = terseBlock block + terseBlock block = terseBlockSlotHash (blockNo block) (blockSlot block) (blockHash block) + + -- | Run-length encoding of a list. This groups consecutive duplicate elements, -- counting them. Only the first element of the equality is kept. For instance: -- @@ -65,67 +110,3 @@ terseBlockSlotHash' (BlockNo bno) (SlotNo sno) (TestHash hash) = | forkNo == 0 = "" | otherwise = "[" ++ show forkNo ++ "]" --- | Print a 'TestBlock' as @block-slot[hash]@. @hash@ only shows if there is a --- non-zero element in it. When it shows, it shows in a compact form. For --- instance, the hash @[0,0,1,0,0,0]@ shows as @[2x0,1,3x0]@. -terseBlock :: TestBlock -> String -terseBlock block = terseBlockSlotHash (blockNo block) (blockSlot block) (blockHash block) - --- | Same as 'terseBlock' except only the last element of the hash shows, if it --- is non-zero. This makes sense when showing a fragment. -terseBlock' :: TestBlock -> String -terseBlock' block = terseBlockSlotHash' (blockNo block) (blockSlot block) (blockHash block) - --- | Same as 'terseBlock' for headers. -terseHeader :: Header TestBlock -> String -terseHeader (TestHeader block) = terseBlock block - --- | Same as 'terseBlock' for points. Genesis shows as @G@. -tersePoint :: Point TestBlock -> String -tersePoint GenesisPoint = "G" -tersePoint (BlockPoint slot hash) = - terseBlockSlotHash (BlockNo (fromIntegral (length (unTestHash hash)))) slot hash - -terseRealPoint :: RealPoint TestBlock -> String -terseRealPoint = tersePoint . realPointToPoint - --- | Same as 'tersePoint' for anchors. -terseAnchor :: Anchor TestBlock -> String -terseAnchor = tersePoint . anchorToPoint - --- | Same as 'tersePoint' for tips. -terseTip :: Tip TestBlock -> String -terseTip TipGenesis = "G" -terseTip (Tip sno hash bno) = terseBlockSlotHash bno sno hash - --- | Given a printer for elements of type @a@, prints a @WithOrigin a@ in a --- terse way. Origin shows as @G@. -terseWithOrigin :: (a -> String) -> WithOrigin a -> String -terseWithOrigin _ Origin = "G" -terseWithOrigin terseA (At a) = terseA a - --- | Print a fragment of 'TestBlock' in a terse way. This shows as @anchor | --- block ...@ where @anchor@ is printed with 'terseAnchor' and @block@s are --- printed with @terseBlock'@; in particular, only the last element of the hash --- shows and only when it is non-zero. -terseFragment :: AnchoredFragment TestBlock -> String -terseFragment fragment = - terseAnchor (anchor fragment) ++ renderBlocks - where - renderBlocks = case toOldestFirst fragment of - [] -> "" - blocks -> " | " ++ unwords (map terseBlock' blocks) - --- | Same as 'terseFragment' for fragments of headers. -terseHFragment :: AnchoredFragment (Header TestBlock) -> String -terseHFragment = terseFragment . mapAnchoredFragment (\(TestHeader block) -> block) - --- | Same as 'terseFragment' for fragments of headers with time. --- -terseHWTFragment :: AnchoredFragment (HeaderWithTime TestBlock) -> String -terseHWTFragment = terseHFragment . mapAnchoredFragment hwtHeader - --- | Same as 'terseWithOrigin' for 'Maybe'. -terseMaybe :: (a -> String) -> Maybe a -> String -terseMaybe _ Nothing = "X" -terseMaybe terseA (Just a) = terseA a