Mempool test: generate txs larger than the entire mempool

ouroboros-consensus/changelog.d/20240827_160651_alexander.esgen_test_empty_mempool_nonblocking.md

@@ -0,0 +1,3 @@
+### Non-Breaking
+
+- Added a `Serialise ByteSize32` instance.

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,

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)

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

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
 -------------------------------------------------------------------------------}

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

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)

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)

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)