From df3c2647755f147186380414e03ad7ca13855e0d 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 | 2 + .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 24 +++-- .../Ouroboros/Consensus/Mock/Ledger/State.hs | 4 +- .../Ouroboros/Consensus/Mock/Ledger/Ticked.hs | 14 +++ .../Ouroboros/Consensus/Mock/Ledger/UTxO.hs | 100 +++++++++++++----- .../test/Test/Consensus/Ledger/Mock.hs | 2 +- .../test/Test/ThreadNet/BFT.hs | 32 +++++- .../test/Test/ThreadNet/LeaderSchedule.hs | 2 + .../test/Test/ThreadNet/PBFT.hs | 2 + .../test/Test/ThreadNet/Praos.hs | 2 + .../test/Test/ThreadNet/TxGen/Mock.hs | 22 +++- .../test/Test/ThreadNet/Util/SimpleBlock.hs | 30 ++++++ .../src/Test/ThreadNet/General.hs | 20 +++- .../src/Test/ThreadNet/Network.hs | 4 +- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../test-consensus/Test/Consensus/Mempool.hs | 14 ++- 18 files changed, 222 insertions(+), 55 deletions(-) create mode 100644 ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Ticked.hs 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 367a7a23396..e2b4cfffe63 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 5f910735c65..c907c580147 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 .&&. prop_pvu .&&. not (all (Chain.null . snd) 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..eced1402838 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal +++ b/ouroboros-consensus/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal @@ -31,6 +31,7 @@ library Ouroboros.Consensus.Mock.Ledger.Forge Ouroboros.Consensus.Mock.Ledger.Stake Ouroboros.Consensus.Mock.Ledger.State + Ouroboros.Consensus.Mock.Ledger.Ticked Ouroboros.Consensus.Mock.Ledger.UTxO Ouroboros.Consensus.Mock.Node Ouroboros.Consensus.Mock.Node.Abstract @@ -84,6 +85,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..4ac19e1c5a7 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 @@ -84,6 +84,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Mock.Ledger.Address import Ouroboros.Consensus.Mock.Ledger.State +import qualified Ouroboros.Consensus.Mock.Ledger.Ticked as Mock import qualified Ouroboros.Consensus.Mock.Ledger.UTxO as Mock import Ouroboros.Consensus.Node.LedgerDerivedInfo import Ouroboros.Consensus.Util ((.:)) @@ -224,13 +225,20 @@ instance Mock.HasUtxo (SimpleBlock' c ext ext') where txIns = Mock.txIns . simpleBody txOuts = Mock.txOuts . simpleBody confirmed = Mock.confirmed . simpleBody - updateUtxo = Mock.updateUtxo . simpleBody + +instance HasHeader (SimpleBlock' c ext ext') + => Mock.UpdUtxo (SimpleBlock' c ext ext') where + updateUtxo blk = + Mock.updateUtxo $ Mock.Ticked (blockSlot blk) (simpleBody blk) instance Mock.HasUtxo SimpleBody where txIns = Mock.txIns . simpleTxs txOuts = Mock.txOuts . simpleTxs confirmed = Mock.confirmed . simpleTxs - updateUtxo = Mock.updateUtxo . simpleTxs + +instance Mock.UpdUtxo (Mock.Ticked SimpleBody) where + updateUtxo (Mock.Ticked slot body) = + Mock.updateUtxo $ map (Mock.Ticked slot) (simpleTxs body) {------------------------------------------------------------------------------- Envelope validation @@ -304,13 +312,14 @@ updateSimpleLedgerState :: (SimpleCrypto c, Typeable ext) updateSimpleLedgerState b (SimpleLedgerState st) = SimpleLedgerState <$> updateMockState b st -updateSimpleUTxO :: Mock.HasUtxo a +updateSimpleUTxO :: Mock.UpdUtxo (Mock.Ticked a) => a -> TickedLedgerState (SimpleBlock c ext) -> Except (MockError (SimpleBlock c ext)) (TickedLedgerState (SimpleBlock c ext)) -updateSimpleUTxO b (TickedLedgerState slot (SimpleLedgerState st)) = - TickedLedgerState slot . SimpleLedgerState <$> updateMockUTxO b st +updateSimpleUTxO tx (TickedLedgerState slot (SimpleLedgerState st)) = + TickedLedgerState slot . SimpleLedgerState <$> + updateMockUTxO (Mock.Ticked slot tx) st genesisSimpleLedgerState :: AddrDist -> LedgerState (SimpleBlock c ext) genesisSimpleLedgerState = SimpleLedgerState . genesisMockState @@ -351,7 +360,10 @@ instance Mock.HasUtxo (GenTx (SimpleBlock p c)) where txIns = Mock.txIns . simpleGenTx txOuts = Mock.txOuts . simpleGenTx confirmed = Mock.confirmed . simpleGenTx - updateUtxo = Mock.updateUtxo . simpleGenTx + +instance Mock.UpdUtxo (Mock.Ticked (GenTx (SimpleBlock p c))) where + updateUtxo (Mock.Ticked slot tx) = + Mock.updateUtxo $ Mock.Ticked slot $ simpleGenTx tx instance Condense (GenTx (SimpleBlock p c)) where condense = condense . simpleGenTx 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..efe54927221 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 @@ -56,7 +56,7 @@ deriving instance Serialise (HeaderHash blk) => Serialise (MockError blk) updateMockState :: ( GetHeader blk , HasHeader (Header blk) , StandardHash blk - , HasUtxo blk + , UpdUtxo blk ) => blk -> MockState blk @@ -75,7 +75,7 @@ updateMockTip hdr (MockState u c t) | otherwise = throwError $ MockInvalidHash (headerPrevHash hdr) (pointHash t) -updateMockUTxO :: HasUtxo a +updateMockUTxO :: UpdUtxo a => a -> MockState blk -> Except (MockError blk) (MockState blk) diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Ticked.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Ticked.hs new file mode 100644 index 00000000000..c5aa2b186ae --- /dev/null +++ b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Ticked.hs @@ -0,0 +1,14 @@ +module Ouroboros.Consensus.Mock.Ledger.Ticked ( + Ticked (..), + ) where + +import Cardano.Slotting.Slot (SlotNo) + +-- | As 'Ouroboros.Consensus.Ledger.Abstract.TickedLedgerState', but +-- generalizing the ledger state field to anything that has time-dependent +-- meaning +-- +data Ticked a = Ticked + { getTick :: !SlotNo + , getTicked :: !a + } 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 f61cf962b73..b8b75af04b4 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 @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} @@ -15,9 +16,11 @@ module Ouroboros.Consensus.Mock.Ledger.UTxO ( , Amount , Ix , Utxo + , Expiry (..) -- * Computing UTxO , UtxoError(..) , HasUtxo(..) + , UpdUtxo(..) -- * Genesis , genesisTx , genesisUtxo @@ -25,6 +28,7 @@ module Ouroboros.Consensus.Mock.Ledger.UTxO ( import Codec.Serialise (Serialise (..)) import Control.DeepSeq (NFData (..), force) +import Control.Monad (guard) import Control.Monad.Except import Control.Monad.State import Data.Functor (($>)) @@ -38,6 +42,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 @@ -45,19 +50,29 @@ import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Mock.Ledger.Address +import Ouroboros.Consensus.Mock.Ledger.Ticked {------------------------------------------------------------------------------- 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 +80,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 @@ -79,7 +94,10 @@ type Utxo = Map TxIn TxOut -------------------------------------------------------------------------------} data UtxoError - = MissingInput TxIn + = Expired !SlotNo !SlotNo + -- ^ The transaction expired in the first 'SlotNo', and it failed to + -- validate in the second 'SlotNo'. + | MissingInput TxIn | InputOutputMismatch Amount -- ^ Input Amount -- ^ Output @@ -93,6 +111,8 @@ class HasUtxo a where txIns :: a -> Set TxIn txOuts :: a -> Utxo confirmed :: a -> Set TxId + +class HasUtxo a => UpdUtxo a where updateUtxo :: a -> Utxo -> Except UtxoError Utxo {------------------------------------------------------------------------------- @@ -100,42 +120,63 @@ 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) aux ix out = ((hash tx, ix), out) confirmed = Set.singleton . hash - updateUtxo tx = execStateT $ do - -- Remove all inputs from the Utxo and calculate the sum of all the input - -- amounts - inputAmount <- fmap sum $ forM (Set.toList (txIns tx)) $ \txIn -> do - u <- get - case Map.updateLookupWithKey (\_ _ -> Nothing) txIn u of - (Nothing, _) -> throwError $ MissingInput txIn - (Just (_addr, amount), u') -> put u' $> amount - - -- Check that the sum of the inputs is equal to the sum of the outputs - let outputAmount = sum $ map snd $ Map.elems $ txOuts tx - when (inputAmount /= outputAmount) $ - throwError $ InputOutputMismatch inputAmount outputAmount - - -- Add the outputs to the Utxo - modify (`Map.union` txOuts tx) + +instance HasUtxo a => HasUtxo (Ticked a) where + txIns = txIns . getTicked + txOuts = txOuts . getTicked + confirmed = confirmed . getTicked + +instance UpdUtxo (Ticked Tx) where + updateUtxo (Ticked now tx) utxo = case hasExpired of + Just e -> throwError e + Nothing -> flip execStateT utxo $ do + -- Remove all inputs from the Utxo and calculate the sum of all the + -- input amounts + inputAmount <- fmap sum $ forM (Set.toList (txIns tx)) $ \txIn -> do + u <- get + case Map.updateLookupWithKey (\_ _ -> Nothing) txIn u of + (Nothing, _) -> throwError $ MissingInput txIn + (Just (_addr, amount), u') -> put u' $> amount + + -- Check that the sum of the inputs is equal to the sum of the + -- outputs + let outputAmount = sum $ map snd $ Map.elems $ txOuts tx + when (inputAmount /= outputAmount) $ + throwError $ InputOutputMismatch inputAmount outputAmount + + -- Add the outputs to the Utxo + modify (`Map.union` txOuts tx) + where + Tx expiry _ins _outs = tx + + hasExpired :: Maybe UtxoError + hasExpired = case expiry of + DoNotExpire -> Nothing + ExpireAtOnsetOf s -> do + guard $ s <= now + Just $ Expired s now + where instance HasUtxo a => HasUtxo [a] where txIns = foldr (Set.union . txIns) Set.empty txOuts = foldr (Map.union . txOuts) Map.empty confirmed = foldr (Set.union . confirmed) Set.empty + +instance UpdUtxo a => UpdUtxo [a] where updateUtxo = repeatedlyM updateUtxo instance HasUtxo a => HasUtxo (Chain a) where - txIns = txIns . toOldestFirst - txOuts = txOuts . toOldestFirst - updateUtxo = updateUtxo . toOldestFirst - confirmed = confirmed . toOldestFirst + txIns = txIns . toOldestFirst + txOuts = txOuts . toOldestFirst + confirmed = confirmed . toOldestFirst {------------------------------------------------------------------------------- Genesis @@ -143,7 +184,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 4d6974092ab..463e8846f0e 100644 --- a/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/BFT.hs +++ b/ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/BFT.hs @@ -4,7 +4,8 @@ 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 @@ -16,7 +17,7 @@ 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 +28,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 +46,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 +85,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 221446e01b1..c043e3e7293 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 ecdf7ad1d88..5a50146548f 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 77ef491367d..e87694d627a 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..b2b4240376e 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 @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.ThreadNet.TxGen.Mock () where @@ -8,6 +9,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 +21,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 +30,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 +43,17 @@ genSimpleTx addrs u = do outs = if amount == fortune then [outRecipient] else [outRecipient, (sender, fortune - amount)] - return $ Tx ins outs + -- generate transactions within several slots in the future or never + mbExpiry <- generateElement $ map mkExpiry $ Nothing : map Just [1 .. 10] + return $ case mbExpiry of + Nothing -> error "impossible!" + Just expiry -> Tx expiry ins outs where + mkExpiry :: Maybe SlotNo -> Expiry + mkExpiry = \case + Nothing -> DoNotExpire + Just 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 0c666b295c5..2a723cdc861 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 slot " <> condense s <> ", node " <> condense nid) $ + counterexample ("forged an invalid 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 75afbc61d57..6787f019c46 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 @@ -1078,9 +1078,9 @@ data NodeOutput blk = NodeOutput { nodeOutputAdds :: Map SlotNo (Set (RealPoint blk, BlockNo)) , nodeOutputFinalChain :: Chain blk , nodeOutputFinalLedger :: LedgerState blk - , nodeOutputNodeDBs :: NodeDBs MockFS , nodeOutputForges :: Map SlotNo blk , nodeOutputInvalids :: Map (RealPoint blk) [ExtValidationError blk] + , nodeOutputNodeDBs :: NodeDBs MockFS } data TestOutput blk = TestOutput @@ -1118,11 +1118,11 @@ mkTestOutput vertexInfos = do [ (s, Set.singleton (p, bno)) | (s, p, bno) <- nodeEventsAdds ] , nodeOutputFinalChain = ch , nodeOutputFinalLedger = ldgr - , nodeOutputNodeDBs = nodeInfoDBs , nodeOutputForges = Map.fromList $ [ (s, b) | TraceForgedBlock s _ b _ <- nodeEventsForges ] , nodeOutputInvalids = (:[]) <$> Map.fromList nodeEventsInvalids + , nodeOutputNodeDBs = nodeInfoDBs } pure diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 4e3fb7267bc..e82495abc70 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -274,6 +274,7 @@ test-suite test-consensus Ouroboros.Consensus.Mock.Ledger.Forge Ouroboros.Consensus.Mock.Ledger.Stake Ouroboros.Consensus.Mock.Ledger.State + Ouroboros.Consensus.Mock.Ledger.Ticked Ouroboros.Consensus.Mock.Ledger.UTxO Ouroboros.Consensus.Mock.Node.Abstract Ouroboros.Consensus.Mock.Protocol.Praos diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/Mempool.hs b/ouroboros-consensus/test-consensus/Test/Consensus/Mempool.hs index 6428c2d1b55..02cd755f6b2 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/Mempool.hs @@ -35,13 +35,14 @@ import Control.Monad.IOSim (runSimOrThrow) import Control.Tracer (Tracer (..)) import Ouroboros.Network.Block (pattern BlockPoint, HeaderHash, - pointSlot) + SlotNo, pointSlot) import Ouroboros.Network.Point (WithOrigin (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Mempool import Ouroboros.Consensus.Mempool.TxSeq as TxSeq import Ouroboros.Consensus.Mock.Ledger hiding (TxId) +import Ouroboros.Consensus.Mock.Ledger.Ticked import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..)) import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Util (repeatedly, repeatedlyM, @@ -467,7 +468,7 @@ genValidTx ledgerState@(SimpleLedgerState MockState { mockUtxo = utxo }) = do = [outRecipient] | otherwise = [outRecipient, (sender, fortune - amount)] - tx = mkSimpleGenTx $ Tx ins outs + tx = mkSimpleGenTx $ Tx DoNotExpire ins outs return (tx, mustBeValid (applyTxToLedger ledgerState tx)) where peopleWithFunds :: Map Addr [(TxIn, Amount)] @@ -487,7 +488,7 @@ 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 + tx = mkSimpleGenTx $ Tx DoNotExpire ins outs return $ assert (not (txIsValid ledgerState tx)) tx -- | Apply a transaction to the ledger @@ -500,8 +501,13 @@ applyTxToLedger :: LedgerState TestBlock -> TestTx -> Except TestTxError (LedgerState TestBlock) applyTxToLedger (SimpleLedgerState mockState) tx = - mkNewLedgerState <$> updateMockUTxO tx mockState + mkNewLedgerState <$> updateMockUTxO (Ticked dummy tx) mockState where + -- All expiries in this test are 'DoNotExpire', so the current time is + -- irrelevant. + dummy :: SlotNo + dummy = 0 + mkNewLedgerState mockState' = SimpleLedgerState mockState' { mockTip = BlockPoint slot' hash' }