From 8c20fd4076a705263bd180b90a67db9431c98453 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Mon, 3 Feb 2020 12:18:01 -0800 Subject: [PATCH] consensus: add optional expiry slot to Mock transactions --- .../test/Test/ThreadNet/DualPBFT.hs | 1 + .../test/Test/ThreadNet/RealPBFT.hs | 1 + .../ouroboros-consensus-mock.cabal | 1 + .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 19 ++++++++-- .../Ouroboros/Consensus/Mock/Ledger/State.hs | 8 +++-- .../Ouroboros/Consensus/Mock/Ledger/UTxO.hs | 28 ++++++++++----- .../test/Test/Consensus/Ledger/Mock.hs | 2 +- .../test/Test/ThreadNet/BFT.hs | 36 +++++++++++++++---- .../test/Test/ThreadNet/LeaderSchedule.hs | 2 ++ .../test/Test/ThreadNet/PBFT.hs | 2 ++ .../test/Test/ThreadNet/Praos.hs | 2 ++ .../test/Test/ThreadNet/TxGen/Mock.hs | 16 ++++++--- .../test/Test/ThreadNet/Util/SimpleBlock.hs | 30 ++++++++++++++++ .../src/Test/ThreadNet/General.hs | 20 ++++++++++- .../src/Test/ThreadNet/Network.hs | 4 +-- .../test-consensus/Test/Consensus/Mempool.hs | 6 ++-- 16 files changed, 149 insertions(+), 29 deletions(-) create mode 100644 ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Util/SimpleBlock.hs diff --git a/ouroboros-consensus-byron/test/Test/ThreadNet/DualPBFT.hs b/ouroboros-consensus-byron/test/Test/ThreadNet/DualPBFT.hs index 4fa4041e0cb..d4375d9c592 100644 --- a/ouroboros-consensus-byron/test/Test/ThreadNet/DualPBFT.hs +++ b/ouroboros-consensus-byron/test/Test/ThreadNet/DualPBFT.hs @@ -89,6 +89,7 @@ prop_convergence setup = withMaxSuccess 10 $ _ -> 0) (setupExpectedRejections setup) 1 + (const (property True)) (setupTestOutput setup) where cfg = setupConfig setup diff --git a/ouroboros-consensus-byron/test/Test/ThreadNet/RealPBFT.hs b/ouroboros-consensus-byron/test/Test/ThreadNet/RealPBFT.hs index 5ec93acd190..4a7f2c94fb5 100644 --- a/ouroboros-consensus-byron/test/Test/ThreadNet/RealPBFT.hs +++ b/ouroboros-consensus-byron/test/Test/ThreadNet/RealPBFT.hs @@ -574,6 +574,7 @@ prop_simple_real_pbft_convergence produceEBBs k _ -> 0) (expectedBlockRejection k numCoreNodes nodeRestarts) 1 + (const (property True)) testOutput .&&. not (all (Chain.null . snd) finalChains) .&&. conjoin (map (hasAllEBBs k numSlots produceEBBs) finalChains) diff --git a/ouroboros-consensus/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal b/ouroboros-consensus/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal index 6a7fa820468..697201cc043 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal +++ b/ouroboros-consensus/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal @@ -84,6 +84,7 @@ test-suite test Test.ThreadNet.Praos Test.ThreadNet.TxGen.Mock Test.ThreadNet.Util.HasCreator.Mock + Test.ThreadNet.Util.SimpleBlock build-depends: base , binary diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs index 16508a7b41a..f4839d609bc 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -61,6 +61,7 @@ import qualified Codec.CBOR.Encoding as CBOR import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Write as CBOR import Codec.Serialise (Serialise (..), serialise) +import Control.Monad (guard) import Control.Monad.Except import qualified Data.Binary.Get as Get import qualified Data.Binary.Put as Put @@ -330,8 +331,22 @@ instance MockProtocolSpecific c ext => ApplyTx (SimpleBlock c ext) where type ApplyTxErr (SimpleBlock c ext) = MockError (SimpleBlock c ext) - applyTx = const updateSimpleUTxO - reapplyTx = const updateSimpleUTxO + applyTx = reapplyTx + reapplyTx _ tx tl = + case hasExpired of + Just e -> throwError e + Nothing -> updateSimpleUTxO tx tl + where + hasExpired :: Maybe (MockError blk) + hasExpired = case expiry of + Mock.DoNotExpire -> Nothing + Mock.ExpireAtOnsetOf s -> do + guard $ s <= tickedSlotNo + Just $ MockExpired s tickedSlotNo + where + TickedLedgerState{tickedSlotNo} = tl + SimpleGenTx{simpleGenTx} = tx + Mock.Tx expiry _ins _outs = simpleGenTx instance HasTxId (GenTx (SimpleBlock c ext)) where newtype TxId (GenTx (SimpleBlock c ext)) = SimpleGenTxId diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs index 18a4bf64a2b..3c3e29d4d0b 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs @@ -25,7 +25,7 @@ import Cardano.Crypto.Hash import Cardano.Prelude (NoUnexpectedThunks) import Ouroboros.Network.Block (ChainHash, HasHeader, HeaderHash, - Point, StandardHash, genesisPoint, pointHash) + Point, SlotNo, StandardHash, genesisPoint, pointHash) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Mock.Ledger.Address @@ -45,7 +45,11 @@ data MockState blk = MockState { deriving instance Serialise (HeaderHash blk) => Serialise (MockState blk) data MockError blk = - MockUtxoError UtxoError + -- | The block expired in the first 'SlotNo', and it failed to validate + -- against a 'Ouroboros.Consensus.Ledger.Abstract.TickedLedgerState' + -- carrying the second 'SlotNo'. + MockExpired !SlotNo !SlotNo + | MockUtxoError UtxoError | MockInvalidHash (ChainHash blk) (ChainHash blk) deriving (Generic, NoUnexpectedThunks) diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/UTxO.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/UTxO.hs index 78c3ab49f08..10ff2c0003d 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/UTxO.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/UTxO.hs @@ -15,6 +15,7 @@ module Ouroboros.Consensus.Mock.Ledger.UTxO ( , Amount , Ix , Utxo + , Expiry (..) -- * Computing UTxO , UtxoError(..) , HasUtxo(..) @@ -38,6 +39,7 @@ import Cardano.Binary (ToCBOR (..)) import Cardano.Crypto.Hash import Cardano.Prelude (NoUnexpectedThunks, UseIsNormalForm (..)) +import Ouroboros.Network.Block (SlotNo) import Ouroboros.Network.MockChain.Chain (Chain, toOldestFirst) import Ouroboros.Consensus.Util @@ -50,14 +52,23 @@ import Ouroboros.Consensus.Mock.Ledger.Address Basic definitions -------------------------------------------------------------------------------} -data Tx = UnsafeTx (Set TxIn) [TxOut] +data Expiry + = DoNotExpire + | ExpireAtOnsetOf !SlotNo + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Serialise, NFData, NoUnexpectedThunks) + +instance Condense Expiry where + condense = show + +data Tx = UnsafeTx Expiry (Set TxIn) [TxOut] deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Serialise, NFData) deriving NoUnexpectedThunks via UseIsNormalForm Tx -pattern Tx :: Set TxIn -> [TxOut] -> Tx -pattern Tx ins outs <- UnsafeTx ins outs where - Tx ins outs = force $ UnsafeTx ins outs +pattern Tx :: Expiry -> Set TxIn -> [TxOut] -> Tx +pattern Tx expiry ins outs <- UnsafeTx expiry ins outs where + Tx expiry ins outs = force $ UnsafeTx expiry ins outs {-# COMPLETE Tx #-} @@ -65,7 +76,7 @@ instance ToCBOR Tx where toCBOR = encode instance Condense Tx where - condense (Tx ins outs) = condense (ins, outs) + condense (Tx expiry ins outs) = condense (expiry, ins, outs) type Ix = Word type Amount = Word @@ -100,8 +111,8 @@ class HasUtxo a where -------------------------------------------------------------------------------} instance HasUtxo Tx where - txIns (Tx ins _outs) = ins - txOuts tx@(Tx _ins outs) = + txIns (Tx _expiry ins _outs) = ins + txOuts tx@(Tx _expiry _ins outs) = Map.fromList $ zipWith aux [0..] outs where aux :: Ix -> TxOut -> (TxIn, TxOut) @@ -143,7 +154,8 @@ instance HasUtxo a => HasUtxo (Chain a) where -- | Transaction giving initial stake to the nodes genesisTx :: AddrDist -> Tx -genesisTx addrDist = Tx mempty [(addr, 1000) | addr <- Map.keys addrDist] +genesisTx addrDist = + Tx DoNotExpire mempty [(addr, 1000) | addr <- Map.keys addrDist] genesisUtxo :: AddrDist -> Utxo genesisUtxo addrDist = txOuts (genesisTx addrDist) diff --git a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/Consensus/Ledger/Mock.hs b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/Consensus/Ledger/Mock.hs index 3352ce58706..85df44c3f96 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/Consensus/Ledger/Mock.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/Consensus/Ledger/Mock.hs @@ -139,7 +139,7 @@ instance Arbitrary SimpleBody where arbitrary = SimpleBody <$> listOf arbitrary instance Arbitrary Tx where - arbitrary = Tx + arbitrary = Tx DoNotExpire <$> pure mempty -- For simplicity <*> arbitrary diff --git a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/BFT.hs b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/BFT.hs index 7544c95ebdb..606a19bd900 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/BFT.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/BFT.hs @@ -1,22 +1,25 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} module Test.ThreadNet.BFT ( tests ) where -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map + import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck import Cardano.Slotting.Slot +import Ouroboros.Network.Block (SlotNo (..)) + import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.BlockchainTime.Mock import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Node () import Ouroboros.Consensus.Mock.Node.BFT -import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..)) import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util.Random (Seed (..)) @@ -27,11 +30,12 @@ import Test.ThreadNet.Util import Test.ThreadNet.Util.NodeJoinPlan import Test.ThreadNet.Util.NodeRestarts import Test.ThreadNet.Util.NodeTopology +import Test.ThreadNet.Util.SimpleBlock import Test.Util.Orphans.Arbitrary () tests :: TestTree -tests = testGroup "BFT" +tests = testGroup "BFT" $ [ testProperty "delayed message corner case" $ once $ let ncn = NumCoreNodes 2 in @@ -44,11 +48,30 @@ tests = testGroup "BFT" , slotLengths = singletonSlotLengths (slotLengthFromSec 1) , initSeed = Seed {getSeed = (12659702313441544615,9326820694273232011,15820857683988100572,2201554969601311572,4716411940989238571)} } - , - testProperty "simple convergence" $ \tc -> + , testProperty "Mock.applyChainTick is not a no-op" $ + -- This repro failed via on a wip branch that included a fix for Issue + -- 1489 and but not for Issue 1559. PR 1562 fixed it. We're retaining + -- this as a regression test. + once $ + let ncn = NumCoreNodes 3 in + prop_simple_bft_convergence (SecurityParam 5) + TestConfig + { numCoreNodes = ncn + , numSlots = NumSlots 7 + , nodeJoinPlan = NodeJoinPlan $ Map.fromList [(CoreNodeId 0, SlotNo 0),(CoreNodeId 1, SlotNo 2),(CoreNodeId 2, SlotNo 2)] + , nodeRestarts = noRestarts + , nodeTopology = meshNodeTopology ncn + , slotLengths = defaultSlotLengths + , initSeed = Seed (6358650144370660550,17563794202468751585,17692838336641672274,12649320068211251815,18441126729279419067) + } + , testProperty "simple convergence" $ \tc -> + -- TODO k > 1 as a workaround for Issue #1511. + -- forAll (SecurityParam <$> elements [2 .. 10]) $ \k -> prop_simple_bft_convergence k tc ] + where + defaultSlotLengths = singletonSlotLengths $ slotLengthFromSec 1 prop_simple_bft_convergence :: SecurityParam -> TestConfig @@ -64,6 +87,7 @@ prop_simple_bft_convergence k Nothing (const False) 0 + prop_validSimpleBlock testOutput where testOutput = diff --git a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/LeaderSchedule.hs b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/LeaderSchedule.hs index 2baa60f0faa..feb0f0adf0b 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/LeaderSchedule.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/LeaderSchedule.hs @@ -35,6 +35,7 @@ import Test.ThreadNet.Util.HasCreator.Mock () import Test.ThreadNet.Util.NodeJoinPlan import Test.ThreadNet.Util.NodeRestarts import Test.ThreadNet.Util.NodeTopology +import Test.ThreadNet.Util.SimpleBlock import Test.Util.Orphans.Arbitrary () @@ -98,6 +99,7 @@ prop_simple_leader_schedule_convergence Nothing (const False) 0 + prop_validSimpleBlock testOutput where testOutput@TestOutput{testOutputNodes} = diff --git a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/PBFT.hs b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/PBFT.hs index a3a8fef0899..9f6f0e65894 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/PBFT.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/PBFT.hs @@ -40,6 +40,7 @@ import Test.ThreadNet.Util.HasCreator.Mock () import Test.ThreadNet.Util.NodeJoinPlan import Test.ThreadNet.Util.NodeRestarts import Test.ThreadNet.Util.NodeTopology +import Test.ThreadNet.Util.SimpleBlock import Test.Util.Orphans.Arbitrary () @@ -87,6 +88,7 @@ prop_simple_pbft_convergence _ -> 0) (expectedBlockRejection numCoreNodes) 0 + prop_validSimpleBlock testOutput where NumCoreNodes nn = numCoreNodes diff --git a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Praos.hs b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Praos.hs index 38a2110cc61..0047cdb4a10 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Praos.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Praos.hs @@ -29,6 +29,7 @@ import Test.ThreadNet.Util.HasCreator.Mock () import Test.ThreadNet.Util.NodeJoinPlan import Test.ThreadNet.Util.NodeRestarts import Test.ThreadNet.Util.NodeTopology +import Test.ThreadNet.Util.SimpleBlock import Test.Util.Orphans.Arbitrary () @@ -102,6 +103,7 @@ prop_simple_praos_convergence Nothing (const False) 0 + prop_validSimpleBlock testOutput where testOutput@TestOutput{testOutputNodes} = diff --git a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/TxGen/Mock.hs b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/TxGen/Mock.hs index 54b86c4216f..9ba48ab079e 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/TxGen/Mock.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/TxGen/Mock.hs @@ -8,6 +8,8 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import GHC.Stack (HasCallStack) +import Ouroboros.Network.Block (SlotNo (..)) + import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Util.Random @@ -18,8 +20,8 @@ import Test.ThreadNet.TxGen -------------------------------------------------------------------------------} instance TxGen (SimpleBlock SimpleMockCrypto ext) where - testGenTx numCoreNodes _curSlotNo _cfg ledgerState = - mkSimpleGenTx <$> genSimpleTx addrs utxo + testGenTx numCoreNodes curSlotNo _cfg ledgerState = + mkSimpleGenTx <$> genSimpleTx curSlotNo addrs utxo where addrs :: [Addr] addrs = Map.keys $ mkAddrDist numCoreNodes @@ -27,8 +29,8 @@ instance TxGen (SimpleBlock SimpleMockCrypto ext) where utxo :: Utxo utxo = mockUtxo $ simpleLedgerState ledgerState -genSimpleTx :: forall m. MonadRandom m => [Addr] -> Utxo -> m Tx -genSimpleTx addrs u = do +genSimpleTx :: forall m. MonadRandom m => SlotNo -> [Addr] -> Utxo -> m Tx +genSimpleTx curSlotNo addrs u = do let senders = Set.toList . Set.fromList . map fst . Map.elems $ u -- people with funds sender <- genElt senders recipient <- genElt $ filter (/= sender) addrs @@ -40,8 +42,12 @@ genSimpleTx addrs u = do outs = if amount == fortune then [outRecipient] else [outRecipient, (sender, fortune - amount)] - return $ Tx ins outs + expiry <- (mkExpiry . SlotNo . fromIntegral) <$> generateBetween 2 10 + return $ Tx expiry ins outs where + mkExpiry :: SlotNo -> Expiry + mkExpiry delta = ExpireAtOnsetOf $ curSlotNo + delta + genElt :: HasCallStack => [a] -> m a genElt xs = do m <- generateElement xs diff --git a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Util/SimpleBlock.hs b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Util/SimpleBlock.hs new file mode 100644 index 00000000000..0d1df8c4468 --- /dev/null +++ b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Util/SimpleBlock.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Test.ThreadNet.Util.SimpleBlock ( + prop_validSimpleBlock, + ) where + +import Test.QuickCheck + +import Ouroboros.Network.Block (HasHeader, SlotNo (..), blockSlot) + +import Ouroboros.Consensus.Mock.Ledger +import Ouroboros.Consensus.Util.Condense (condense) + +prop_validSimpleBlock + :: HasHeader (SimpleBlock' c ext ext') + => SimpleBlock' c ext ext' -> Property +prop_validSimpleBlock blk = conjoin $ map each $ simpleTxs $ simpleBody blk + where + now :: SlotNo + now = blockSlot blk + + msg :: String + msg = "block contains expired transaction:" + + each :: Tx -> Property + each tx@(Tx expiry _ins _outs) = + counterexample (msg <> " " <> condense (now, tx)) $ + case expiry of + DoNotExpire -> True + ExpireAtOnsetOf s -> now < s diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/General.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/General.hs index cb14f20be04..e9179864b28 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/General.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/General.hs @@ -285,13 +285,16 @@ prop_general :: -> Maybe LeaderSchedule -> Maybe NumBlocks -> (BlockRejection blk -> Bool) + -- ^ Was this block rejection expected? -> BlockNo -- ^ block number of the first proper block after genesis + -> (blk -> Property) + -- ^ Test if the block is valid -> TestOutput blk -> Property prop_general countTxs k TestConfig{numSlots, nodeJoinPlan, nodeRestarts, nodeTopology} mbSchedule mbMaxForkLength expectedBlockRejection firstBlockNo - TestOutput{testOutputNodes, testOutputTipBlockNos} = + prop_valid_block TestOutput{testOutputNodes, testOutputTipBlockNos} = counterexample ("nodeChains: " <> unlines ("" : map (\x -> " " <> condense x) (Map.toList nodeChains))) $ counterexample ("nodeJoinPlan: " <> condense nodeJoinPlan) $ counterexample ("nodeRestarts: " <> condense nodeRestarts) $ @@ -311,6 +314,7 @@ prop_general countTxs k TestConfig{numSlots, nodeJoinPlan, nodeRestarts, nodeTop tabulate "involves >=1 re-delegation" [show hasNodeRekey] $ tabulate "average #txs/block" [show (range averageNumTxs)] $ prop_no_unexpected_BlockRejections .&&. + prop_no_invalid_blocks .&&. prop_all_common_prefix maxForkLength (Map.elems nodeChains) .&&. @@ -621,3 +625,17 @@ prop_general countTxs k TestConfig{numSlots, nodeJoinPlan, nodeRestarts, nodeTop average :: [Double] -> Double average [] = 0 average xs = sum xs / fromIntegral (length xs) + + -- The 'prop_valid_block' argument could, for example, check for no expired + -- transactions. + prop_no_invalid_blocks :: Property + prop_no_invalid_blocks = conjoin $ + [ counterexample ("In the final chain of " <> condense nid) $ + counterexample ("In slot " <> condense s) $ + counterexample ("In the block " <> condense blk) $ + prop_valid_block blk + | (nid, NodeOutput{nodeOutputForges}) <- Map.toList testOutputNodes + -- checking all forged blocks, even if they were never or only + -- temporarily selected. + , (s, blk) <- Map.toAscList nodeOutputForges + ] diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs index 5e832ae861e..d1c6efc0bfb 100644 --- a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs @@ -1038,9 +1038,9 @@ newNodeInfo = do data NodeOutput blk = NodeOutput { nodeOutputAdds :: Map SlotNo (Set (RealPoint blk, BlockNo)) , nodeOutputFinalChain :: Chain blk - , nodeOutputNodeDBs :: NodeDBs MockFS , nodeOutputForges :: Map SlotNo blk , nodeOutputInvalids :: Map (RealPoint blk) [ExtValidationError blk] + , nodeOutputNodeDBs :: NodeDBs MockFS } data TestOutput blk = TestOutput @@ -1076,10 +1076,10 @@ mkTestOutput vertexInfos = do Map.fromListWith Set.union $ [ (s, Set.singleton (p, bno)) | (s, p, bno) <- nodeEventsAdds ] , nodeOutputFinalChain = ch - , nodeOutputNodeDBs = nodeInfoDBs , nodeOutputForges = Map.fromList $ [ (s, b) | TraceForgedBlock s _ b _ <- nodeEventsForges ] + , nodeOutputNodeDBs = nodeInfoDBs , nodeOutputInvalids = (:[]) <$> Map.fromList nodeEventsInvalids } diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/Mempool.hs b/ouroboros-consensus/test-consensus/Test/Consensus/Mempool.hs index c0094dd2763..046c4965e34 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/Mempool.hs @@ -464,7 +464,8 @@ genValidTx ledgerState@(SimpleLedgerState MockState { mockUtxo = utxo }) = do = [outRecipient] | otherwise = [outRecipient, (sender, fortune - amount)] - tx = mkSimpleGenTx $ Tx ins outs + -- TODO how to integrate expiry into these tests? + tx = mkSimpleGenTx $ Tx DoNotExpire ins outs return (tx, mustBeValid (applyTxToLedger ledgerState tx)) where peopleWithFunds :: Map Addr [(TxIn, Amount)] @@ -484,7 +485,8 @@ genInvalidTx ledgerState@(SimpleLedgerState MockState { mockUtxo = utxo }) = do -- more than 5 000 is invalid. amount <- choose (5_001, 10_000) let outs = [(recipient, amount)] - tx = mkSimpleGenTx $ Tx ins outs + -- TODO how to integrate expiry into these tests? + tx = mkSimpleGenTx $ Tx DoNotExpire ins outs return $ assert (not (txIsValid ledgerState tx)) tx -- | Apply a transaction to the ledger