Mempool test: generate txs larger than the entire mempool

Author: amesgen

ouroboros-consensus/ouroboros-consensus.cabal

@@ -542,6 +542,7 @@ test-suite consensus-test
     base-deriving-via,
     cardano-binary,
     cardano-crypto-class,
+    cardano-crypto-tests,
     cardano-slotting:{cardano-slotting, testlib},
     cborg,
     containers,

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)
@@ -557,6 +559,23 @@ genInvalidTx ledgerState@(SimpleLedgerState MockState { mockUtxo = utxo }) = do
         tx   = mkSimpleGenTx $ Tx DoNotExpire ins outs
     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
 --
 -- We don't have blocks in this test, but transactions only. In this function
@@ -639,7 +658,24 @@ instance Arbitrary TestSetupWithTxs where
                 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.
+        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 }