diff --git a/ouroboros-consensus/changelog.d/20240827_160651_alexander.esgen_test_empty_mempool_nonblocking.md b/ouroboros-consensus/changelog.d/20240827_160651_alexander.esgen_test_empty_mempool_nonblocking.md new file mode 100644 index 0000000000..23b2652749 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20240827_160651_alexander.esgen_test_empty_mempool_nonblocking.md @@ -0,0 +1,3 @@ +### Non-Breaking + +- Added a `Serialise ByteSize32` instance. diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 3af60fe981..cce3ffa020 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -544,6 +544,7 @@ test-suite consensus-test base-deriving-via, cardano-binary, cardano-crypto-class, + cardano-crypto-tests, cardano-slotting:{cardano-slotting, testlib}, cborg, containers, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs index 3a218241f3..605c66bf00 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs @@ -23,6 +23,7 @@ module Ouroboros.Consensus.Ledger.SupportsMempool ( , WhetherToIntervene (..) ) where +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Control.Monad.Except import Data.ByteString.Short (ShortByteString) @@ -246,6 +247,7 @@ newtype ByteSize32 = ByteSize32 { unByteSize32 :: Word32 } deriving stock (Show) deriving newtype (Eq, Ord) deriving newtype (NFData) + deriving newtype (Serialise) deriving (Monoid, Semigroup) via (InstantiatedAt Measure (IgnoringOverflow ByteSize32)) deriving (NoThunks) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index c006b0e6f0..f6db8e90cf 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -49,8 +49,8 @@ module Ouroboros.Consensus.Mock.Ledger.Block ( , GenTx (..) , TxId (..) , Validated (..) + , genTxSize , mkSimpleGenTx - , txSize -- * Crypto , SimpleCrypto , SimpleMockCrypto @@ -95,7 +95,7 @@ import qualified Ouroboros.Consensus.Mock.Ledger.UTxO as Mock import Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..), SizeInBytes) import Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE, - (..:), (.:)) + (..:)) import Ouroboros.Consensus.Util.Condense import Test.Util.Orphans.Serialise () @@ -328,6 +328,8 @@ data SimpleLedgerConfig c ext = SimpleLedgerConfig { -- | Era parameters , simpleLedgerEraParams :: !HardFork.EraParams + + , simpleLedgerMockConfig :: !MockConfig } deriving (Generic) @@ -353,7 +355,7 @@ instance MockProtocolSpecific c ext instance MockProtocolSpecific c ext => ApplyBlock (LedgerState (SimpleBlock c ext)) (SimpleBlock c ext) where - applyBlockLedgerResult _ = fmap pureLedgerResult .: updateSimpleLedgerState + applyBlockLedgerResult = fmap pureLedgerResult ..: updateSimpleLedgerState reapplyBlockLedgerResult = (mustSucceed . runExcept) ..: applyBlockLedgerResult @@ -377,21 +379,27 @@ newtype instance Ticked (LedgerState (SimpleBlock c ext)) = TickedSimpleLedgerSt instance MockProtocolSpecific c ext => UpdateLedger (SimpleBlock c ext) updateSimpleLedgerState :: (SimpleCrypto c, Typeable ext) - => SimpleBlock c ext + => LedgerConfig (SimpleBlock c ext) + -> SimpleBlock c ext -> TickedLedgerState (SimpleBlock c ext) -> Except (MockError (SimpleBlock c ext)) (LedgerState (SimpleBlock c ext)) -updateSimpleLedgerState b (TickedSimpleLedgerState (SimpleLedgerState st)) = - SimpleLedgerState <$> updateMockState b st +updateSimpleLedgerState cfg b (TickedSimpleLedgerState (SimpleLedgerState st)) = + SimpleLedgerState <$> updateMockState mockCfg b st + where + mockCfg = simpleLedgerMockConfig cfg updateSimpleUTxO :: Mock.HasMockTxs a - => SlotNo + => LedgerConfig (SimpleBlock c ext) + -> SlotNo -> a -> TickedLedgerState (SimpleBlock c ext) -> Except (MockError (SimpleBlock c ext)) (TickedLedgerState (SimpleBlock c ext)) -updateSimpleUTxO x slot (TickedSimpleLedgerState (SimpleLedgerState st)) = - TickedSimpleLedgerState . SimpleLedgerState <$> updateMockUTxO x slot st +updateSimpleUTxO cfg x slot (TickedSimpleLedgerState (SimpleLedgerState st)) = + TickedSimpleLedgerState . SimpleLedgerState <$> updateMockUTxO mockCfg x slot st + where + mockCfg = simpleLedgerMockConfig cfg genesisSimpleLedgerState :: AddrDist -> LedgerState (SimpleBlock c ext) genesisSimpleLedgerState = SimpleLedgerState . genesisMockState @@ -427,11 +435,11 @@ type instance ApplyTxErr (SimpleBlock c ext) = MockError (SimpleBlock c ext) instance MockProtocolSpecific c ext => LedgerSupportsMempool (SimpleBlock c ext) where - applyTx _cfg _wti slot tx st = do - st' <- updateSimpleUTxO slot tx st + applyTx cfg _wti slot tx st = do + st' <- updateSimpleUTxO cfg slot tx st return (st', ValidatedSimpleGenTx tx) - reapplyTx _cfg slot vtx st = - updateSimpleUTxO slot (forgetValidatedSimpleGenTx vtx) st + reapplyTx cfg slot vtx st = + updateSimpleUTxO cfg slot (forgetValidatedSimpleGenTx vtx) st txForgetValidated = forgetValidatedSimpleGenTx @@ -443,7 +451,11 @@ instance TxLimits (SimpleBlock c ext) where -- -- But not 'maxbound'!, since the mempool sometimes holds multiple blocks worth. blockCapacityTxMeasure _cfg _st = IgnoringOverflow simpleBlockCapacity - txMeasure _cfg _st = pure . IgnoringOverflow . txSize + + txMeasure cfg _st = + fmap IgnoringOverflow + . checkTxSize (simpleLedgerMockConfig cfg) + . simpleGenTx simpleBlockCapacity :: ByteSize32 simpleBlockCapacity = ByteSize32 512 @@ -490,8 +502,8 @@ mkSimpleGenTx tx = SimpleGenTx , simpleGenTxId = Hash.hashWithSerialiser toCBOR tx } -txSize :: GenTx (SimpleBlock c ext) -> ByteSize32 -txSize = ByteSize32 . fromIntegral . Lazy.length . serialise +genTxSize :: GenTx (SimpleBlock c ext) -> ByteSize32 +genTxSize = txSize . simpleGenTx {------------------------------------------------------------------------------- Support for QueryLedger diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/State.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/State.hs index d4df9871a7..2bbcc377eb 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/State.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/State.hs @@ -1,35 +1,61 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Mock.Ledger.State ( + -- * Config for the mock ledger + MockConfig (..) + , defaultMockConfig -- * State of the mock ledger - MockError (..) + , MockError (..) , MockState (..) , updateMockState , updateMockTip , updateMockUTxO + -- * Supporting definitions + , checkTxSize + , txSize -- * Genesis state , genesisMockState ) where import Cardano.Binary (toCBOR) import Cardano.Crypto.Hash -import Codec.Serialise (Serialise) +import Codec.Serialise (Serialise, serialise) import Control.Monad (guard) import Control.Monad.Except (Except, throwError, withExcept) +import qualified Data.ByteString.Lazy as BL import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32 (..)) import Ouroboros.Consensus.Mock.Ledger.Address import Ouroboros.Consensus.Mock.Ledger.UTxO import Ouroboros.Consensus.Util (ShowProxy (..), repeatedlyM) +import Test.Util.Orphans.Serialise () + +{------------------------------------------------------------------------------- + Config of the mock block +-------------------------------------------------------------------------------} + +-- | Parameters needed to validate blocks/txs +data MockConfig = MockConfig { + mockCfgMaxTxSize :: !(Maybe ByteSize32) + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NoThunks) + +defaultMockConfig :: MockConfig +defaultMockConfig = MockConfig { + mockCfgMaxTxSize = Nothing + } {------------------------------------------------------------------------------- State of the mock ledger @@ -50,6 +76,7 @@ data MockError blk = -- validate in the second 'SlotNo'. | MockUtxoError UtxoError | MockInvalidHash (ChainHash blk) (ChainHash blk) + | MockTxSizeTooBig ByteSize32 ByteSize32 deriving (Generic, NoThunks) deriving instance StandardHash blk => Show (MockError blk) @@ -59,13 +86,14 @@ deriving instance Serialise (HeaderHash blk) => Serialise (MockError blk) instance Typeable blk => ShowProxy (MockError blk) where updateMockState :: (GetPrevHash blk, HasMockTxs blk) - => blk + => MockConfig + -> blk -> MockState blk -> Except (MockError blk) (MockState blk) -updateMockState blk st = do +updateMockState cfg blk st = do let hdr = getHeader blk st' <- updateMockTip hdr st - updateMockUTxO (blockSlot hdr) blk st' + updateMockUTxO cfg (blockSlot hdr) blk st' updateMockTip :: GetPrevHash blk => Header blk @@ -78,20 +106,23 @@ updateMockTip hdr (MockState u c t) = throwError $ MockInvalidHash (headerPrevHash hdr) (pointHash t) updateMockUTxO :: HasMockTxs a - => SlotNo + => MockConfig + -> SlotNo -> a -> MockState blk -> Except (MockError blk) (MockState blk) -updateMockUTxO now = repeatedlyM (updateMockUTxO1 now) . getMockTxs +updateMockUTxO cfg now = repeatedlyM (updateMockUTxO1 cfg now) . getMockTxs updateMockUTxO1 :: forall blk. - SlotNo + MockConfig + -> SlotNo -> Tx -> MockState blk -> Except (MockError blk) (MockState blk) -updateMockUTxO1 now tx (MockState u c t) = case hasExpired of +updateMockUTxO1 cfg now tx (MockState u c t) = case hasExpired of Just e -> throwError e Nothing -> do + _ <- checkTxSize cfg tx u' <- withExcept MockUtxoError $ updateUtxo tx u return $ MockState u' (c `Set.union` confirmed tx) t where @@ -104,6 +135,22 @@ updateMockUTxO1 now tx (MockState u c t) = case hasExpired of guard $ s <= now Just $ MockExpired s now +checkTxSize :: MockConfig -> Tx -> Except (MockError blk) ByteSize32 +checkTxSize cfg tx + | Just maxTxSize <- mockCfgMaxTxSize cfg + , actualTxSize > maxTxSize = + throwError $ MockTxSizeTooBig actualTxSize maxTxSize + | otherwise = pure actualTxSize + where + actualTxSize = txSize tx + +{------------------------------------------------------------------------------- + Supporting definitions +-------------------------------------------------------------------------------} + +txSize :: Tx -> ByteSize32 +txSize = ByteSize32 . fromIntegral . BL.length . serialise + {------------------------------------------------------------------------------- Genesis -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs index 4a83573a33..544a68998b 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs @@ -38,7 +38,7 @@ protocolInfoBft numCoreNodes nid securityParam eraParams = | n <- enumCoreNodes numCoreNodes ] } - , topLevelConfigLedger = SimpleLedgerConfig () eraParams + , topLevelConfigLedger = SimpleLedgerConfig () eraParams defaultMockConfig , topLevelConfigBlock = SimpleBlockConfig , topLevelConfigCodec = SimpleCodecConfig , topLevelConfigStorage = SimpleStorageConfig securityParam diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs index 6e20e13e75..c2b22c8c40 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs @@ -37,7 +37,7 @@ protocolInfoMockPBFT params eraParams = topLevelConfigProtocol = PBftConfig { pbftParams = params } - , topLevelConfigLedger = SimpleLedgerConfig ledgerView eraParams + , topLevelConfigLedger = SimpleLedgerConfig ledgerView eraParams defaultMockConfig , topLevelConfigBlock = SimpleBlockConfig , topLevelConfigCodec = SimpleCodecConfig , topLevelConfigStorage = SimpleStorageConfig (pbftSecurityParam params) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs index 1895000a5a..00d678da6d 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs @@ -48,7 +48,7 @@ protocolInfoPraos numCoreNodes nid params eraParams eta0 evolvingStakeDist = , praosEvolvingStake = evolvingStakeDist , praosVerKeys = verKeys } - , topLevelConfigLedger = SimpleLedgerConfig addrDist eraParams + , topLevelConfigLedger = SimpleLedgerConfig addrDist eraParams defaultMockConfig , topLevelConfigBlock = SimpleBlockConfig , topLevelConfigCodec = SimpleCodecConfig , topLevelConfigStorage = SimpleStorageConfig (praosSecurityParam params) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs index a4a728cc25..3c715b5680 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs @@ -50,7 +50,7 @@ protocolInfoPraosRule numCoreNodes } , wlsConfigNodeId = nid } - , topLevelConfigLedger = SimpleLedgerConfig () eraParams + , topLevelConfigLedger = SimpleLedgerConfig () eraParams defaultMockConfig , topLevelConfigBlock = SimpleBlockConfig , topLevelConfigCodec = SimpleCodecConfig , topLevelConfigStorage = SimpleStorageConfig (praosSecurityParam params) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs index 4c43b15935..a583914def 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs @@ -35,7 +35,7 @@ module Test.Consensus.Mempool (tests) where import Cardano.Binary (Encoding, toCBOR) import Cardano.Crypto.Hash import Control.Exception (assert) -import Control.Monad (foldM, forM, forM_, void) +import Control.Monad (foldM, forM, forM_, guard, void) import Control.Monad.Except (Except, runExcept) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.State (State, evalState, get, modify) @@ -47,6 +47,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import Data.Semigroup (stimes) +import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word32) import GHC.Stack (HasCallStack) @@ -65,6 +66,7 @@ import Ouroboros.Consensus.Util (repeatedly, repeatedlyM, safeMaximumOn, (.:)) import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.IOLike +import Test.Crypto.Hash () import Test.QuickCheck hiding (elements) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -290,6 +292,8 @@ prop_Mempool_TraceRemovedTxs setup = map (const (Right ())) errs === errs .&&. sortOn fst expected === sortOn fst removedTxs where + cfg = testLedgerCfg setup + isRemoveTxsEvent :: TraceEventMempool TestBlock -> Maybe [(TestTx, TestTxError)] isRemoveTxsEvent (TraceMempoolRemoveTxs txs _) = Just (map (first txForgetValidated) txs) isRemoveTxsEvent _ = Nothing @@ -297,7 +301,7 @@ prop_Mempool_TraceRemovedTxs setup = expectedToBeRemoved :: LedgerState TestBlock -> [TestTx] -> [(TestTx, TestTxError)] expectedToBeRemoved ledgerState txsInMempool = [ (tx, err) - | (tx, Left err) <- fst $ validateTxs ledgerState txsInMempool + | (tx, Left err) <- fst $ validateTxs cfg ledgerState txsInMempool ] prjTx :: @@ -323,18 +327,23 @@ testInitLedger = genesisSimpleLedgerState $ mkAddrDist (NumCoreNodes 5) -- | Test config -- --- (We don't really care about these values here) -testLedgerConfig :: LedgerConfig TestBlock -testLedgerConfig = SimpleLedgerConfig { +-- (We don't really care about most of these values here) +mkTestLedgerConfig :: MockConfig -> LedgerConfig TestBlock +mkTestLedgerConfig mockCfg = SimpleLedgerConfig { simpleMockLedgerConfig = () , simpleLedgerEraParams = HardFork.defaultEraParams (SecurityParam 4) (slotLengthFromSec 20) + , simpleLedgerMockConfig = mockCfg } +testLedgerConfigNoSizeLimits :: LedgerConfig TestBlock +testLedgerConfigNoSizeLimits = mkTestLedgerConfig defaultMockConfig + data TestSetup = TestSetup - { testLedgerState :: LedgerState TestBlock + { testLedgerCfg :: LedgerConfig TestBlock + , testLedgerState :: LedgerState TestBlock , testInitialTxs :: [TestTx] -- ^ These are all valid and will be the initial contents of the Mempool. , testMempoolCapOverride :: MempoolCapacityBytesOverride @@ -344,11 +353,11 @@ ppTestSetup :: TestSetup -> String ppTestSetup TestSetup { testInitialTxs , testMempoolCapOverride } = unlines $ - ["Initial contents of the Mempool:"] <> - (map ppTestTxWithHash testInitialTxs) <> - ["Total size:"] <> - [show $ foldMap txSize $ testInitialTxs] <> - ["Mempool capacity override:"] <> + ["Initial contents of the Mempool:"] <> + (map ppTestTxWithHash testInitialTxs) <> + ["Total size:"] <> + [show $ foldMap genTxSize $ testInitialTxs] <> + ["Mempool capacity override:"] <> [show testMempoolCapOverride] ppTestTxWithHash :: TestTx -> String @@ -359,17 +368,18 @@ ppTestTxWithHash x = condense -- the initial transactions. -- -- The generated 'testMempoolCap' will be: --- > foldMap 'txSize' 'testInitialTxs' + extraCapacity +-- > foldMap 'genTxSize' 'testInitialTxs' + extraCapacity genTestSetupWithExtraCapacity :: Int -> ByteSize32 -> Gen (TestSetup, LedgerState TestBlock) genTestSetupWithExtraCapacity maxInitialTxs extraCapacity = do ledgerSize <- choose (0, maxInitialTxs) nbInitialTxs <- choose (0, maxInitialTxs) (_txs1, ledger1) <- genValidTxs ledgerSize testInitLedger ( txs2, ledger2) <- genValidTxs nbInitialTxs ledger1 - let initTxsSizeInBytes = foldMap txSize txs2 + let initTxsSizeInBytes = foldMap genTxSize txs2 mpCap = initTxsSizeInBytes <> extraCapacity testSetup = TestSetup - { testLedgerState = ledger1 + { testLedgerCfg = testLedgerConfigNoSizeLimits + , testLedgerState = ledger1 , testInitialTxs = txs2 , testMempoolCapOverride = MempoolCapacityBytesOverride mpCap } @@ -388,43 +398,47 @@ instance Arbitrary TestSetup where extraCapacity <- (ByteSize32 . fromIntegral) <$> choose (0, n) testSetup <- fst <$> genTestSetupWithExtraCapacity n extraCapacity noOverride <- arbitrary - let initialSize = foldMap txSize $ testInitialTxs testSetup + let initialSize = foldMap genTxSize $ testInitialTxs testSetup defaultCap = simpleBlockCapacity <> simpleBlockCapacity return $ if noOverride && initialSize <= defaultCap then testSetup { testMempoolCapOverride = NoMempoolCapacityBytesOverride } else testSetup - shrink TestSetup { testLedgerState + shrink TestSetup { testLedgerCfg + , testLedgerState , testInitialTxs , testMempoolCapOverride = MempoolCapacityBytesOverride (ByteSize32 mpCap) } = -- TODO we could shrink @testLedgerState@ too - [ TestSetup { testLedgerState + [ TestSetup { testLedgerCfg + , testLedgerState , testInitialTxs = testInitialTxs' , testMempoolCapOverride = MempoolCapacityBytesOverride mpCap' } - | let ByteSize32 initial = foldMap txSize testInitialTxs + | let ByteSize32 initial = foldMap genTxSize testInitialTxs extraCap = mpCap - initial , testInitialTxs' <- shrinkList (const []) testInitialTxs - , isRight $ txsAreValid testLedgerState testInitialTxs' - , let mpCap' = foldMap txSize testInitialTxs' <> ByteSize32 extraCap + , isRight $ txsAreValid testLedgerCfg testLedgerState testInitialTxs' + , let mpCap' = foldMap genTxSize testInitialTxs' <> ByteSize32 extraCap ] -- TODO shrink to an override, that's an easier test case - shrink TestSetup { testLedgerState + shrink TestSetup { testLedgerCfg + , testLedgerState , testInitialTxs , testMempoolCapOverride = NoMempoolCapacityBytesOverride } = -- TODO we could shrink @testLedgerState@ too - [ TestSetup { testLedgerState + [ TestSetup { testLedgerCfg + , testLedgerState , testInitialTxs = testInitialTxs' , testMempoolCapOverride = NoMempoolCapacityBytesOverride } | testInitialTxs' <- shrinkList (const []) testInitialTxs - , isRight $ txsAreValid testLedgerState testInitialTxs' + , isRight $ txsAreValid testLedgerCfg testLedgerState testInitialTxs' ] -- | Generate a number of valid and invalid transactions and apply the valid @@ -455,26 +469,28 @@ mustBeValid ex = case runExcept ex of Left _ -> error "impossible" Right ledger -> ledger -txIsValid :: LedgerState TestBlock -> TestTx -> Bool -txIsValid ledgerState tx = - isRight $ runExcept $ applyTxToLedger ledgerState tx +txIsValid :: LedgerConfig TestBlock -> LedgerState TestBlock -> TestTx -> Bool +txIsValid cfg ledgerState tx = + isRight $ runExcept $ applyTxToLedger cfg ledgerState tx txsAreValid :: - LedgerState TestBlock + LedgerConfig TestBlock + -> LedgerState TestBlock -> [TestTx] -> Either TestTxError (LedgerState TestBlock) -txsAreValid ledgerState txs = - runExcept $ repeatedlyM (flip applyTxToLedger) txs ledgerState +txsAreValid cfg ledgerState txs = + runExcept $ repeatedlyM (flip (applyTxToLedger cfg)) txs ledgerState validateTxs :: - LedgerState TestBlock + LedgerConfig TestBlock + -> LedgerState TestBlock -> [TestTx] -> ([(TestTx, Either TestTxError ())], LedgerState TestBlock) -validateTxs = go [] +validateTxs cfg = go [] where go revalidated ledgerState = \case [] -> (reverse revalidated, ledgerState) - tx:txs' -> case runExcept (applyTxToLedger ledgerState tx) of + tx:txs' -> case runExcept (applyTxToLedger cfg ledgerState tx) of Left err -> go ((tx, Left err):revalidated) ledgerState txs' Right ledgerState' -> go ((tx, Right ()):revalidated) ledgerState' txs' @@ -492,6 +508,8 @@ genValidTxs = go [] (tx, ledger') <- genValidTx ledger go (tx:txs) (n - 1) ledger' +-- | Generate a valid transaction (but ignoring any per-tx size limits, see Note +-- [Transaction size limit]). genValidTx :: LedgerState TestBlock -> Gen (TestTx, LedgerState TestBlock) genValidTx ledgerState@(SimpleLedgerState MockState { mockUtxo = utxo }) = do -- Never let someone go broke, otherwise we risk concentrating all the @@ -520,7 +538,7 @@ genValidTx ledgerState@(SimpleLedgerState MockState { mockUtxo = utxo }) = do | otherwise = [outRecipient, (sender, fortune - amount)] tx = mkSimpleGenTx $ Tx DoNotExpire ins outs - return (tx, mustBeValid (applyTxToLedger ledgerState tx)) + return (tx, mustBeValid (applyTxToLedger testLedgerConfigNoSizeLimits ledgerState tx)) where peopleWithFunds :: Map Addr [(TxIn, Amount)] peopleWithFunds = Map.unionsWith (<>) @@ -540,7 +558,24 @@ genInvalidTx ledgerState@(SimpleLedgerState MockState { mockUtxo = utxo }) = do amount <- choose (5_001, 10_000) let outs = [(recipient, amount)] tx = mkSimpleGenTx $ Tx DoNotExpire ins outs - return $ assert (not (txIsValid ledgerState tx)) tx + return $ assert (not (txIsValid testLedgerConfigNoSizeLimits ledgerState tx)) tx + +-- | Generate an invalid tx that is larger than the given measure. +genLargeInvalidTx :: TheMeasure -> Gen TestTx +genLargeInvalidTx (IgnoringOverflow sz) = go Set.empty + where + go ins = case isLargeTx ins of + Just tx -> pure tx + Nothing -> do + newTxIn <- arbitrary + go (Set.insert newTxIn ins) + + isLargeTx :: Set TxIn -> Maybe TestTx + isLargeTx ins = do + let outs = [] + tx = mkSimpleGenTx $ Tx DoNotExpire ins outs + guard $ genTxSize tx > sz + pure tx -- | Apply a transaction to the ledger -- @@ -548,12 +583,15 @@ genInvalidTx ledgerState@(SimpleLedgerState MockState { mockUtxo = utxo }) = do -- we pretend the transaction /is/ a block, apply it to the UTxO, and then -- update the tip of the ledger state, incrementing the slot number and faking -- a hash. -applyTxToLedger :: LedgerState TestBlock +applyTxToLedger :: LedgerConfig TestBlock + -> LedgerState TestBlock -> TestTx -> Except TestTxError (LedgerState TestBlock) -applyTxToLedger (SimpleLedgerState mockState) tx = - mkNewLedgerState <$> updateMockUTxO dummy tx mockState +applyTxToLedger cfg (SimpleLedgerState mockState) tx = + mkNewLedgerState <$> updateMockUTxO mockCfg dummy tx mockState where + mockCfg = simpleLedgerMockConfig cfg + -- All expiries in this test are 'DoNotExpire', so the current time is -- irrelevant. dummy :: SlotNo @@ -601,6 +639,21 @@ validTxs = map fst . filter snd . txs invalidTxs :: TestSetupWithTxs -> [GenTx TestBlock] invalidTxs = map fst . filter (not . snd) . txs +{- +Note [Transaction size limit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +An important property of the mempool is that adding a transaction that can never +fit into the mempool must not block, also see +https://github.com/IntersectMBO/ouroboros-consensus/issues/1226. We test this +while generating a TestSetupWithTxs by always including a transaction that is +larger than the entire mempool, and setting the per-tx size limit such that just +this transaction is invalid due to its size, but not impacting the validity of +any other transactions. Therefore, we disable the size limit in e.g. +'genValidTx' to only capture UTxO-related validity for them by using an +appropriate ledger config ('testLedgerConfigNoSizeLimits'). +-} + instance Arbitrary TestSetupWithTxs where arbitrary = sized $ \n -> do nbTxs <- choose (0, n) @@ -610,18 +663,39 @@ instance Arbitrary TestSetupWithTxs where NoMempoolCapacityBytesOverride -> return testSetup MempoolCapacityBytesOverride mpCap -> do noOverride <- arbitrary - let initialSize = foldMap txSize $ testInitialTxs testSetup + let initialSize = foldMap genTxSize $ testInitialTxs testSetup defaultCap = simpleBlockCapacity <> simpleBlockCapacity newSize = - foldMap (txSize . fst) (filter snd txs) - <> maximum (ByteSize32 0 : map (txSize . fst) (filter (not . snd) txs)) + foldMap (genTxSize . fst) (filter snd txs) + <> maximum (ByteSize32 0 : map (genTxSize . fst) (filter (not . snd) txs)) return testSetup { testMempoolCapOverride = if noOverride && initialSize <> newSize <= defaultCap then NoMempoolCapacityBytesOverride else MempoolCapacityBytesOverride $ mpCap <> newSize } - return TestSetupWithTxs { testSetup = testSetup', txs } + let mempoolCap :: TheMeasure + mempoolCap = computeMempoolCapacity + testLedgerConfigNoSizeLimits + (TickedSimpleLedgerState ledger) + (testMempoolCapOverride testSetup) + + + largeInvalidTx <- genLargeInvalidTx mempoolCap + let txs' = (largeInvalidTx, False) : txs + -- Set the maximum tx size to the mempool capacity. This won't + -- invalidate any valid tx in @txs@ as the capacity was chosen such that + -- all @txs@ fit into the mempool. Also see Note [Transaction size + -- limit]. + testSetup'' = testSetup' { testLedgerCfg = + (testLedgerCfg testSetup') { simpleLedgerMockConfig = + MockConfig { + mockCfgMaxTxSize = Just (unIgnoringOverflow mempoolCap) + } + } + } + + return TestSetupWithTxs { testSetup = testSetup'', txs = txs' } shrink TestSetupWithTxs { testSetup, txs } = [ TestSetupWithTxs { testSetup = testSetup', txs } @@ -632,12 +706,12 @@ instance Arbitrary TestSetupWithTxs where map fst $ txs ] revalidate :: TestSetup -> [TestTx] -> ([(TestTx, Either TestTxError ())], LedgerState TestBlock) -revalidate TestSetup { testLedgerState, testInitialTxs } = - validateTxs initLedgerState +revalidate TestSetup { testLedgerCfg, testLedgerState, testInitialTxs } = + validateTxs testLedgerCfg initLedgerState where -- The LedgerState after adding the transactions initially in the mempool initLedgerState = repeatedly - (\tx l -> mustBeValid (applyTxToLedger l tx)) + (\tx l -> mustBeValid (applyTxToLedger testLedgerCfg l tx)) testInitialTxs testLedgerState @@ -752,7 +826,7 @@ withTestMempool setup@TestSetup {..} prop = mempool <- openMempoolWithoutSyncThread ledgerInterface - testLedgerConfig + testLedgerCfg testMempoolCapOverride tracer result <- addTxs mempool testInitialTxs @@ -786,7 +860,7 @@ withTestMempool setup@TestSetup {..} prop = -> STM m (Either TestTxError ()) addTxToLedger varCurrentLedgerState tx = do ledgerState <- readTVar varCurrentLedgerState - case runExcept (applyTxToLedger ledgerState tx) of + case runExcept (applyTxToLedger testLedgerCfg ledgerState tx) of Left e -> return $ Left e Right ledgerState' -> do writeTVar varCurrentLedgerState ledgerState' @@ -810,7 +884,7 @@ withTestMempool setup@TestSetup {..} prop = , snapshotSlotNo } = case runExcept $ repeatedlyM - (fmap fst .: applyTx testLedgerConfig DoNotIntervene snapshotSlotNo) + (fmap fst .: applyTx testLedgerCfg DoNotIntervene snapshotSlotNo) txs (TickedSimpleLedgerState ledgerState) of Right _ -> property True @@ -836,12 +910,12 @@ instance Arbitrary MempoolCapTestSetup where testSetupWithTxs@TestSetupWithTxs { testSetup, txs } <- arbitrary -- The Mempool should at least be capable of containing the transactions -- it already contains. - let currentSize = foldMap txSize (testInitialTxs testSetup) + let currentSize = foldMap genTxSize (testInitialTxs testSetup) capacityMinBound = currentSize validTxsToAdd = [tx | (tx, True) <- txs] -- Use the current size + the sum of all the valid transactions to add -- as the upper bound. - capacityMaxBound = currentSize <> foldMap txSize validTxsToAdd + capacityMaxBound = currentSize <> foldMap genTxSize validTxsToAdd -- Note that we could pick @currentSize@, meaning that we can't add any -- more transactions to the Mempool @@ -1037,7 +1111,8 @@ prop_Mempool_idx_consistency (Actions actions) = expectedAssignment = expectedTicketAssignment actions emptyTestSetup = TestSetup - { testLedgerState = testInitLedger + { testLedgerCfg = testLedgerConfigNoSizeLimits + , testLedgerState = testInitLedger , testInitialTxs = [] , testMempoolCapOverride = MempoolCapacityBytesOverride @@ -1154,6 +1229,8 @@ genActions :: -> Gen Actions genActions genNbToAdd = go testInitLedger mempty mempty where + cfg = testLedgerConfigNoSizeLimits + go :: LedgerState TestBlock -- ^ Current ledger state with the contents of the Mempool applied -> [TestTx] -- ^ Transactions currently in the Mempool @@ -1170,7 +1247,7 @@ genActions genNbToAdd = go testInitLedger mempty mempty -> do tx <- elements txs let ((vTxs, iTxs), ledger') = first (partition (isRight . snd)) $ - validateTxs testInitLedger (filter (/= tx) txs) + validateTxs cfg testInitLedger (filter (/= tx) txs) txs' = map fst vTxs removedTxs = tx : map fst iTxs go ledger' txs' (RemoveTxs removedTxs:actions) (n - 1)