From 48ab59d35e52838ac4453aa8fdec3874c1cd74c8 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Thu, 11 Jul 2024 06:18:23 -0700 Subject: [PATCH] consensus: consolidate transaction limits in the mempool Transaction size, block capacity, and mempool capacity are multi-dimensional vectors (incl ExUnits, etc), instead of merely bytes: see `TxMeasure`. `TxLimits` has fittingly been promoted from the `Capacity` module to the proper `SupportsMempool` module, cannibalizing some methds from the `LedgerSupporstMempool` class. A transaction cannot be added if it would push any component of the size over that component's capacity. The capacity override is still only specified in byte size, but the value is interpreted as a block count (rounded up). Enforce block capacity _before_ the forging logic. Now the forging logic simply includes whatever transactions its given, which is reasonable and simpler. It's the NodeKernel logic that uses the mempool's finger tree in order to slice an appropriately-sized prefix, which is then passed to the now-dumb forging function. Explicit attention is given to overflow and the DoS vector of providing an erroneously massive tx that would block the mempool's growth, were it not for the new guards. Also, anachronistically use ConwayMeasure in Babbage, since it should have been counting ref script bytes, as Conway now does. Many comments are improved and also updated for the new scheme. --- .../ouroboros-consensus-cardano.cabal | 1 + .../Ouroboros/Consensus/Byron/Ledger/Forge.hs | 6 +- .../Consensus/Byron/Ledger/Mempool.hs | 53 ++- .../Consensus/Cardano/CanHardFork.hs | 38 +- .../Consensus/Shelley/Ledger/Forge.hs | 35 +- .../Consensus/Shelley/Ledger/Mempool.hs | 415 ++++++++++++++---- .../Ouroboros/Consensus/Shelley/Node.hs | 12 +- .../Consensus/Shelley/Node/Common.hs | 2 +- .../Ouroboros/Consensus/Shelley/Node/Praos.hs | 2 +- .../Consensus/Shelley/Node/TPraos.hs | 4 +- .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 35 +- .../Consensus/ByronSpec/Ledger/Mempool.hs | 10 +- .../ThreadNet/Infra/ShelleyBasedHardFork.hs | 54 ++- .../Cardano/Tools/DBAnalyser/Analysis.hs | 7 +- .../MiniProtocol/LocalTxSubmission/Server.hs | 5 +- .../Test/Consensus/Shelley/Coherence.hs | 18 +- .../Ouroboros/Consensus/NodeKernel.hs | 13 +- .../Test/ThreadNet/Network.hs | 3 +- .../Test/Consensus/HardFork/Combinator.hs | 7 + .../Test/Consensus/HardFork/Combinator/A.hs | 8 +- .../Test/Consensus/HardFork/Combinator/B.hs | 8 +- .../Bench/Consensus/Mempool/TestBlock.hs | 21 +- .../bench/mempool-bench/Main.hs | 12 +- ouroboros-consensus/ouroboros-consensus.cabal | 2 +- .../Ouroboros/Consensus/Block/Forging.hs | 32 +- .../Combinator/Abstract/CanHardFork.hs | 33 +- .../Consensus/HardFork/Combinator/Mempool.hs | 90 +++- .../Ouroboros/Consensus/Ledger/Dual.hs | 16 +- .../Consensus/Ledger/SupportsMempool.hs | 178 ++++++-- .../Ouroboros/Consensus/Mempool.hs | 11 +- .../Ouroboros/Consensus/Mempool/API.hs | 59 ++- .../Ouroboros/Consensus/Mempool/Capacity.hs | 107 ++--- .../Consensus/Mempool/Impl/Common.hs | 98 +++-- .../Ouroboros/Consensus/Mempool/TxSeq.hs | 154 ++++--- .../Ouroboros/Consensus/Mempool/Update.hs | 143 ++++-- .../MiniProtocol/LocalTxMonitor/Server.hs | 26 +- .../Ouroboros/Consensus/TypeFamilyWrappers.hs | 6 +- .../Test/Consensus/Mempool/Mocked.hs | 11 +- .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 20 +- .../consensus-test/Test/Consensus/Mempool.hs | 180 +++++--- .../Test/Consensus/Mempool/Fairness.hs | 22 +- .../Consensus/Mempool/Fairness/TestBlock.hs | 24 +- 42 files changed, 1326 insertions(+), 655 deletions(-) diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index e41b605a46..e7b27a8a75 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -167,6 +167,7 @@ library strict-sop-core ^>=0.1, text, these ^>=1.2, + validation, vector-map, -- GHC 8.10.7 on aarch64-darwin cannot use text-2 diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Forge.hs index 02ea93dbf3..1ebf0c3016 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Forge.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Forge.hs @@ -48,7 +48,7 @@ forgeByronBlock :: -> BlockNo -- ^ Current block number -> SlotNo -- ^ Current slot number -> TickedLedgerState ByronBlock -- ^ Current ledger - -> [Validated (GenTx ByronBlock)] -- ^ Txs to consider adding in the block + -> [Validated (GenTx ByronBlock)] -- ^ Txs to include -> PBftIsLeader PBftByronCrypto -- ^ Leader proof ('IsLeader') -> ByronBlock forgeByronBlock cfg = forgeRegularBlock (configBlock cfg) @@ -123,7 +123,7 @@ forgeRegularBlock :: -> BlockNo -- ^ Current block number -> SlotNo -- ^ Current slot number -> TickedLedgerState ByronBlock -- ^ Current ledger - -> [Validated (GenTx ByronBlock)] -- ^ Txs to consider adding in the block + -> [Validated (GenTx ByronBlock)] -- ^ Txs to include -> PBftIsLeader PBftByronCrypto -- ^ Leader proof ('IsLeader') -> ByronBlock forgeRegularBlock cfg bno sno st txs isLeader = @@ -141,7 +141,7 @@ forgeRegularBlock cfg bno sno st txs isLeader = foldr extendBlockPayloads initBlockPayloads - (takeLargestPrefixThatFits st txs) + txs txPayload :: CC.UTxO.TxPayload txPayload = CC.UTxO.mkTxPayload (bpTxs blockPayloads) diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs index 0b2d41a23b..de2080d645 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs @@ -48,13 +48,13 @@ import Cardano.Ledger.Binary (ByteSpan, DecoderError (..), byronProtVer, fromByronCBOR, serialize, slice, toByronCBOR, unsafeDeserialize) import Cardano.Ledger.Binary.Plain (enforceSize) -import Cardano.Prelude (cborError) +import Cardano.Prelude (Natural, cborError) import Codec.CBOR.Decoding (Decoder) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) import qualified Codec.CBOR.Encoding as CBOR import Control.Monad (void) -import Control.Monad.Except (Except) +import Control.Monad.Except (Except, throwError) import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy @@ -71,19 +71,9 @@ import Ouroboros.Consensus.Byron.Ledger.Serialisation (byronBlockEncodingOverhead) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Mempool import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.Condense -{------------------------------------------------------------------------------- - TxLimits --------------------------------------------------------------------------------} - -instance TxLimits ByronBlock where - type TxMeasure ByronBlock = ByteSize - txMeasure _st = ByteSize . txInBlockSize . txForgetValidated - txsBlockCapacity = ByteSize . txsMaxBytes - {------------------------------------------------------------------------------- Transactions -------------------------------------------------------------------------------} @@ -132,16 +122,39 @@ instance LedgerSupportsMempool ByronBlock where where validationMode = CC.ValidationMode CC.NoBlockValidation Utxo.TxValidationNoCrypto - txsMaxBytes st = - CC.getMaxBlockSize (tickedByronLedgerState st) - byronBlockEncodingOverhead + txForgetValidated = forgetValidatedByronTx - txInBlockSize = - fromIntegral - . Strict.length - . CC.mempoolPayloadRecoverBytes - . toMempoolPayload +instance TxLimits ByronBlock where + type TxMeasure ByronBlock = IgnoringOverflow ByteSize32 - txForgetValidated = forgetValidatedByronTx + blockCapacityTxMeasure _cfg st = + IgnoringOverflow + $ ByteSize32 + $ CC.getMaxBlockSize cvs - byronBlockEncodingOverhead + where + cvs = tickedByronLedgerState st + + txMeasure _cfg st tx = + if txszNat > maxTxSize then throwError err else + pure $ IgnoringOverflow $ ByteSize32 $ fromIntegral txsz + where + maxTxSize = + Update.ppMaxTxSize + $ CC.adoptedProtocolParameters + $ CC.cvsUpdateState + $ tickedByronLedgerState st + + txszNat = fromIntegral txsz :: Natural + + txsz = + Strict.length + $ CC.mempoolPayloadRecoverBytes + $ toMempoolPayload tx + + err = + CC.MempoolTxErr + $ Utxo.UTxOValidationTxValidationError + $ Utxo.TxValidationTxTooLarge txszNat maxTxSize data instance TxId (GenTx ByronBlock) = ByronTxId !Utxo.TxId diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index 800041c0e3..02d06ed28f 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -2,8 +2,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -57,7 +59,7 @@ import Data.Maybe (listToMaybe, mapMaybe) import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.InPairs (RequiringBoth (..), ignoringBoth) -import Data.SOP.Strict (hpure) +import qualified Data.SOP.Strict as SOP import Data.SOP.Tails (Tails (..)) import qualified Data.SOP.Tails as Tails import Data.Void @@ -78,6 +80,8 @@ import Ouroboros.Consensus.HardFork.History (Bound (boundSlot), addSlots) import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32, + IgnoringOverflow, TxMeasure) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Protocol.Abstract @@ -283,6 +287,8 @@ type CardanoHardForkConstraints c = ) instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where + type HardForkTxMeasure (CardanoEras c) = ConwayMeasure + hardForkEraTranslation = EraTranslation { translateLedgerState = PCons translateLedgerStateByronToShelleyWrapper @@ -311,7 +317,7 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where } hardForkChainSel = -- Byron <-> Shelley, ... - TCons (hpure CompareBlockNo) + TCons (SOP.hpure CompareBlockNo) -- Inter-Shelley-based $ Tails.hcpure (Proxy @(HasPraosSelectView c)) CompareSameSelectView hardForkInjectTxs = @@ -349,6 +355,34 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where ) $ PNil + hardForkInjTxMeasure = + fromByteSize `o` + fromByteSize `o` + fromByteSize `o` + fromByteSize `o` + fromAlonzo `o` + fromConway `o` + fromConway `o` + nil + where + nil :: SOP.NS f '[] -> a + nil = \case {} + + infixr `o` + o :: + (TxMeasure x -> a) + -> (SOP.NS WrapTxMeasure xs -> a) + -> SOP.NS WrapTxMeasure (x : xs) + -> a + o f g = \case + SOP.Z (WrapTxMeasure x) -> f x + SOP.S y -> g y + + fromByteSize :: IgnoringOverflow ByteSize32 -> ConwayMeasure + fromByteSize x = fromAlonzo $ AlonzoMeasure x mempty + fromAlonzo x = fromConway $ ConwayMeasure x mempty + fromConway x = x + class (SelectView (BlockProtocol blk) ~ PraosChainSelectView c) => HasPraosSelectView c blk instance (SelectView (BlockProtocol blk) ~ PraosChainSelectView c) => HasPraosSelectView c blk diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index f95a863362..9a309bd413 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -13,14 +12,11 @@ import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx) import qualified Cardano.Ledger.Shelley.BlockChain as SL (bBodySize) import qualified Cardano.Protocol.TPraos.BHeader as SL import Control.Exception -import Control.Monad.Except -import Data.List as List (foldl') import qualified Data.Sequence.Strict as Seq import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Mempool (TxLimits) import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader, IsLeader) import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import Ouroboros.Consensus.Shelley.Eras (EraCrypto) @@ -32,7 +28,6 @@ import Ouroboros.Consensus.Shelley.Ledger.Mempool import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto, ProtocolHeaderSupportsKES (configSlotsPerKESPeriod), mkHeader) -import Ouroboros.Consensus.Util.Assert {------------------------------------------------------------------------------- Forging @@ -40,14 +35,14 @@ import Ouroboros.Consensus.Util.Assert forgeShelleyBlock :: forall m era proto. - (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era), Monad m) + (ShelleyCompatible proto era, Monad m) => HotKey (EraCrypto era) m -> CanBeLeader proto -> TopLevelConfig (ShelleyBlock proto era) -> BlockNo -- ^ Current block number -> SlotNo -- ^ Current slot number -> TickedLedgerState (ShelleyBlock proto era) -- ^ Current ledger - -> [Validated (GenTx (ShelleyBlock proto era))] -- ^ Txs to add in the block + -> [Validated (GenTx (ShelleyBlock proto era))] -- ^ Txs to include -> IsLeader proto -> m (ShelleyBlock proto era) forgeShelleyBlock @@ -64,15 +59,16 @@ forgeShelleyBlock let blk = mkShelleyBlock $ SL.Block hdr body return $ assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus cfg) blk) $ - assertWithMsg bodySizeEstimate blk + blk where protocolVersion = shelleyProtocolVersion $ configBlock cfg body = SL.toTxSeq @era - . Seq.fromList - . fmap extractTx - $ takeLargestPrefixThatFits tickedLedger txs + $ Seq.fromList + $ fmap extractTx txs + + actualBodySize = SL.bBodySize protocolVersion body extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx era extractTx (ShelleyValidatedTx _txid vtx) = SL.extractTx vtx @@ -83,20 +79,3 @@ forgeShelleyBlock . castHash . getTipHash $ tickedLedger - - bodySizeEstimate :: Either String () - bodySizeEstimate - | actualBodySize > estimatedBodySize + fixedBlockBodyOverhead - = throwError $ - "Actual block body size > Estimated block body size + fixedBlockBodyOverhead: " - <> show actualBodySize - <> " > " - <> show estimatedBodySize - <> " + " - <> show (fixedBlockBodyOverhead :: Int) - | otherwise - = return () - - estimatedBodySize, actualBodySize :: Int - estimatedBodySize = fromIntegral $ List.foldl' (+) 0 $ map (txInBlockSize . txForgetValidated) txs - actualBodySize = SL.bBodySize protocolVersion body diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 00c5a47085..4a9005992d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -6,7 +6,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -18,6 +19,9 @@ {-# OPTIONS_GHC -Wno-orphans #-} -- | Shelley mempool integration +-- +-- TODO nearly all of the logic in this module belongs in cardano-ledger, not +-- ouroboros-consensus; ouroboros-consensus-cardano should just be "glue code". module Ouroboros.Consensus.Shelley.Ledger.Mempool ( GenTx (..) , SL.ApplyTxError (..) @@ -34,27 +38,37 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool ( ) where import qualified Cardano.Crypto.Hash as Hash +import qualified Cardano.Ledger.Allegra.Rules as AllegraEra import Cardano.Ledger.Alonzo.Core (Tx, TxSeq, bodyTxL, eraProtVerLow, fromTxSeq, ppMaxBBSizeL, ppMaxBlockExUnitsL, sizeTxF) +import qualified Cardano.Ledger.Alonzo.Rules as AlonzoEra import Cardano.Ledger.Alonzo.Scripts (ExUnits, ExUnits', - unWrapExUnits) + pointWiseExUnits, unWrapExUnits) import Cardano.Ledger.Alonzo.Tx (totExUnits) import qualified Cardano.Ledger.Api as L +import qualified Cardano.Ledger.Babbage.Rules as BabbageEra import Cardano.Ledger.Binary (Annotator (..), DecCBOR (..), EncCBOR (..), FromCBOR (..), FullByteString (..), ToCBOR (..), toPlainDecoder) +import qualified Cardano.Ledger.Conway.Rules as ConwayEra import qualified Cardano.Ledger.Conway.Rules as SL +import qualified Cardano.Ledger.Conway.Tx as SL (tierRefScriptFee) import qualified Cardano.Ledger.Conway.UTxO as SL import qualified Cardano.Ledger.Core as SL (txIdTxBody) import Cardano.Ledger.Crypto (Crypto) import qualified Cardano.Ledger.SafeHash as SL import qualified Cardano.Ledger.Shelley.API as SL -import Control.Monad.Except (Except) +import qualified Cardano.Ledger.Shelley.Rules as ShelleyEra +import qualified Cardano.Ledger.Val as SL (zero, (<+>)) +import Control.Arrow ((+++)) +import Control.Monad (guard) +import Control.Monad.Except (Except, liftEither) import Control.Monad.Identity (Identity (..)) import Data.DerivingVia (InstantiatedAt (..)) import Data.Foldable (toList) import Data.Measure (Measure) import Data.Typeable (Typeable) +import qualified Data.Validation as V import GHC.Generics (Generic) import GHC.Natural (Natural) import Lens.Micro ((^.)) @@ -62,7 +76,6 @@ import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool -import qualified Ouroboros.Consensus.Mempool as Mempool import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger @@ -128,7 +141,7 @@ fixedBlockBodyOverhead = 1024 perTxOverhead :: Num a => a perTxOverhead = 4 -instance ShelleyCompatible proto era +instance (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era)) => LedgerSupportsMempool (ShelleyBlock proto era) where txInvariant = const True @@ -136,17 +149,6 @@ instance ShelleyCompatible proto era reapplyTx = reapplyShelleyTx - txsMaxBytes TickedShelleyLedgerState { tickedShelleyLedgerState = shelleyState } = - - -- `maxBlockBodySize` is expected to be bigger than `fixedBlockBodyOverhead` - maxBlockBodySize - fixedBlockBodyOverhead - where - maxBlockBodySize = getPParams shelleyState ^. ppMaxBBSizeL - - txInBlockSize (ShelleyTx _ tx) = txSize + perTxOverhead - where - txSize = fromIntegral $ tx ^. sizeTxF - txForgetValidated (ShelleyValidatedTx txid vtx) = ShelleyTx txid (SL.extractTx vtx) mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era) @@ -288,101 +290,352 @@ theLedgerLens f x = Tx Limits -------------------------------------------------------------------------------} -instance ShelleyCompatible p (ShelleyEra c) => Mempool.TxLimits (ShelleyBlock p (ShelleyEra c)) where - type TxMeasure (ShelleyBlock p (ShelleyEra c)) = Mempool.ByteSize - txMeasure _st = Mempool.ByteSize . txInBlockSize . txForgetValidated - txsBlockCapacity = Mempool.ByteSize . txsMaxBytes - -instance ShelleyCompatible p (AllegraEra c) => Mempool.TxLimits (ShelleyBlock p (AllegraEra c)) where - type TxMeasure (ShelleyBlock p (AllegraEra c)) = Mempool.ByteSize - txMeasure _st = Mempool.ByteSize . txInBlockSize . txForgetValidated - txsBlockCapacity = Mempool.ByteSize . txsMaxBytes - -instance ShelleyCompatible p (MaryEra c) => Mempool.TxLimits (ShelleyBlock p (MaryEra c)) where - type TxMeasure (ShelleyBlock p (MaryEra c)) = Mempool.ByteSize - txMeasure _st = Mempool.ByteSize . txInBlockSize . txForgetValidated - txsBlockCapacity = Mempool.ByteSize . txsMaxBytes - -instance ( ShelleyCompatible p (AlonzoEra c) - ) => Mempool.TxLimits (ShelleyBlock p (AlonzoEra c)) where - - type TxMeasure (ShelleyBlock p (AlonzoEra c)) = AlonzoMeasure - - txMeasure _st = txMeasureAlonzo +-- | A non-exported newtype wrapper just to give a 'Semigroup' instance +newtype TxErrorSG era = TxErrorSG { unTxErrorSG :: SL.ApplyTxError era } + +instance Semigroup (TxErrorSG era) where + TxErrorSG (SL.ApplyTxError x) <> TxErrorSG (SL.ApplyTxError y) = + TxErrorSG (SL.ApplyTxError (x <> y)) + +validateMaybe :: + SL.ApplyTxError era + -> Maybe a + -> V.Validation (TxErrorSG era) a +validateMaybe err mb = V.validate (TxErrorSG err) id mb + +validateGuard :: + SL.ApplyTxError era + -> Bool + -> V.Validation (TxErrorSG era) () +validateGuard err b = validateMaybe err $ guard b + +runValidation :: + V.Validation (TxErrorSG era) a + -> Except (SL.ApplyTxError era) a +runValidation = liftEither . (unTxErrorSG +++ id) . V.toEither + +----- + +txsMaxBytes :: + ShelleyCompatible proto era + => TickedLedgerState (ShelleyBlock proto era) + -> IgnoringOverflow ByteSize32 +txsMaxBytes TickedShelleyLedgerState { tickedShelleyLedgerState } = + -- `maxBlockBodySize` is expected to be bigger than `fixedBlockBodyOverhead` + IgnoringOverflow + $ ByteSize32 + $ maxBlockBodySize - fixedBlockBodyOverhead + where + maxBlockBodySize = getPParams tickedShelleyLedgerState ^. ppMaxBBSizeL - txsBlockCapacity = txsBlockCapacityAlonzo +txInBlockSize :: + (ShelleyCompatible proto era, MaxTxSizeUTxO era) + => TickedLedgerState (ShelleyBlock proto era) + -> GenTx (ShelleyBlock proto era) + -> V.Validation (TxErrorSG era) (IgnoringOverflow ByteSize32) +txInBlockSize st (ShelleyTx _txid tx') = + validateMaybe (maxTxSizeUTxO txsz limit) $ do + guard $ txsz <= limit + Just $ IgnoringOverflow $ ByteSize32 $ fromIntegral txsz + where + txsz = perTxOverhead + (tx' ^. sizeTxF) + + pparams = getPParams $ tickedShelleyLedgerState st + limit = fromIntegral (pparams ^. L.ppMaxTxSizeL) :: Integer + +class MaxTxSizeUTxO era where + maxTxSizeUTxO :: Integer -> Integer -> SL.ApplyTxError era + +instance MaxTxSizeUTxO (ShelleyEra c) where + maxTxSizeUTxO x y = + SL.ApplyTxError . pure + $ ShelleyEra.UtxowFailure + $ ShelleyEra.UtxoFailure + $ ShelleyEra.MaxTxSizeUTxO x y + +instance MaxTxSizeUTxO (AllegraEra c) where + maxTxSizeUTxO x y = + SL.ApplyTxError . pure + $ ShelleyEra.UtxowFailure + $ ShelleyEra.UtxoFailure + $ AllegraEra.MaxTxSizeUTxO x y + +instance MaxTxSizeUTxO (MaryEra c) where + maxTxSizeUTxO x y = + SL.ApplyTxError . pure + $ ShelleyEra.UtxowFailure + $ ShelleyEra.UtxoFailure + $ AllegraEra.MaxTxSizeUTxO x y + +instance MaxTxSizeUTxO (AlonzoEra c) where + maxTxSizeUTxO x y = + SL.ApplyTxError . pure + $ ShelleyEra.UtxowFailure + $ AlonzoEra.ShelleyInAlonzoUtxowPredFailure + $ ShelleyEra.UtxoFailure + $ AlonzoEra.MaxTxSizeUTxO x y + +instance MaxTxSizeUTxO (BabbageEra c) where + maxTxSizeUTxO x y = + SL.ApplyTxError . pure + $ ShelleyEra.UtxowFailure + $ BabbageEra.UtxoFailure + $ BabbageEra.AlonzoInBabbageUtxoPredFailure + $ AlonzoEra.MaxTxSizeUTxO x y + +instance MaxTxSizeUTxO (ConwayEra c) where + maxTxSizeUTxO x y = + SL.ApplyTxError . pure + $ ConwayEra.ConwayUtxowFailure + $ ConwayEra.UtxoFailure + $ ConwayEra.MaxTxSizeUTxO x y + +----- + +instance ShelleyCompatible p (ShelleyEra c) => TxLimits (ShelleyBlock p (ShelleyEra c)) where + type TxMeasure (ShelleyBlock p (ShelleyEra c)) = IgnoringOverflow ByteSize32 + txMeasure _cfg st tx = runValidation $ txInBlockSize st tx + blockCapacityTxMeasure _cfg = txsMaxBytes + +instance ShelleyCompatible p (AllegraEra c) => TxLimits (ShelleyBlock p (AllegraEra c)) where + type TxMeasure (ShelleyBlock p (AllegraEra c)) = IgnoringOverflow ByteSize32 + txMeasure _cfg st tx = runValidation $ txInBlockSize st tx + blockCapacityTxMeasure _cfg = txsMaxBytes + +instance ShelleyCompatible p (MaryEra c) => TxLimits (ShelleyBlock p (MaryEra c)) where + type TxMeasure (ShelleyBlock p (MaryEra c)) = IgnoringOverflow ByteSize32 + txMeasure _cfg st tx = runValidation $ txInBlockSize st tx + blockCapacityTxMeasure _cfg = txsMaxBytes + +----- data AlonzoMeasure = AlonzoMeasure { - byteSize :: !Mempool.ByteSize + byteSize :: !(IgnoringOverflow ByteSize32) , exUnits :: !(ExUnits' Natural) } deriving stock (Eq, Generic, Show) + deriving anyclass (NoThunks) deriving (Measure) via (InstantiatedAt Generic AlonzoMeasure) --- | This function used to do more, but now it's merely a synonym that avoids --- more import statements in modules that import this one. +instance HasByteSize AlonzoMeasure where + txMeasureByteSize = unIgnoringOverflow . byteSize + fromExUnits :: ExUnits -> ExUnits' Natural fromExUnits = unWrapExUnits -txMeasureAlonzo :: - forall proto era. - (ShelleyCompatible proto era, L.AlonzoEraTxWits era) - => Validated (GenTx (ShelleyBlock proto era)) -> AlonzoMeasure -txMeasureAlonzo (ShelleyValidatedTx _txid vtx) = - AlonzoMeasure { - byteSize = Mempool.ByteSize $ txInBlockSize (mkShelleyTx @era @proto tx) - , exUnits = fromExUnits $ totExUnits tx - } - where - tx = SL.extractTx vtx - -txsBlockCapacityAlonzo :: +blockCapacityAlonzoMeasure :: forall proto era. (ShelleyCompatible proto era, L.AlonzoEraPParams era) - => TickedLedgerState (ShelleyBlock proto era) -> AlonzoMeasure -txsBlockCapacityAlonzo ledgerState = + => TickedLedgerState (ShelleyBlock proto era) + -> AlonzoMeasure +blockCapacityAlonzoMeasure ledgerState = AlonzoMeasure { - byteSize = Mempool.ByteSize $ txsMaxBytes ledgerState + byteSize = txsMaxBytes ledgerState , exUnits = fromExUnits $ pparams ^. ppMaxBlockExUnitsL } where pparams = getPParams $ tickedShelleyLedgerState ledgerState -instance ( ShelleyCompatible p (BabbageEra c) - ) => Mempool.TxLimits (ShelleyBlock p (BabbageEra c)) where +txMeasureAlonzo :: + forall proto era. + ( ShelleyCompatible proto era + , L.AlonzoEraPParams era + , L.AlonzoEraTxWits era + , ExUnitsTooBigUTxO era + , MaxTxSizeUTxO era + ) + => TickedLedgerState (ShelleyBlock proto era) + -> GenTx (ShelleyBlock proto era) + -> V.Validation (TxErrorSG era) AlonzoMeasure +txMeasureAlonzo st tx@(ShelleyTx _txid tx') = + AlonzoMeasure <$> txInBlockSize st tx <*> exunits + where + txsz = totExUnits tx' + + pparams = getPParams $ tickedShelleyLedgerState st + limit = pparams ^. L.ppMaxTxExUnitsL + + exunits = + validateMaybe (exUnitsTooBigUTxO limit txsz) $ do + guard $ pointWiseExUnits (<=) txsz limit + Just $ fromExUnits txsz + +class ExUnitsTooBigUTxO era where + exUnitsTooBigUTxO :: ExUnits -> ExUnits -> SL.ApplyTxError era + +instance Crypto c => ExUnitsTooBigUTxO (AlonzoEra c) where + exUnitsTooBigUTxO x y = + SL.ApplyTxError . pure + $ ShelleyEra.UtxowFailure + $ AlonzoEra.ShelleyInAlonzoUtxowPredFailure + $ ShelleyEra.UtxoFailure + $ AlonzoEra.ExUnitsTooBigUTxO x y + +instance Crypto c => ExUnitsTooBigUTxO (BabbageEra c) where + exUnitsTooBigUTxO x y = + SL.ApplyTxError . pure + $ ShelleyEra.UtxowFailure + $ BabbageEra.AlonzoInBabbageUtxowPredFailure + $ AlonzoEra.ShelleyInAlonzoUtxowPredFailure + $ ShelleyEra.UtxoFailure + $ BabbageEra.AlonzoInBabbageUtxoPredFailure + $ AlonzoEra.ExUnitsTooBigUTxO x y + +instance Crypto c => ExUnitsTooBigUTxO (ConwayEra c) where + exUnitsTooBigUTxO x y = + SL.ApplyTxError . pure + $ ConwayEra.ConwayUtxowFailure + $ ConwayEra.UtxoFailure + $ ConwayEra.ExUnitsTooBigUTxO x y + +----- - type TxMeasure (ShelleyBlock p (BabbageEra c)) = AlonzoMeasure +instance ( ShelleyCompatible p (AlonzoEra c) + ) => TxLimits (ShelleyBlock p (AlonzoEra c)) where - txMeasure _st = txMeasureAlonzo + type TxMeasure (ShelleyBlock p (AlonzoEra c)) = AlonzoMeasure + txMeasure _cfg st tx = runValidation $ txMeasureAlonzo st tx + blockCapacityTxMeasure _cfg = blockCapacityAlonzoMeasure - txsBlockCapacity = txsBlockCapacityAlonzo +----- data ConwayMeasure = ConwayMeasure { alonzoMeasure :: !AlonzoMeasure - , refScriptsSize :: !Mempool.ByteSize + , refScriptsSize :: !(IgnoringOverflow ByteSize32) } deriving stock (Eq, Generic, Show) + deriving anyclass (NoThunks) deriving (Measure) via (InstantiatedAt Generic ConwayMeasure) -instance ( ShelleyCompatible p (ConwayEra c) - ) => Mempool.TxLimits (ShelleyBlock p (ConwayEra c)) where +instance HasByteSize ConwayMeasure where + txMeasureByteSize = txMeasureByteSize . alonzoMeasure - type TxMeasure (ShelleyBlock p (ConwayEra c)) = ConwayMeasure +blockCapacityConwayMeasure :: + forall proto era. + ( ShelleyCompatible proto era + , L.AlonzoEraPParams era + ) + => TickedLedgerState (ShelleyBlock proto era) + -> ConwayMeasure +blockCapacityConwayMeasure st = + ConwayMeasure { + alonzoMeasure = blockCapacityAlonzoMeasure st + , refScriptsSize = IgnoringOverflow $ ByteSize32 $ fromIntegral $ + -- For post-Conway eras, this will become a protocol parameter. + SL.maxRefScriptSizePerBlock + } - txMeasure st genTx@(ShelleyValidatedTx _txid vtx) = - ConwayMeasure { - alonzoMeasure = txMeasureAlonzo genTx - , refScriptsSize = Mempool.ByteSize $ fromIntegral $ - SL.txNonDistinctRefScriptsSize utxo (SL.extractTx vtx) - } - where - utxo = SL.getUTxO . tickedShelleyLedgerState $ st +txMeasureConway :: + forall proto era. + ( ShelleyCompatible proto era + , L.AlonzoEraTxWits era + , L.BabbageEraTxBody era + , ExUnitsTooBigUTxO era + , MaxTxSizeUTxO era + , TxRefScriptsSizeTooBig era + ) + => TickedLedgerState (ShelleyBlock proto era) + -> GenTx (ShelleyBlock proto era) + -> V.Validation (TxErrorSG era) ConwayMeasure +txMeasureConway st tx@(ShelleyTx _txid tx') = + ConwayMeasure <$> txMeasureAlonzo st tx <*> refScriptBytes + where + utxo = SL.getUTxO . tickedShelleyLedgerState $ st + txsz = SL.txNonDistinctRefScriptsSize utxo tx' :: Int + + -- For post-Conway eras, this will become a protocol parameter. + limit = SL.maxRefScriptSizePerTx + refScriptBytes = + validateMaybe (txRefScriptsSizeTooBig limit txsz) $ do + guard $ txsz <= limit + Just $ IgnoringOverflow $ ByteSize32 $ fromIntegral txsz - txsBlockCapacity st = - ConwayMeasure { - alonzoMeasure = txsBlockCapacityAlonzo st - , refScriptsSize = Mempool.ByteSize $ fromIntegral $ - -- For post-Conway eras, this will become a protocol parameter. - SL.maxRefScriptSizePerBlock - } +class TxRefScriptsSizeTooBig era where + txRefScriptsSizeTooBig :: Int -> Int -> SL.ApplyTxError era + +instance Crypto c => TxRefScriptsSizeTooBig (ConwayEra c) where + txRefScriptsSizeTooBig x y = + SL.ApplyTxError . pure + $ ConwayEra.ConwayTxRefScriptsSizeTooBig x y + +----- + +txMeasureBabbage :: + forall proto era. + ( ShelleyCompatible proto era + , L.AlonzoEraTxWits era + , L.BabbageEraTxBody era + , ExUnitsTooBigUTxO era + , MaxTxSizeUTxO era + ) + => TickedLedgerState (ShelleyBlock proto era) + -> GenTx (ShelleyBlock proto era) + -> V.Validation (TxErrorSG era) ConwayMeasure +txMeasureBabbage st tx@(ShelleyTx _txid tx') = + ConwayMeasure <$> txMeasureAlonzo st tx <*> refScriptBytes + where + utxo = SL.getUTxO $ tickedShelleyLedgerState st + txsz = SL.txNonDistinctRefScriptsSize utxo tx' :: Int + + -- TODO recall the assertion in this module header that this logic should + -- be owned by Ledger, not by Consensus: Ledger prefers to delete these + -- checks after mainnet hard forks to Conway, rather than introduce the + -- necessary 'SL.PredicateFailure' constructors for Babbage (which would in + -- turn require a bump to "Ouroboros.Network.NodeToNode.Version" and + -- "Ouroboros.Network.NodeToClient.Version") + -- + -- -- Babbage should have enforced a per-tx limit here, but did not. + -- refScriptBytes = pure $ ByteSize $ fromIntegral txsz + refScriptBytes :: + V.Validation (TxErrorSG era) (IgnoringOverflow ByteSize32) + refScriptBytes = + (IgnoringOverflow $ ByteSize32 $ fromIntegral txsz) + -- Reject it if it has more than 100 kibibytes of ref script. + <$ validateGuard + (err 1_000_000 (fromIntegral txsz) (fromIntegral limit)) + (txsz <= limit) + -- Reject it if it has more than 50 kibibytes of ref script and does + -- not satisfy an additional fee of 'SL.tierRefScriptFee'. + -- + -- TODO this additional fee check in particular doesn't truly belong + -- in 'txMeasure' (which only needs to enforce per-tx limits); + -- however, it's less confusing and less duplication to put it here + -- rather than + -- 'Ouroboros.Consensus.Shelley.Eras.defaultApplyShelleyBasedTx' + <* validateGuard + (err 100_000 (SL.unCoin fee) (SL.unCoin reqFee)) + (reqFee <= fee) + where + limit = 100 * 1024 + + fee = tx' ^. L.bodyTxL . L.feeTxBodyL :: SL.Coin + + reqFee :: SL.Coin + reqFee = if txsz <= 50 * 1024 then SL.zero else minFee SL.<+> addlFee + + pparams = getPParams $ tickedShelleyLedgerState st + minFee = L.getMinFeeTx pparams tx' 0 + addlFee = SL.tierRefScriptFee 1.2 25600 15 txsz + + -- As we are reusing an existing error message, we add a large number + -- to ensure users running into this are productively irritated and + -- post this error message somewhere where they can receive + -- help/context. + err :: Integer -> Integer -> Integer -> SL.ApplyTxError era + err shift l r = maxTxSizeUTxO (l + shift) (r + shift) + +-- | We anachronistically use 'ConwayMeasure' in Babbage. +instance ( ShelleyCompatible p (BabbageEra c) + ) => TxLimits (ShelleyBlock p (BabbageEra c)) where + + type TxMeasure (ShelleyBlock p (BabbageEra c)) = ConwayMeasure + txMeasure _cfg st tx = runValidation $ txMeasureBabbage st tx + blockCapacityTxMeasure _cfg = blockCapacityConwayMeasure + +instance ( ShelleyCompatible p (ConwayEra c) + ) => TxLimits (ShelleyBlock p (ConwayEra c)) where + + type TxMeasure (ShelleyBlock p (ConwayEra c)) = ConwayMeasure + txMeasure _cfg st tx = runValidation $ txMeasureConway st tx + blockCapacityTxMeasure _cfg = blockCapacityConwayMeasure diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs index b0b9349bea..ff9da0b3d2 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs @@ -32,6 +32,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Node.ProtocolInfo @@ -107,8 +108,9 @@ instance ShelleyCompatible proto era => BlockSupportsMetrics (ShelleyBlock proto instance ConsensusProtocol proto => BlockSupportsSanityCheck (ShelleyBlock proto era) where configAllSecurityParams = pure . protocolSecurityParam . topLevelConfigProtocol -instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - , BlockSupportsSanityCheck (ShelleyBlock proto era) - ) => RunNode (ShelleyBlock proto era) +instance ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) + , BlockSupportsSanityCheck (ShelleyBlock proto era) + , TxLimits (ShelleyBlock proto era) + ) + => RunNode (ShelleyBlock proto era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs index a176ecc256..913f86b396 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs @@ -28,7 +28,7 @@ import Ouroboros.Consensus.Block (CannotForge, ForgeStateInfo, ForgeStateUpdateError) import Ouroboros.Consensus.Config (maxRollbacks) import Ouroboros.Consensus.Config.SupportsNode -import Ouroboros.Consensus.Mempool (TxLimits) +import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Node.InitStorage import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos.Common diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index b388395280..287281410c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -24,7 +24,7 @@ import qualified Cardano.Protocol.TPraos.OCert as SL import qualified Data.Text as T import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (configConsensus) -import qualified Ouroboros.Consensus.Mempool as Mempool +import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Mempool import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..), praosCheckCanForge) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index d6ed3ab460..401019a279 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -52,7 +52,7 @@ import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Mempool (TxLimits) +import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) @@ -121,7 +121,7 @@ shelleySharedBlockForging :: => HotKey c m -> (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c - -> BlockForging m (ShelleyBlock (TPraos c) era) + -> BlockForging m (ShelleyBlock (TPraos c) era) shelleySharedBlockForging hotKey slotToPeriod credentials = BlockForging { forgeLabel = label <> "_" <> T.pack (L.eraName @era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 1d6e1334f9..90bcda4454 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -52,6 +52,7 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.History (Bound (boundSlot)) import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol, ledgerViewForecastAt) import Ouroboros.Consensus.Node.NetworkProtocolVersion @@ -75,10 +76,10 @@ type ShelleyBlockHFC proto era = HardForkBlock '[ShelleyBlock proto era] NoHardForks instance -------------------------------------------------------------------------------} -instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - ) => NoHardForks (ShelleyBlock proto era) where +instance ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) + , TxLimits (ShelleyBlock proto era) + ) => NoHardForks (ShelleyBlock proto era) where getEraParams = shelleyEraParamsNeverHardForks . shelleyLedgerGenesis @@ -95,8 +96,10 @@ instance -- | Forward to the ShelleyBlock instance. Only supports -- 'HardForkNodeToNodeDisabled', which is compatible with nodes running with -- 'ShelleyBlock'. -instance (ShelleyCompatible proto era, LedgerSupportsProtocol (ShelleyBlock proto era)) - => SupportedNetworkProtocolVersion (ShelleyBlockHFC proto era) where +instance ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) + , TxLimits (ShelleyBlock proto era) + ) => SupportedNetworkProtocolVersion (ShelleyBlockHFC proto era) where supportedNodeToNodeVersions _ = Map.map HardForkNodeToNodeDisabled $ supportedNodeToNodeVersions (Proxy @(ShelleyBlock proto era)) @@ -114,10 +117,14 @@ instance (ShelleyCompatible proto era, LedgerSupportsProtocol (ShelleyBlock prot -- | Use the default implementations. This means the serialisation of blocks -- includes an era wrapper. Each block should do this from the start to be -- prepared for future hard forks without having to do any bit twiddling. -instance (ShelleyCompatible proto era, LedgerSupportsProtocol (ShelleyBlock proto era)) - => SerialiseHFC '[ShelleyBlock proto era] -instance (ShelleyCompatible proto era, LedgerSupportsProtocol (ShelleyBlock proto era)) - => SerialiseConstraintsHFC (ShelleyBlock proto era) +instance ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) + , TxLimits (ShelleyBlock proto era) + ) => SerialiseHFC '[ShelleyBlock proto era] +instance ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) + , TxLimits (ShelleyBlock proto era) + ) => SerialiseConstraintsHFC (ShelleyBlock proto era) {------------------------------------------------------------------------------- Protocol type definition @@ -161,10 +168,10 @@ shelleyTransition ShelleyPartialLedgerConfig{..} guard $ shelleyAfterVoting >= fromIntegral k return newPParamsEpochNo -instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - ) => SingleEraBlock (ShelleyBlock proto era) where +instance ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) + , TxLimits (ShelleyBlock proto era) + ) => SingleEraBlock (ShelleyBlock proto era) where singleEraTransition pcfg _eraParams _eraStart ledgerState = -- TODO: We might be evaluating 'singleEraTransition' more than once when -- replaying blocks. We should investigate if this is the case, and if so, diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs index 0116a98fb0..4420e3b538 100644 --- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs @@ -51,8 +51,12 @@ instance LedgerSupportsMempool ByronSpecBlock where fmap fst $ applyTx cfg DoNotIntervene slot (forgetValidatedByronSpecGenTx vtx) st + txForgetValidated = forgetValidatedByronSpecGenTx + +instance TxLimits ByronSpecBlock where + type TxMeasure ByronSpecBlock = IgnoringOverflow ByteSize32 + -- Dummy values, as these are not used in practice. - txsMaxBytes = const maxBound - txInBlockSize = const 0 + blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 1 - txForgetValidated = forgetValidatedByronSpecGenTx + txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index 02a8586cf8..161cd25941 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -47,9 +49,9 @@ import Ouroboros.Consensus.HardFork.Combinator.Serialisation import qualified Ouroboros.Consensus.HardFork.Combinator.State.Types as HFC import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Basics (LedgerConfig) +import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -import Ouroboros.Consensus.Mempool (TxLimits) import Ouroboros.Consensus.Node import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Protocol.TPraos @@ -123,6 +125,7 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = , LedgerSupportsProtocol (ShelleyBlock proto2 era2) , TxLimits (ShelleyBlock proto1 era1) , TxLimits (ShelleyBlock proto2 era2) + , TranslateTxMeasure (TxMeasure (ShelleyBlock proto1 era1)) (TxMeasure (ShelleyBlock proto2 era2)) , SL.PreviousEra era2 ~ era1 , SL.TranslateEra era2 SL.NewEpochState @@ -137,12 +140,37 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = , proto1 ~ proto2 ) +class TranslateTxMeasure a b where + translateTxMeasure :: a -> b + +instance TranslateTxMeasure (IgnoringOverflow ByteSize32) (IgnoringOverflow ByteSize32) where + translateTxMeasure = id + +instance TranslateTxMeasure (IgnoringOverflow ByteSize32) AlonzoMeasure where + translateTxMeasure x = AlonzoMeasure x mempty + +instance TranslateTxMeasure (IgnoringOverflow ByteSize32) ConwayMeasure where + translateTxMeasure = + translateTxMeasure . (\x -> x :: AlonzoMeasure) . translateTxMeasure + +instance TranslateTxMeasure AlonzoMeasure AlonzoMeasure where + translateTxMeasure = id + +instance TranslateTxMeasure AlonzoMeasure ConwayMeasure where + translateTxMeasure x = ConwayMeasure x mempty + +instance TranslateTxMeasure ConwayMeasure ConwayMeasure where + translateTxMeasure = id + instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 => SerialiseHFC (ShelleyBasedHardForkEras proto1 era1 proto2 era2) -- use defaults instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 => CanHardFork (ShelleyBasedHardForkEras proto1 era1 proto2 era2) where + type HardForkTxMeasure (ShelleyBasedHardForkEras proto1 era1 proto2 era2) = + TxMeasure (ShelleyBlock proto2 era2) + hardForkEraTranslation = EraTranslation { translateLedgerState = PCons translateLedgerState PNil , translateChainDepState = PCons translateChainDepStateAcrossShelley PNil @@ -203,6 +231,10 @@ instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 . eitherToMaybe . runExcept . SL.translateEra transCtxt . Comp + hardForkInjTxMeasure = \case + ( Z (WrapTxMeasure x)) -> translateTxMeasure x + S (Z (WrapTxMeasure x)) -> x + instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 => SupportedNetworkProtocolVersion (ShelleyBasedHardForkBlock proto1 era1 proto2 era2) where supportedNodeToNodeVersions _ = Map.fromList $ diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 2715257167..2e874be58d 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -740,8 +740,11 @@ reproMempoolForge numBlks env = do Mempool.getCurrentLedgerState = ledgerState <$> IOLike.readTVar ref } lCfg - -- one megabyte should generously accomodate two blocks' worth of txs - (Mempool.MempoolCapacityBytesOverride $ Mempool.MempoolCapacityBytes $ 2^(20 :: Int)) + -- one mebibyte should generously accomodate two blocks' worth of txs + ( Mempool.MempoolCapacityBytesOverride + $ LedgerSupportsMempool.ByteSize32 + $ 1024*1024 + ) nullTracer void $ processAll db registry GetBlock startFrom limit Nothing (process howManyBlocks ref mempool) diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs index a6e344ea78..0aadb8d1c1 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs @@ -19,6 +19,7 @@ import qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.HardFork.Combinator (getHardForkState, hardForkLedgerStatePerEra) import Ouroboros.Consensus.Ledger.Extended (ledgerState) +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32 (..)) import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Ledger import qualified Ouroboros.Consensus.Ledger.SupportsMempool as LedgerSupportsMempool import qualified Ouroboros.Consensus.Mempool.Capacity as Mempool @@ -32,7 +33,6 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Examples (localTxSubmissionClient) import Ouroboros.Network.Protocol.LocalTxSubmission.Server (localTxSubmissionServerPeer) -import Ouroboros.Network.SizeInBytes import Test.Consensus.Cardano.MiniProtocol.LocalTxSubmission.ByteStringTxParser (deserialiseTx) import Test.Consensus.Cardano.ProtocolInfo @@ -73,7 +73,8 @@ tests = let -- We don't want the mempool to fill up during these tests. - capcityBytesOverride = Mempool.mkCapacityBytesOverride 100_000 + capcityBytesOverride = + Mempool.mkCapacityBytesOverride (ByteSize32 100_000) -- Use 'show >$< stdoutTracer' for debugging. tracer = nullTracer mempoolParams = Mocked.MempoolAndModelParams { diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs index 31e2d0b571..5d948f88d8 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs @@ -3,9 +3,10 @@ module Test.Consensus.Shelley.Coherence (tests) where import Cardano.Ledger.Alonzo.Scripts (ExUnits, pointWiseExUnits) import qualified Data.Measure as Measure import Data.Word (Word32) -import qualified Ouroboros.Consensus.Mempool.Capacity as MempoolCapacity +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32 (..), + IgnoringOverflow (..)) import Ouroboros.Consensus.Shelley.Ledger.Mempool (AlonzoMeasure (..), - fromExUnits) + ConwayMeasure (..), fromExUnits) import Test.Cardano.Ledger.Alonzo.Serialisation.Generators () import Test.Tasty import Test.Tasty.QuickCheck @@ -16,11 +17,18 @@ tests = testGroup "Shelley coherences" [ ] -- | 'Measure.<=' and @'pointWiseExUnits' (<=)@ must agree -leqCoherence :: Word32 -> ExUnits -> ExUnits -> Property -leqCoherence w eu1 eu2 = +leqCoherence :: Word32 -> Word32 -> ExUnits -> ExUnits -> Property +leqCoherence w1 w2 eu1 eu2 = actual === expected where - inj eu = AlonzoMeasure (MempoolCapacity.ByteSize w) (fromExUnits eu) + -- ConwayMeasure is the fullest TxMeasure and mainnet's + inj eu = + ConwayMeasure + (AlonzoMeasure + (IgnoringOverflow $ ByteSize32 w1) + (fromExUnits eu) + ) + (IgnoringOverflow $ ByteSize32 w2) actual = inj eu1 Measure.<= inj eu2 expected = pointWiseExUnits (<=) eu1 eu2 diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index c0c3c4cf63..7a71b7ee92 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -544,7 +544,11 @@ forkBlockForging IS{..} blockForging = (ForgeInKnownSlot currentSlot tickedLedgerState) pure (mempoolHash, mempoolSlotNo, snap) - let txs = map fst $ snapshotTxs mempoolSnapshot + let txs = + snapshotTake mempoolSnapshot + $ blockCapacityTxMeasure (configLedger cfg) tickedLedgerState + -- NB respect the capacity of the ledger state we're extending, + -- which is /not/ 'snapshotLedgerState' -- force the mempool's computation before the tracer event _ <- evaluate (length txs) @@ -732,8 +736,11 @@ getMempoolReader mempool = MempoolReader.TxSubmissionMempoolReader snapshotHasTx } = MempoolReader.MempoolSnapshot { mempoolTxIdsAfter = \idx -> - [ (txId (txForgetValidated tx), idx', sz) - | (tx, idx', sz) <- snapshotTxsAfter idx + [ ( txId (txForgetValidated tx) + , idx' + , SizeInBytes $ unByteSize32 byteSize + ) + | (tx, idx', byteSize) <- snapshotTxsAfter idx ] , mempoolLookupTx = snapshotLookupTx , mempoolHasTx = snapshotHasTx diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index c6ce17dc07..e91932409c 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -649,7 +649,8 @@ runThreadNetwork systemTime ThreadNetworkArgs -- a new tx (e.g. added by TxSubmission) might render a crucial -- transaction valid mempChanged = do - let getMemp = (map snd . snapshotTxs) <$> getSnapshot mempool + let prjTno (_a, b, _c) = b :: TicketNo + getMemp = (map prjTno . snapshotTxs) <$> getSnapshot mempool (mempFp', _) <- atomically $ blockUntilChanged id mempFp getMemp pure (slot, ledger, mempFp') diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index d3835e09b5..4f29fd78fd 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -362,6 +363,8 @@ instance TxGen TestBlock where type TestBlock = HardForkBlock '[BlockA, BlockB] instance CanHardFork '[BlockA, BlockB] where + type HardForkTxMeasure '[BlockA, BlockB] = IgnoringOverflow ByteSize32 + hardForkEraTranslation = EraTranslation { translateLedgerState = PCons ledgerState_AtoB PNil , translateChainDepState = PCons chainDepState_AtoB PNil @@ -370,6 +373,10 @@ instance CanHardFork '[BlockA, BlockB] where hardForkChainSel = Tails.mk2 CompareBlockNo hardForkInjectTxs = InPairs.mk2 injectTx_AtoB + hardForkInjTxMeasure = \case + ( Z (WrapTxMeasure x)) -> x + S (Z (WrapTxMeasure x)) -> x + versionN2N :: BlockNodeToNodeVersion TestBlock versionN2N = HardForkNodeToNodeEnabled diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 80a01c92a8..32910a7eeb 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -326,11 +326,13 @@ instance LedgerSupportsMempool BlockA where reapplyTx cfg slot = fmap fst .: (applyTx cfg DoNotIntervene slot . forgetValidatedGenTxA) - txsMaxBytes _ = maxBound - txInBlockSize _ = 0 - txForgetValidated = forgetValidatedGenTxA +instance TxLimits BlockA where + type TxMeasure BlockA = IgnoringOverflow ByteSize32 + blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 $ 100 * 1024 -- arbitrary + txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + newtype instance TxId (GenTx BlockA) = TxIdA Int deriving stock (Show, Eq, Ord, Generic) deriving newtype (NoThunks, Serialise) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 2459f48118..443752ddb2 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -262,11 +262,13 @@ instance LedgerSupportsMempool BlockB where applyTx = \_ _ _wti tx -> case tx of {} reapplyTx = \_ _ vtx -> case vtx of {} - txsMaxBytes _ = maxBound - txInBlockSize _ = 0 - txForgetValidated = \case {} +instance TxLimits BlockB where + type TxMeasure BlockB = IgnoringOverflow ByteSize32 + blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 $ 100 * 1024 -- arbitrary + txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + data instance TxId (GenTx BlockB) deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NoThunks, Serialise) diff --git a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs index bda4545ece..cfd10dd283 100644 --- a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs +++ b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs @@ -36,8 +36,6 @@ import Ouroboros.Consensus.Config.SecurityParam as Consensus import qualified Ouroboros.Consensus.HardFork.History as HardFork import qualified Ouroboros.Consensus.Ledger.Basics as Ledger import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Ledger -import qualified Ouroboros.Consensus.Mempool as Mempool -import Ouroboros.Network.SizeInBytes import Test.Util.TestBlock (LedgerState (TestLedger), PayloadSemantics (PayloadDependentError, PayloadDependentState, applyPayload), TestBlockWith, applyDirectlyToPayloadDependentState, @@ -123,8 +121,11 @@ newtype instance Ledger.GenTx TestBlock = TestBlockGenTx { unGenTx :: Tx } -- | For the mempool tests and benchmarks it is not imporant that we calculate -- the actual size of the transaction in bytes. -txSize :: Ledger.GenTx TestBlock -> Mempool.SizeInBytes -txSize (TestBlockGenTx tx) = fromIntegral $ 1 + length (consumed tx) + length (produced tx) +txSize :: Ledger.GenTx TestBlock -> Ledger.ByteSize32 +txSize (TestBlockGenTx tx) = + Ledger.ByteSize32 + $ fromIntegral + $ 1 + length (consumed tx) + length (produced tx) mkTx :: [Token] @@ -145,13 +146,17 @@ instance Ledger.LedgerSupportsMempool TestBlock where fst <$> Ledger.applyTx cfg Ledger.DoNotIntervene slot genTx tickedSt -- FIXME: it is ok to use 'DoNotIntervene' here? + txForgetValidated (ValidatedGenTx tx) = tx + +instance Ledger.TxLimits TestBlock where + type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + -- We tweaked this in such a way that we test the case in which we exceed the -- maximum mempool capacity. The value used here depends on 'txInBlockSize'. - txsMaxBytes _ = 20 + blockCapacityTxMeasure _cfg _st = + Ledger.IgnoringOverflow $ Ledger.ByteSize32 20 - txInBlockSize = getSizeInBytes . txSize - - txForgetValidated (ValidatedGenTx tx) = tx + txMeasure _cfg _st = pure . Ledger.IgnoringOverflow . txSize newtype instance Ledger.TxId (Ledger.GenTx TestBlock) = TestBlockTxId Tx deriving stock (Generic) diff --git a/ouroboros-consensus/bench/mempool-bench/Main.hs b/ouroboros-consensus/bench/mempool-bench/Main.hs index e06217e510..18dfc712f6 100644 --- a/ouroboros-consensus/bench/mempool-bench/Main.hs +++ b/ouroboros-consensus/bench/mempool-bench/Main.hs @@ -21,8 +21,8 @@ import Data.Set () import qualified Data.Text as Text import qualified Data.Text.Read as Text.Read import Main.Utf8 (withStdTerminalHandles) +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32) import qualified Ouroboros.Consensus.Mempool.Capacity as Mempool -import Ouroboros.Network.SizeInBytes import System.Exit (die, exitFailure) import qualified Test.Consensus.Mempool.Mocked as Mocked import Test.Consensus.Mempool.Mocked (MockedMempool) @@ -57,8 +57,8 @@ main = withStdTerminalHandles $ do withResource (pure $!! let cmds = mkNTryAddTxs n - sz = sum $ map TestBlock.txSize $ getCmdsTxs cmds - in (cmds, Mempool.ByteSize $ getSizeInBytes sz) + sz = foldMap TestBlock.txSize $ getCmdsTxs cmds + in (cmds, sz) ) (\_ -> pure ()) (\getCmds -> do @@ -134,11 +134,9 @@ main = withStdTerminalHandles $ do Adding TestBlock transactions to a mempool -------------------------------------------------------------------------------} -openMempoolWithCapacity :: Mempool.ByteSize -> IO (MockedMempool IO TestBlock) +openMempoolWithCapacity :: ByteSize32 -> IO (MockedMempool IO TestBlock) openMempoolWithCapacity capacity = - Mocked.openMockedMempool (Mempool.mkCapacityBytesOverride - (Mempool.unByteSize capacity) - ) + Mocked.openMockedMempool (Mempool.mkCapacityBytesOverride capacity) Tracer.nullTracer Mocked.MempoolAndModelParams { Mocked.immpInitialState = TestBlock.initialLedgerState diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index aeb03444bb..c86f989ea0 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -273,6 +273,7 @@ library build-depends: base >=4.14 && <4.21, + base-deriving-via, base16-bytestring, bimap >=0.4 && <0.6, binary >=0.8 && <0.11, @@ -697,7 +698,6 @@ benchmark mempool-bench deepseq, nothunks, ouroboros-consensus, - ouroboros-network-api, serialise, tasty, tasty-bench, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs index 2019f51d24..6d39fc0597 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs @@ -20,21 +20,16 @@ module Ouroboros.Consensus.Block.Forging ( , forgeStateUpdateInfoFromUpdateInfo -- * 'UpdateInfo' , UpdateInfo (..) - -- * Selecting transaction sequence prefixes - , takeLargestPrefixThatFits ) where import Control.Tracer (Tracer, traceWith) import Data.Kind (Type) -import qualified Data.Measure as Measure import Data.Text (Text) import GHC.Stack import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Mempool.Capacity (TxLimits) -import qualified Ouroboros.Consensus.Mempool.Capacity as MempoolCapacity import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Ticked @@ -127,11 +122,11 @@ data BlockForging m blk = BlockForging { -- | Forge a block -- - -- The function is passed the contents of the mempool; this is a set of - -- transactions that is guaranteed to be consistent with the ledger state - -- (also provided as an argument) and with each other (when applied in - -- order). In principle /all/ of them could be included in the block (up - -- to maximum block size). + -- The function is passed the prefix of the mempool that will fit within + -- a valid block; this is a set of transactions that is guaranteed to be + -- consistent with the ledger state (also provided as an argument) and + -- with each other (when applied in order). All of them should be + -- included in the forged block, since the mempool ensures they can fit. -- -- NOTE: do not refer to the consensus or ledger config in the closure, -- because they might contain an @EpochInfo Identity@, which will be @@ -145,26 +140,11 @@ data BlockForging m blk = BlockForging { -> BlockNo -- Current block number -> SlotNo -- Current slot number -> TickedLedgerState blk -- Current ledger state - -> [Validated (GenTx blk)] -- Contents of the mempool + -> [Validated (GenTx blk)] -- Transactions to include -> IsLeader (BlockProtocol blk) -- Proof we are leader -> m blk } --- | The prefix of transactions to include in the block --- --- Filters out all transactions that do not fit the maximum size of total --- transactions in a single block, which is determined by querying the ledger --- state for the current limit. -takeLargestPrefixThatFits :: - TxLimits blk - => TickedLedgerState blk - -> [Validated (GenTx blk)] - -> [Validated (GenTx blk)] -takeLargestPrefixThatFits ledger txs = - Measure.take (MempoolCapacity.txMeasure ledger) capacity txs - where - capacity = MempoolCapacity.txsBlockCapacity ledger - data ShouldForge blk = -- | Before check whether we are a leader in this slot, we tried to update -- our forge state ('updateForgeState'), but it failed. We will not check diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs index 9af5b14959..4ed86d707e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs @@ -1,28 +1,48 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableSuperClasses #-} module Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork (CanHardFork (..)) where +import Data.Measure (Measure) import Data.SOP.Constraint import Data.SOP.Functors (Product2) import Data.SOP.InPairs (InPairs, RequiringBoth) import qualified Data.SOP.InPairs as InPairs import Data.SOP.NonEmpty +import qualified Data.SOP.Strict as SOP import Data.SOP.Tails (Tails) import qualified Data.SOP.Tails as Tails import Data.Typeable +import NoThunks.Class (NoThunks) import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock import Ouroboros.Consensus.HardFork.Combinator.InjectTxs import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel import Ouroboros.Consensus.HardFork.Combinator.Translation +import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.TypeFamilyWrappers + {------------------------------------------------------------------------------- CanHardFork -------------------------------------------------------------------------------} -class (All SingleEraBlock xs, Typeable xs, IsNonEmpty xs) => CanHardFork xs where +class ( All SingleEraBlock xs + , Typeable xs + , IsNonEmpty xs + , Measure (HardForkTxMeasure xs) + , HasByteSize (HardForkTxMeasure xs) + , NoThunks (HardForkTxMeasure xs) + , Show (HardForkTxMeasure xs) + ) => CanHardFork xs where + -- | A measure that can accurately represent the 'TxMeasure' of any era. + -- + -- Usually, this can simply be the union of the sets of components of each + -- individual era's 'TxMeasure'. (Which is too awkward of a type to express + -- in Haskell.) + type HardForkTxMeasure xs + hardForkEraTranslation :: EraTranslation xs hardForkChainSel :: Tails AcrossEraSelection xs hardForkInjectTxs :: @@ -33,7 +53,18 @@ class (All SingleEraBlock xs, Typeable xs, IsNonEmpty xs) => CanHardFork xs wher ) xs + -- | This is ideally exact. + -- + -- If that's not possible, the result must not be too small, since this is + -- relied upon to determine which prefix of the mempool's txs will fit in a + -- valid block. + hardForkInjTxMeasure :: SOP.NS WrapTxMeasure xs -> HardForkTxMeasure xs + instance SingleEraBlock blk => CanHardFork '[blk] where + type HardForkTxMeasure '[blk] = TxMeasure blk + hardForkEraTranslation = trivialEraTranslation hardForkChainSel = Tails.mk1 hardForkInjectTxs = InPairs.mk1 + + hardForkInjTxMeasure (SOP.Z (WrapTxMeasure x)) = x diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs index 2d9579d342..bfdb667bb5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs @@ -25,9 +25,11 @@ module Ouroboros.Consensus.HardFork.Combinator.Mempool ( , hardForkApplyTxErrToEither ) where +import Control.Arrow ((+++)) import Control.Monad.Except import Data.Functor.Product import Data.Kind (Type) +import qualified Data.Measure as Measure import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Functors (Product2 (..)) @@ -46,6 +48,8 @@ import Ouroboros.Consensus.HardFork.Combinator.Basics import Ouroboros.Consensus.HardFork.Combinator.Info import Ouroboros.Consensus.HardFork.Combinator.InjectTxs import Ouroboros.Consensus.HardFork.Combinator.Ledger (Ticked (..)) +import Ouroboros.Consensus.HardFork.Combinator.PartialConfig + (WrapPartialLedgerConfig (..)) import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool @@ -105,18 +109,6 @@ instance CanHardFork xs => LedgerSupportsMempool (HardForkBlock xs) where (WrapValidatedGenTx vtx) tls - txsMaxBytes = - hcollapse - . hcmap proxySingle (K . txsMaxBytes . unComp) - . State.tip - . tickedHardForkLedgerStatePerEra - - txInBlockSize = - hcollapse - . hcmap proxySingle (K . txInBlockSize) - . getOneEraGenTx - . getHardForkGenTx - txForgetValidated = HardForkGenTx . OneEraGenTx @@ -124,6 +116,80 @@ instance CanHardFork xs => LedgerSupportsMempool (HardForkBlock xs) where . getOneEraValidatedGenTx . getHardForkValidatedGenTx +instance CanHardFork xs => TxLimits (HardForkBlock xs) where + type TxMeasure (HardForkBlock xs) = HardForkTxMeasure xs + + blockCapacityTxMeasure + HardForkLedgerConfig{..} + (TickedHardForkLedgerState transition hardForkState) + = + hcollapse + $ hcizipWith proxySingle aux pcfgs hardForkState + where + pcfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra + ei = State.epochInfoPrecomputedTransitionInfo + hardForkLedgerConfigShape + transition + hardForkState + + aux :: + SingleEraBlock blk + => Index xs blk + -> WrapPartialLedgerConfig blk + -> (Ticked :.: LedgerState) blk + -> K (HardForkTxMeasure xs) blk + aux idx pcfg st' = + K + $ hardForkInjTxMeasure . injectNS idx . WrapTxMeasure + $ blockCapacityTxMeasure + (completeLedgerConfig' ei pcfg) + (unComp st') + + txMeasure + HardForkLedgerConfig{..} + (TickedHardForkLedgerState transition hardForkState) + tx + = + case matchTx injs (unwrapTx tx) hardForkState of + Left{} -> pure Measure.zero -- safe b/c the tx will be found invalid + Right pair -> hcollapse $ hcizipWith proxySingle aux cfgs pair + where + pcfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra + ei = State.epochInfoPrecomputedTransitionInfo + hardForkLedgerConfigShape + transition + hardForkState + cfgs = hcmap proxySingle (completeLedgerConfig'' ei) pcfgs + + unwrapTx = getOneEraGenTx . getHardForkGenTx + + injs :: InPairs (InjectPolyTx GenTx) xs + injs = + InPairs.hmap (\(Pair2 injTx _injValidatedTx) -> injTx) + $ InPairs.requiringBoth cfgs hardForkInjectTxs + + aux :: forall blk. + SingleEraBlock blk + => Index xs blk + -> WrapLedgerConfig blk + -> (Product GenTx (Ticked :.: LedgerState)) blk + -> K (Except (HardForkApplyTxErr xs) (HardForkTxMeasure xs)) blk + aux idx cfg (Pair tx' st') = + K + $ mapExcept + ( ( HardForkApplyTxErrFromEra + . OneEraApplyTxErr + . injectNS idx + . WrapApplyTxErr + ) + +++ + (hardForkInjTxMeasure . injectNS idx . WrapTxMeasure) + ) + $ txMeasure + (unwrapLedgerConfig cfg) + (unComp st') + tx' + -- | A private type used only to clarify the parameterization of 'applyHelper' data ApplyHelperMode :: (Type -> Type) -> Type where ModeApply :: ApplyHelperMode GenTx diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index 749f9b6660..45f5fa53e9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -60,6 +60,7 @@ import Cardano.Binary (enforceSize) import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise +import Control.Arrow ((+++)) import Control.Monad.Except import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Short as Short @@ -608,9 +609,6 @@ instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where tickedDualLedgerStateBridge } - txsMaxBytes = txsMaxBytes . tickedDualLedgerStateMain - txInBlockSize = txInBlockSize . dualGenTxMain - txForgetValidated vtx = DualGenTx { dualGenTxMain = txForgetValidated vDualGenTxMain @@ -624,6 +622,18 @@ instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where , vDualGenTxBridge } = vtx +instance Bridge m a => TxLimits (DualBlock m a) where + type TxMeasure (DualBlock m a) = TxMeasure m + + txMeasure DualLedgerConfig{..} TickedDualLedgerState{..} DualGenTx{..} = do + mapExcept (inj +++ id) + $ txMeasure dualLedgerConfigMain tickedDualLedgerStateMain dualGenTxMain + where + inj m = DualGenTxErr m (error "ByronSpec has no tx-too-big error") + + blockCapacityTxMeasure DualLedgerConfig{..} TickedDualLedgerState{..} = + blockCapacityTxMeasure dualLedgerConfigMain tickedDualLedgerStateMain + -- We don't need a pair of IDs, as long as we can unique ID the transaction newtype instance TxId (GenTx (DualBlock m a)) = DualGenTxId { dualGenTxIdMain :: GenTxId m 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 fc5e929617..1c88e4c953 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs @@ -1,28 +1,42 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.Ledger.SupportsMempool ( ApplyTxErr + , ByteSize32 (..) , ConvertRawTxId (..) , GenTx , GenTxId + , HasByteSize (..) , HasTxId (..) , HasTxs (..) + , IgnoringOverflow (..) , LedgerSupportsMempool (..) , TxId + , TxLimits (..) , Validated , WhetherToIntervene (..) ) where +import Control.DeepSeq (NFData) import Control.Monad.Except import Data.ByteString.Short (ShortByteString) +import Data.Coerce (coerce) +import Data.DerivingVia (InstantiatedAt (..)) import Data.Kind (Type) +import Data.Measure (Measure) +import qualified Data.Measure import Data.Word (Word32) import GHC.Stack (HasCallStack) +import NoThunks.Class import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ticked -import Ouroboros.Consensus.Util.IOLike -- | Generalized transaction -- @@ -59,6 +73,7 @@ data WhetherToIntervene deriving (Show) class ( UpdateLedger blk + , TxLimits blk , NoThunks (GenTx blk) , NoThunks (Validated (GenTx blk)) , NoThunks (Ticked (LedgerState blk)) @@ -96,34 +111,6 @@ class ( UpdateLedger blk -> TickedLedgerState blk -> Except (ApplyTxErr blk) (TickedLedgerState blk) - -- | The maximum number of bytes worth of transactions that can be put into - -- a block according to the currently adopted protocol parameters of the - -- ledger state. - -- - -- This is (conservatively) computed by subtracting the header size and any - -- other fixed overheads from the maximum block size. - txsMaxBytes :: TickedLedgerState blk -> Word32 - - -- | Return the post-serialisation size in bytes of a 'GenTx' /when it is - -- embedded in a block/. This size might differ from the size of the - -- serialisation used to send and receive the transaction across the - -- network. - -- - -- This size is used to compute how many transaction we can put in a block - -- when forging one. - -- - -- For example, CBOR-in-CBOR could be used when sending the transaction - -- across the network, requiring a few extra bytes compared to the actual - -- in-block serialisation. Another example is the transaction of the - -- hard-fork combinator which will include an envelope indicating its era - -- when sent across the network. However, when embedded in the respective - -- era's block, there is no need for such envelope. - -- - -- Can be implemented by serialising the 'GenTx', but, ideally, this is - -- implement more efficiently. E.g., by returning the length of the - -- annotation. - txInBlockSize :: GenTx blk -> Word32 - -- | Discard the evidence that transaction has been previously validated txForgetValidated :: Validated (GenTx blk) -> GenTx blk @@ -166,3 +153,132 @@ type GenTxId blk = TxId (GenTx blk) class HasTxs blk where -- | Return the transactions part of the given block in no particular order. extractTxs :: blk -> [GenTx blk] + +{------------------------------------------------------------------------------- + Tx sizes +-------------------------------------------------------------------------------} + +-- | Each block has its limits of how many transactions it can hold. That limit +-- is compared against the sum of measurements taken of each of the +-- transactions in that block. +-- +-- How we measure the transaction depends of the era that this transaction +-- belongs to (more specifically it depends on the block type to which this +-- transaction will be added). For initial eras (like Byron and initial +-- generations of Shelley based eras) this measure was simply a byte size +-- (block could not be bigger then given size - in bytes - specified by the +-- ledger state). In subsequent eras (starting with Alonzo) this measure was a +-- bit more complex as it had to take other factors into account (like +-- execution units). For details please see the individual instances for the +-- TxLimits. +class ( Measure (TxMeasure blk) + , HasByteSize (TxMeasure blk) + , NoThunks (TxMeasure blk) + , Show (TxMeasure blk) + ) => TxLimits blk where + -- | The (possibly multi-dimensional) size of a transaction in a block. + type TxMeasure blk + + -- | The various sizes (bytes, Plutus script ExUnits, etc) of a tx /when it's + -- in a block/ + -- + -- This size is used to compute how many transaction we can put in a block + -- when forging one. + -- + -- The byte size component in particular might differ from the size of the + -- serialisation used to send and receive the transaction across the network. + -- For example, CBOR-in-CBOR could be used when sending the transaction + -- across the network, requiring a few extra bytes compared to the actual + -- in-block serialisation. Another example is the transaction of the + -- hard-fork combinator which will include an envelope indicating its era + -- when sent across the network. However, when embedded in the respective + -- era's block, there is no need for such envelope. An example from upstream + -- is that the Cardano ledger's "Segregated Witness" encoding scheme + -- contributes to the encoding overhead. + -- + -- INVARIANT Assuming no hash collisions, the size should be the same in any + -- state in which the transaction is valid. For example, it's acceptable to + -- simply omit the size of ref scripts that could not be found, since their + -- absence implies the tx is invalid. In fact, that invalidity could be + -- reported by this function, but it need not be. + -- + -- INVARIANT @Right x = txMeasure cfg st tx@ implies @x 'Measure.<=' + -- 'blockCapacityTxMeasure cfg st'. Otherwise, the mempool could block + -- forever. + -- + -- Returns an exception if and only if the transaction violates the per-tx + -- limits. + txMeasure :: + LedgerConfig blk + -- ^ used at least by HFC's composition logic + -> TickedLedgerState blk + -> GenTx blk + -> Except (ApplyTxErr blk) (TxMeasure blk) + + -- | What is the allowed capacity for the txs in an individual block? + blockCapacityTxMeasure :: + LedgerConfig blk + -- ^ at least for symmetry with 'txMeasure' + -> TickedLedgerState blk + -> TxMeasure blk + +-- | We intentionally do not declare a 'Num' instance! We prefer @ByteSize32@ +-- to occur explicitly in the code where possible, for +-- legibility/perspicuousness. We also do not need nor want subtraction. +-- +-- This data type measures the size of a transaction, the sum of the sizes of +-- txs in a block, the sum of the sizes of the txs in the mempool, etc. None of +-- those will ever need to represent gigabytes, so 32 bits suffice. But 16 bits +-- would not. +-- +-- This is modular arithmetic, so uses need to be concerned with overflow. For +-- example, see the related guard in +-- 'Ouroboros.Consensus.Mempool.Update.pureTryAddTx'. One important element is +-- anticipating the possibility of very large summands injected by the +-- adversary. +-- +-- There is a temptation to use 'Natural' here, since it can never overflow. +-- However, some points in the interface do not easily handle 'Natural's, such +-- as encoders. Thus 'Natural' would merely defer the overflow concern, and +-- even risks instilling a false sense that overflow need not be considered at +-- all. +newtype ByteSize32 = ByteSize32 { unByteSize32 :: Word32 } + deriving stock (Show) + deriving newtype (Eq, Ord) + deriving newtype (NFData) + deriving (Monoid, Semigroup) + via (InstantiatedAt Measure (IgnoringOverflow ByteSize32)) + deriving (NoThunks) + via OnlyCheckWhnfNamed "ByteSize" ByteSize32 + +-- | @'IgnoringOverflow' a@ has the same semantics as @a@, except it ignores +-- the fact that @a@ can overflow. +-- +-- For example, @'Measure' 'Word32'@ is not lawful, because overflow violates +-- the /lattice-ordered monoid/ law. But @'Measure' (IgnoringOverflow +-- 'Word32')@ is lawful, since it explicitly ignores that case. +-- +-- WARNING: anywhere this type occurs is a very strong indicator that overflow +-- will break assumptions, so overflow must therefore be guarded against. +-- +-- TODO upstream this to the @measure@ package +newtype IgnoringOverflow a = IgnoringOverflow { unIgnoringOverflow :: a } + deriving stock (Show) + deriving newtype (Eq, Ord) + deriving newtype (NFData) + deriving newtype (Monoid, Semigroup) + deriving newtype (NoThunks) + deriving newtype (HasByteSize) + +instance Measure (IgnoringOverflow ByteSize32) where + zero = coerce (0 :: Word32) + plus = coerce $ (+) @Word32 + min = coerce $ min @Word32 + max = coerce $ max @Word32 + +class HasByteSize a where + -- | The byte size component (of 'TxMeasure') + txMeasureByteSize :: a -> ByteSize32 + +instance HasByteSize ByteSize32 where + txMeasureByteSize = id diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs index d91ad92420..fed42f2a46 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs @@ -19,14 +19,10 @@ module Ouroboros.Consensus.Mempool ( , TicketNo , zeroTicketNo -- * Mempool capacity - , MempoolCapacityBytes (..) , MempoolCapacityBytesOverride (..) , computeMempoolCapacity -- ** Mempool Size , MempoolSize (..) - -- ** Transaction size - , ByteSize (..) - , TxLimits (..) -- * Mempool initialization , openMempool , openMempoolWithoutSyncThread @@ -42,10 +38,9 @@ import Ouroboros.Consensus.Mempool.API (ForgeLedgerState (..), MempoolSnapshot (..), SizeInBytes, TicketNo, addLocalTxs, addTxs, isMempoolTxAdded, isMempoolTxRejected, mempoolTxAddedToMaybe, zeroTicketNo) -import Ouroboros.Consensus.Mempool.Capacity (ByteSize (..), - MempoolCapacityBytes (..), - MempoolCapacityBytesOverride (..), MempoolSize (..), - TxLimits (..), computeMempoolCapacity) +import Ouroboros.Consensus.Mempool.Capacity + (MempoolCapacityBytesOverride (..), MempoolSize (..), + computeMempoolCapacity) import Ouroboros.Consensus.Mempool.Impl.Common (LedgerInterface (..), TraceEventMempool (..), chainDBLedgerInterface) import Ouroboros.Consensus.Mempool.Init (openMempool, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs index ea58f06519..261c3d7ac1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs @@ -96,31 +96,30 @@ data Mempool m blk = Mempool { -- -- The new transaction provided will be validated, /in order/, against -- the ledger state obtained by applying all the transactions already in - -- the Mempool to it. Transactions which are found to be invalid, with - -- respect to the ledger state, are dropped, whereas valid transactions - -- are added to the mempool. + -- the mempool. Transactions which are found to be invalid are dropped, + -- whereas valid transactions are added to the mempool. -- - -- Note that transactions that are invalid, with respect to the ledger - -- state, will /never/ be added to the mempool. However, it is possible - -- that, at a given point in time, transactions which were once valid - -- but are now invalid, with respect to the current ledger state, could - -- exist within the mempool until they are revalidated and dropped from - -- the mempool via a call to 'syncWithLedger' or by the background - -- thread that watches the ledger for changes. + -- Note that transactions that are invalid will /never/ be added to the + -- mempool. However, it is possible that, at a given point in time, + -- transactions which were valid in an older ledger state but are invalid + -- in the current ledger state, could exist within the mempool until they + -- are revalidated and dropped from the mempool via a call to + -- 'syncWithLedger' or by the background thread that watches the ledger + -- for changes. -- - -- This action returns one of two results + -- This action returns one of two results. -- -- * A 'MempoolTxAdded' value if the transaction provided was found to - -- be valid. This transactions is now in the Mempool. + -- be valid. This transactions is now in the mempool. -- -- * A 'MempoolTxRejected' value if the transaction provided was found -- to be invalid, along with its accompanying validation errors. This - -- transactions is not in the Mempool. + -- transactions is not in the mempool. -- -- Note that this is a blocking action. It will block until the -- transaction fits into the mempool. This includes transactions that -- turn out to be invalid: the action waits for there to be space for - -- the transaction before it gets validated. + -- the transaction before validation is attempted. -- -- Note that it is safe to use this from multiple threads concurrently. -- @@ -131,10 +130,6 @@ data Mempool m blk = Mempool { -- > processed <- addTx wti txs -- > prj processed == tx -- - -- Note that previously valid transaction that are now invalid with - -- respect to the current ledger state are dropped from the mempool, but - -- are not part of the first returned list (nor the second). - -- -- In principle it is possible that validation errors are transient; for -- example, it is possible that a transaction is rejected because one of -- its inputs is not /yet/ available in the UTxO (the transaction it @@ -148,16 +143,14 @@ data Mempool m blk = Mempool { -- (after all, by definition that must mean its inputs have been used). -- Rejected transactions are therefore not necessarily a sign of -- malicious behaviour. Indeed, we would expect /most/ transactions that - -- are reported as invalid by 'tryAddTxs' to be invalid precisely - -- because they have already been included. Distinguishing between these - -- two cases can be done in theory, but it is expensive unless we have - -- an index of transaction hashes that have been included on the - -- blockchain. + -- are reported as invalid by 'addTxs' to be invalid precisely because + -- they have already been included. Distinguishing between these two + -- cases can be done in theory, but it is expensive unless we have an + -- index of transaction hashes that have been included on the blockchain. -- -- As long as we keep the mempool entirely in-memory this could live in -- @STM m@; we keep it in @m@ instead to leave open the possibility of -- persistence. - -- addTx :: AddTxOnBehalfOf -> GenTx blk -> m (MempoolAddTxResult blk) @@ -194,19 +187,19 @@ data Mempool m blk = Mempool { -- This does not update the state of the mempool. , getSnapshotFor :: ForgeLedgerState blk -> STM m (MempoolSnapshot blk) - -- | Get the mempool's capacity in bytes. + -- | Get the mempool's capacity -- -- Note that the capacity of the Mempool, unless it is overridden with - -- 'MempoolCapacityBytesOverride', can dynamically change when the - -- ledger state is updated: it will be set to twice the current ledger's - -- maximum transaction capacity of a block. + -- 'MempoolCapacityBytesOverride', can dynamically change when the ledger + -- state is updated: it will be set to twice the current ledger's maximum + -- transaction capacity of a block. -- -- When the capacity happens to shrink at some point, we /do not/ remove -- transactions from the Mempool to satisfy this new lower limit. -- Instead, we treat it the same way as a Mempool which is /at/ -- capacity, i.e., we won't admit new transactions until some have been -- removed because they have become invalid. - , getCapacity :: STM m Cap.MempoolCapacityBytes + , getCapacity :: STM m (TxMeasure blk) } {------------------------------------------------------------------------------- @@ -327,13 +320,17 @@ data ForgeLedgerState blk = data MempoolSnapshot blk = MempoolSnapshot { -- | Get all transactions (oldest to newest) in the mempool snapshot along -- with their ticket number. - snapshotTxs :: [(Validated (GenTx blk), TicketNo)] + snapshotTxs :: [(Validated (GenTx blk), TicketNo, ByteSize32)] -- | Get all transactions (oldest to newest) in the mempool snapshot, -- along with their ticket number, which are associated with a ticket -- number greater than the one provided. , snapshotTxsAfter :: - TicketNo -> [(Validated (GenTx blk), TicketNo, TxSizeInBytes)] + TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)] + + -- | Get the greatest prefix (oldest to newest) that respects the given + -- block capacity. + , snapshotTake :: TxMeasure blk -> [Validated (GenTx blk)] -- | Get a specific transaction from the mempool snapshot by its ticket -- number, if it exists. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Capacity.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Capacity.hs index a632ebe425..6f2ffb54a0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Capacity.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Capacity.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -- | Mempool capacity, size and transaction size datatypes. -- @@ -12,63 +9,71 @@ -- > import qualified Ouroboros.Consensus.Mempool.Capacity as Capacity module Ouroboros.Consensus.Mempool.Capacity ( -- * Mempool capacity - MempoolCapacityBytes (..) - , MempoolCapacityBytesOverride (..) + MempoolCapacityBytesOverride (..) , computeMempoolCapacity , mkCapacityBytesOverride -- * Mempool Size , MempoolSize (..) - -- * Transaction size - , ByteSize (..) - , TxLimits (..) ) where -import Cardano.Prelude (NFData) +import Data.DerivingVia (InstantiatedAt (..)) import Data.Measure (Measure) +import Data.Semigroup (stimes) import Data.Word (Word32) -import NoThunks.Class import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Ticked (Ticked (..)) {------------------------------------------------------------------------------- Mempool capacity in bytes -------------------------------------------------------------------------------} --- | Represents the maximum number of bytes worth of transactions that a --- 'Mempool' can contain. -newtype MempoolCapacityBytes = MempoolCapacityBytes { - getMempoolCapacityBytes :: Word32 - } - deriving (Eq, Show, NoThunks) - -- | An override for the default 'MempoolCapacityBytes' which is 2x the -- maximum transaction capacity data MempoolCapacityBytesOverride = NoMempoolCapacityBytesOverride -- ^ Use 2x the maximum transaction capacity of a block. This will change -- dynamically with the protocol parameters adopted in the current ledger. - | MempoolCapacityBytesOverride !MempoolCapacityBytes - -- ^ Use the following 'MempoolCapacityBytes'. + | MempoolCapacityBytesOverride !ByteSize32 + -- ^ Use the least multiple of the block capacity that is no less than this + -- size. deriving (Eq, Show) -- | Create an override for the mempool capacity using the provided number of -- bytes. -mkCapacityBytesOverride :: Word32 -> MempoolCapacityBytesOverride -mkCapacityBytesOverride = MempoolCapacityBytesOverride . MempoolCapacityBytes +mkCapacityBytesOverride :: ByteSize32 -> MempoolCapacityBytesOverride +mkCapacityBytesOverride = MempoolCapacityBytesOverride -- | If no override is provided, calculate the default mempool capacity as 2x -- the current ledger's maximum transaction capacity of a block. +-- +-- If an override is present, reinterpret it as a number of blocks (rounded +-- up), and then simply multiply the ledger's capacity by that number. computeMempoolCapacity :: LedgerSupportsMempool blk - => TickedLedgerState blk + => LedgerConfig blk + -> TickedLedgerState blk -> MempoolCapacityBytesOverride - -> MempoolCapacityBytes -computeMempoolCapacity st mc = case mc of - NoMempoolCapacityBytesOverride -> noOverride - MempoolCapacityBytesOverride override -> override + -> TxMeasure blk +computeMempoolCapacity cfg st override = + capacity where - noOverride = MempoolCapacityBytes (txsMaxBytes st * 2) + oneBlock = blockCapacityTxMeasure cfg st + ByteSize32 oneBlockBytes = txMeasureByteSize oneBlock + + blockCount = case override of + NoMempoolCapacityBytesOverride -> 2 + MempoolCapacityBytesOverride (ByteSize32 x) -> + -- This calculation is happening at Word32. Thus overflow is silently + -- accepted. Adding one less than the denominator to the numerator + -- effectively rounds up instead of down. + max 1 $ (x + oneBlockBytes - 1) `div` oneBlockBytes + + SemigroupViaMeasure capacity = + stimes blockCount (SemigroupViaMeasure oneBlock) + +newtype SemigroupViaMeasure a = SemigroupViaMeasure a + deriving (Eq, Measure) + deriving Semigroup via (InstantiatedAt Measure (SemigroupViaMeasure a)) {------------------------------------------------------------------------------- Mempool size @@ -78,51 +83,13 @@ computeMempoolCapacity st mc = case mc of data MempoolSize = MempoolSize { msNumTxs :: !Word32 -- ^ The number of transactions in the mempool. - , msNumBytes :: !Word32 + , msNumBytes :: !ByteSize32 -- ^ The summed byte size of all the transactions in the mempool. } deriving (Eq, Show) instance Semigroup MempoolSize where - MempoolSize xt xb <> MempoolSize yt yb = MempoolSize (xt + yt) (xb + yb) + MempoolSize xt xb <> MempoolSize yt yb = MempoolSize (xt + yt) (xb <> yb) instance Monoid MempoolSize where - mempty = MempoolSize { msNumTxs = 0, msNumBytes = 0 } + mempty = MempoolSize { msNumTxs = 0, msNumBytes = ByteSize32 0 } mappend = (<>) - -{------------------------------------------------------------------------------- - Tx sizes --------------------------------------------------------------------------------} - --- | Each block has its limits of how many transactions it can hold. --- That limit is compared against the sum of measurements --- taken of each of the transactions in that block. --- --- How we measure the transaction depends of the era that this --- transaction belongs to (more specifically it depends on the block --- type to which this transaction will be added). For initial eras --- (like Byron and initial generations of Shelley based eras) this --- measure was simply a ByteSize (block could not be bigger then --- given size - in bytes - specified by the ledger state). In future --- eras (starting with Alonzo) this measure was a bit more complex --- as it had to take other factors into account (like execution units). --- For details please see the individual instances for the TxLimits. -class Measure (TxMeasure blk) => TxLimits blk where - type TxMeasure blk - - -- | What is the measure an individual tx? - txMeasure :: - TickedLedgerState blk - -> Validated (GenTx blk) - -> TxMeasure blk - - -- | What is the allowed capacity for txs in an individual block? - txsBlockCapacity :: Ticked (LedgerState blk) -> TxMeasure blk - -{------------------------------------------------------------------------------- - ByteSize --------------------------------------------------------------------------------} - -newtype ByteSize = ByteSize { unByteSize :: Word32 } - deriving stock (Show) - deriving newtype (Eq, NFData, Ord) - deriving newtype (Measure) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs index 2fd49e722d..17d51b3876 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs @@ -73,7 +73,7 @@ data InternalState blk = IS { -- the normal way: by becoming invalid w.r.t. the updated ledger state. -- We treat a Mempool /over/ capacity in the same way as a Mempool /at/ -- capacity. - isTxs :: !(TxSeq (Validated (GenTx blk))) + isTxs :: !(TxSeq (TxMeasure blk) (Validated (GenTx blk))) -- | The cached IDs of transactions currently in the mempool. -- @@ -123,37 +123,42 @@ data InternalState blk = IS { -- transactions will be in the next block. So any changes caused by that -- block will take effect after applying it and will only affect the -- next block. - , isCapacity :: !MempoolCapacityBytes + , isCapacity :: !(TxMeasure blk) } deriving (Generic) deriving instance ( NoThunks (Validated (GenTx blk)) , NoThunks (GenTxId blk) , NoThunks (Ticked (LedgerState blk)) + , NoThunks (TxMeasure blk) , StandardHash blk , Typeable blk ) => NoThunks (InternalState blk) -- | \( O(1) \). Return the number of transactions in the internal state of -- the Mempool paired with their total size in bytes. -isMempoolSize :: InternalState blk -> MempoolSize -isMempoolSize = TxSeq.toMempoolSize . isTxs +isMempoolSize :: TxLimits blk => InternalState blk -> MempoolSize +isMempoolSize is = MempoolSize { + msNumTxs = fromIntegral $ length $ isTxs is + , msNumBytes = txMeasureByteSize $ TxSeq.toSize $ isTxs is + } initInternalState :: LedgerSupportsMempool blk => MempoolCapacityBytesOverride -> TicketNo -- ^ Used for 'isLastTicketNo' + -> LedgerConfig blk -> SlotNo -> TickedLedgerState blk -> InternalState blk -initInternalState capacityOverride lastTicketNo slot st = IS { +initInternalState capacityOverride lastTicketNo cfg slot st = IS { isTxs = TxSeq.Empty , isTxIds = Set.empty , isLedgerState = st , isTip = castHash (getTipHash st) , isSlotNo = slot , isLastTicketNo = lastTicketNo - , isCapacity = computeMempoolCapacity st capacityOverride + , isCapacity = computeMempoolCapacity cfg st capacityOverride } {------------------------------------------------------------------------------- @@ -203,7 +208,9 @@ initMempoolEnv :: ( IOLike m initMempoolEnv ledgerInterface cfg capacityOverride tracer = do st <- atomically $ getCurrentLedgerState ledgerInterface let (slot, st') = tickLedgerState cfg (ForgeInUnknownSlot st) - isVar <- newTVarIO $ initInternalState capacityOverride TxSeq.zeroTicketNo slot st' + isVar <- + newTVarIO + $ initInternalState capacityOverride TxSeq.zeroTicketNo cfg slot st' addTxRemoteFifo <- newMVar () addTxAllFifo <- newMVar () return MempoolEnv @@ -254,10 +261,10 @@ data ValidationResult invalidTx blk = ValidationResult { -- | Capacity of the Mempool. Corresponds to 'vrBeforeTip' and -- 'vrBeforeSlotNo', /not/ 'vrAfter'. - , vrBeforeCapacity :: MempoolCapacityBytes + , vrBeforeCapacity :: TxMeasure blk -- | The transactions that were found to be valid (oldest to newest) - , vrValid :: TxSeq (Validated (GenTx blk)) + , vrValid :: TxSeq (TxMeasure blk) (Validated (GenTx blk)) -- | The cached IDs of transactions that were found to be valid (oldest to -- newest) @@ -297,7 +304,7 @@ data ValidationResult invalidTx blk = ValidationResult { -- signatures. extendVRPrevApplied :: (LedgerSupportsMempool blk, HasTxId (GenTx blk)) => LedgerConfig blk - -> TxTicket (Validated (GenTx blk)) + -> TxTicket (TxMeasure blk) (Validated (GenTx blk)) -> ValidationResult (Validated (GenTx blk)) blk -> ValidationResult (Validated (GenTx blk)) blk extendVRPrevApplied cfg txTicket vr = @@ -323,39 +330,36 @@ extendVRNew :: (LedgerSupportsMempool blk, HasTxId (GenTx blk)) -> WhetherToIntervene -> GenTx blk -> ValidationResult (GenTx blk) blk - -> ( Either (ApplyTxErr blk) (Validated (GenTx blk)) - , ValidationResult (GenTx blk) blk - ) -extendVRNew cfg wti tx vr = assert (isNothing vrNewValid) $ - case runExcept (applyTx cfg wti vrSlotNo tx vrAfter) of - Left err -> - ( Left err - , vr { vrInvalid = (tx, err) : vrInvalid - } - ) - Right (st', vtx) -> - ( Right vtx - , vr { vrValid = vrValid :> TxTicket vtx nextTicketNo sz - , vrValidTxIds = Set.insert (txId tx) vrValidTxIds - , vrNewValid = Just vtx - , vrAfter = st' - , vrLastTicketNo = nextTicketNo - } - ) + -> Either + (ApplyTxErr blk) + ( Validated (GenTx blk) + , ValidationResult (GenTx blk) blk + ) +extendVRNew cfg wti tx vr = + assert (isNothing vrNewValid) $ runExcept m where ValidationResult { vrValid , vrValidTxIds , vrAfter - , vrInvalid , vrLastTicketNo , vrNewValid , vrSlotNo } = vr - nextTicketNo = succ vrLastTicketNo - - sz = txInBlockSize tx + m = do + txsz <- txMeasure cfg vrAfter tx + (st', vtx) <- applyTx cfg wti vrSlotNo tx vrAfter + let nextTicketNo = succ vrLastTicketNo + pure + ( vtx + , vr { vrValid = vrValid :> TxTicket vtx nextTicketNo txsz + , vrValidTxIds = Set.insert (txId tx) vrValidTxIds + , vrNewValid = Just vtx + , vrAfter = st' + , vrLastTicketNo = nextTicketNo + } + ) {------------------------------------------------------------------------------- Conversions @@ -410,8 +414,8 @@ validationResultFromIS is = ValidationResult { } = is -- | Create a Mempool Snapshot from a given Internal State of the mempool. -snapshotFromIS :: - HasTxId (GenTx blk) +snapshotFromIS :: forall blk. + (HasTxId (GenTx blk), TxLimits blk) => InternalState blk -> MempoolSnapshot blk snapshotFromIS is = MempoolSnapshot { @@ -422,34 +426,38 @@ snapshotFromIS is = MempoolSnapshot { , snapshotMempoolSize = implSnapshotGetMempoolSize is , snapshotSlotNo = isSlotNo is , snapshotLedgerState = isLedgerState is + , snapshotTake = implSnapshotTake is } where implSnapshotGetTxs :: InternalState blk - -> [(Validated (GenTx blk), TicketNo)] - implSnapshotGetTxs is' = - map (\(a, b, _c) -> (a, b)) - $ implSnapshotGetTxsAfter is' TxSeq.zeroTicketNo + -> [(Validated (GenTx blk), TicketNo, ByteSize32)] + implSnapshotGetTxs = flip implSnapshotGetTxsAfter TxSeq.zeroTicketNo implSnapshotGetTxsAfter :: InternalState blk -> TicketNo - -> [(Validated (GenTx blk), TicketNo, TxSizeInBytes)] + -> [(Validated (GenTx blk), TicketNo, ByteSize32)] implSnapshotGetTxsAfter IS{isTxs} = TxSeq.toTuples . snd . TxSeq.splitAfterTicketNo isTxs + implSnapshotTake :: InternalState blk + -> TxMeasure blk + -> [Validated (GenTx blk)] + implSnapshotTake IS{isTxs} = + map TxSeq.txTicketTx . TxSeq.toList . fst . TxSeq.splitAfterTxSize isTxs + implSnapshotGetTx :: InternalState blk -> TicketNo -> Maybe (Validated (GenTx blk)) implSnapshotGetTx IS{isTxs} = (isTxs `TxSeq.lookupByTicketNo`) - implSnapshotHasTx :: Ord (GenTxId blk) - => InternalState blk + implSnapshotHasTx :: InternalState blk -> GenTxId blk -> Bool implSnapshotHasTx IS{isTxIds} = flip Set.member isTxIds implSnapshotGetMempoolSize :: InternalState blk -> MempoolSize - implSnapshotGetMempoolSize = TxSeq.toMempoolSize . isTxs + implSnapshotGetMempoolSize = isMempoolSize {------------------------------------------------------------------------------- Validating txs or states @@ -498,7 +506,7 @@ revalidateTxsFor :: -> TickedLedgerState blk -> TicketNo -- ^ 'isLastTicketNo' & 'vrLastTicketNo' - -> [TxTicket (Validated (GenTx blk))] + -> [TxTicket (TxMeasure blk) (Validated (GenTx blk))] -> ValidationResult (Validated (GenTx blk)) blk revalidateTxsFor capacityOverride cfg slot st lastTicketNo txTickets = repeatedly @@ -506,7 +514,7 @@ revalidateTxsFor capacityOverride cfg slot st lastTicketNo txTickets = txTickets (validationResultFromIS is) where - is = initInternalState capacityOverride lastTicketNo slot st + is = initInternalState capacityOverride lastTicketNo cfg slot st {------------------------------------------------------------------------------- Tracing support for the mempool operations diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/TxSeq.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/TxSeq.hs index 0c04858a36..1380c9dabc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/TxSeq.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/TxSeq.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | Intended for qualified import. @@ -21,21 +22,24 @@ module Ouroboros.Consensus.Mempool.TxSeq ( , splitAfterTicketNo , splitAfterTxSize , toList - , toMempoolSize + , toSize , toTuples , zeroTicketNo -- * Reference implementations for testing , splitAfterTxSizeSpec ) where +import Control.Arrow ((***)) import Data.FingerTree.Strict (StrictFingerTree) import qualified Data.FingerTree.Strict as FingerTree import qualified Data.Foldable as Foldable +import Data.Measure (Measure) +import qualified Data.Measure as Measure import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -import Ouroboros.Consensus.Mempool.Capacity (MempoolSize (..)) -import Ouroboros.Network.SizeInBytes +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32, + HasByteSize, txMeasureByteSize) {------------------------------------------------------------------------------- Mempool transaction sequence as a finger tree @@ -55,14 +59,13 @@ zeroTicketNo = TicketNo 0 -- | We associate transactions in the mempool with their ticket number and -- size in bytes. -- -data TxTicket tx = TxTicket - { txTicketTx :: !tx +data TxTicket sz tx = TxTicket + { txTicketTx :: !tx -- ^ The transaction associated with this ticket. - , txTicketNo :: !TicketNo + , txTicketNo :: !TicketNo -- ^ The ticket number. - , txTicketTxSizeInBytes :: !SizeInBytes - -- ^ The byte size of the transaction ('txTicketTx') associated with this - -- ticket. + , txTicketSize :: !sz + -- ^ The size of 'txTicketTx'. } deriving (Eq, Show, Generic, NoThunks) -- | The mempool is a sequence of transactions with their ticket numbers and @@ -81,14 +84,15 @@ data TxTicket tx = TxTicket -- measure to allow not just normal sequence operations but also efficient -- splitting and indexing by the ticket number. -- -newtype TxSeq tx = TxSeq (StrictFingerTree TxSeqMeasure (TxTicket tx)) +newtype TxSeq sz tx = + TxSeq (StrictFingerTree (TxSeqMeasure sz) (TxTicket sz tx)) deriving stock (Show) deriving newtype (NoThunks) -instance Foldable TxSeq where +instance Measure sz => Foldable (TxSeq sz) where foldMap f (TxSeq txs) = Foldable.foldMap (f . txTicketTx) txs null (TxSeq txs) = Foldable.null txs - length (TxSeq txs) = mSize $ FingerTree.measure txs + length (TxSeq txs) = mCount $ FingerTree.measure txs -- | The 'StrictFingerTree' relies on a \"measure\" for subsequences in the -- tree. A measure of the size of the subsequence allows for efficient @@ -101,45 +105,57 @@ instance Foldable TxSeq where -- 'Measured' instance, and also a way to combine the measures, via a 'Monoid' -- instance. -- -data TxSeqMeasure = TxSeqMeasure { - mMinTicket :: !TicketNo, - mMaxTicket :: !TicketNo, - mSizeBytes :: !SizeInBytes, - mSize :: !Int +data TxSeqMeasure sz = TxSeqMeasure { + mCount :: !Int, + mMinTicket :: !TicketNo, + mMaxTicket :: !TicketNo, + mSize :: !sz } deriving Show -instance FingerTree.Measured TxSeqMeasure (TxTicket tx) where - measure (TxTicket _ tno tsz) = TxSeqMeasure tno tno tsz 1 +instance Measure sz => FingerTree.Measured (TxSeqMeasure sz) (TxTicket sz tx) where + measure ticket = TxSeqMeasure { + mCount = 1 + , mMinTicket = txTicketNo + , mMaxTicket = txTicketNo + , mSize = txTicketSize + } + where + TxTicket{txTicketNo, txTicketSize} = ticket -instance Semigroup TxSeqMeasure where +instance Measure sz => Semigroup (TxSeqMeasure sz) where vl <> vr = TxSeqMeasure - (mMinTicket vl `min` mMinTicket vr) - (mMaxTicket vl `max` mMaxTicket vr) - (mSizeBytes vl + mSizeBytes vr) - (mSize vl + mSize vr) + (mCount vl + mCount vr) + (mMinTicket vl `min` mMinTicket vr) + (mMaxTicket vl `max` mMaxTicket vr) + (mSize vl `Measure.plus` mSize vr) -instance Monoid TxSeqMeasure where - mempty = TxSeqMeasure maxBound minBound 0 0 +instance Measure sz => Monoid (TxSeqMeasure sz) where + mempty = TxSeqMeasure { + mCount = 0 + , mMinTicket = maxBound -- note the inversion! + , mMaxTicket = minBound + , mSize = Measure.zero + } mappend = (<>) -- | A helper function for the ':>' pattern. -- -viewBack :: TxSeq tx -> Maybe (TxSeq tx, TxTicket tx) +viewBack :: Measure sz => TxSeq sz tx -> Maybe (TxSeq sz tx, TxTicket sz tx) viewBack (TxSeq txs) = case FingerTree.viewr txs of FingerTree.EmptyR -> Nothing txs' FingerTree.:> tx -> Just (TxSeq txs', tx) -- | A helper function for the ':<' pattern. -- -viewFront :: TxSeq tx -> Maybe (TxTicket tx, TxSeq tx) +viewFront :: Measure sz => TxSeq sz tx -> Maybe (TxTicket sz tx, TxSeq sz tx) viewFront (TxSeq txs) = case FingerTree.viewl txs of FingerTree.EmptyL -> Nothing tx FingerTree.:< txs' -> Just (tx, TxSeq txs') -- | An empty mempool sequence. -- -pattern Empty :: TxSeq tx +pattern Empty :: Measure sz => TxSeq sz tx pattern Empty <- (viewFront -> Nothing) where Empty = TxSeq FingerTree.empty @@ -147,7 +163,7 @@ pattern Empty <- (viewFront -> Nothing) where -- -- New txs are always added at the back. -- -pattern (:>) :: TxSeq tx -> TxTicket tx -> TxSeq tx +pattern (:>) :: Measure sz => TxSeq sz tx -> TxTicket sz tx -> TxSeq sz tx pattern txs :> tx <- (viewBack -> Just (txs, tx)) where TxSeq txs :> tx = TxSeq (txs FingerTree.|> tx) --TODO: assert ordered by ticket no @@ -156,7 +172,7 @@ pattern txs :> tx <- (viewBack -> Just (txs, tx)) where -- Note that we never add txs at the front. We access txs from front to back -- when forwarding txs to other peers, or when adding txs to blocks. -- -pattern (:<) :: TxTicket tx -> TxSeq tx -> TxSeq tx +pattern (:<) :: Measure sz => TxTicket sz tx -> TxSeq sz tx -> TxSeq sz tx pattern tx :< txs <- (viewFront -> Just (tx, txs)) infixl 5 :>, :< @@ -164,10 +180,9 @@ infixl 5 :>, :< {-# COMPLETE Empty, (:>) #-} {-# COMPLETE Empty, (:<) #-} - -- | \( O(\log(n)) \). Look up a transaction in the sequence by its 'TicketNo'. -- -lookupByTicketNo :: TxSeq tx -> TicketNo -> Maybe tx +lookupByTicketNo :: Measure sz => TxSeq sz tx -> TicketNo -> Maybe tx lookupByTicketNo (TxSeq txs) n = case FingerTree.search (\ml mr -> mMaxTicket ml >= n && mMinTicket mr > n) txs of @@ -179,19 +194,27 @@ lookupByTicketNo (TxSeq txs) n = -- less than or equal to the given ticket, and the second part has transactions -- with tickets strictly greater than the given ticket. -- -splitAfterTicketNo :: TxSeq tx -> TicketNo -> (TxSeq tx, TxSeq tx) +splitAfterTicketNo :: + Measure sz + => TxSeq sz tx + -> TicketNo + -> (TxSeq sz tx, TxSeq sz tx) splitAfterTicketNo (TxSeq txs) n = case FingerTree.split (\m -> mMaxTicket m > n) txs of (l, r) -> (TxSeq l, TxSeq r) --- | \( O(\log(n)) \). Split the sequence of transactions into two parts --- based on the given 'SizeInBytes'. The first part has transactions whose --- summed 'SizeInBytes' is less than or equal to the given 'SizeInBytes', --- and the second part has the remaining transactions in the sequence. +-- | \( O(\log(n)) \). Split the sequence of transactions into two parts based +-- on the given @sz@. The first part has transactions whose summed @sz@ is less +-- than or equal to the given @sz@, and the second part has the remaining +-- transactions in the sequence. -- -splitAfterTxSize :: TxSeq tx -> SizeInBytes -> (TxSeq tx, TxSeq tx) +splitAfterTxSize :: + Measure sz + => TxSeq sz tx + -> sz + -> (TxSeq sz tx, TxSeq sz tx) splitAfterTxSize (TxSeq txs) n = - case FingerTree.split (\m -> mSizeBytes m > n) txs of + case FingerTree.split (\m -> not $ mSize m Measure.<= n) txs of (l, r) -> (TxSeq l, TxSeq r) -- | \( O(n) \). Specification of 'splitAfterTxSize'. @@ -200,51 +223,52 @@ splitAfterTxSize (TxSeq txs) n = -- -- This function is used to verify whether 'splitAfterTxSize' behaves as -- expected. -splitAfterTxSizeSpec :: TxSeq tx -> SizeInBytes -> (TxSeq tx, TxSeq tx) +splitAfterTxSizeSpec :: forall sz tx. + Measure sz + => TxSeq sz tx + -> sz + -> (TxSeq sz tx, TxSeq sz tx) splitAfterTxSizeSpec txseq n = - mapTuple fromList $ go 0 [] (toList txseq) + (fromList *** fromList) + $ go Measure.zero [] + $ toList txseq where - mapTuple :: (a -> b) -> (a, a) -> (b, b) - mapTuple f (x, y) = (f x, f y) - - go :: SizeInBytes - -> [TxTicket tx] - -> [TxTicket tx] - -> ([TxTicket tx], [TxTicket tx]) - go accByteSize accTickets = \case + go :: sz + -> [TxTicket sz tx] + -> [TxTicket sz tx] + -> ([TxTicket sz tx], [TxTicket sz tx]) + go accSize accTickets = \case [] -> (reverse accTickets, []) t:ts - | let accByteSize' = accByteSize + txTicketTxSizeInBytes t - , accByteSize' <= n - -> go accByteSize' (t:accTickets) ts + | let accSize' = accSize `Measure.plus` txTicketSize t + , accSize' Measure.<= n + -> go accSize' (t:accTickets) ts | otherwise -> (reverse accTickets, t:ts) -- | Given a list of 'TxTicket's, construct a 'TxSeq'. -fromList :: [TxTicket tx] -> TxSeq tx +fromList :: Measure sz => [TxTicket sz tx] -> TxSeq sz tx fromList = Foldable.foldl' (:>) Empty -- | Convert a 'TxSeq' to a list of 'TxTicket's. -toList :: TxSeq tx -> [TxTicket tx] +toList :: TxSeq sz tx -> [TxTicket sz tx] toList (TxSeq ftree) = Foldable.toList ftree -- | Convert a 'TxSeq' to a list of pairs of transactions and their --- associated 'TicketNo's. -toTuples :: TxSeq tx -> [(tx, TicketNo, TxSizeInBytes)] +-- associated 'TicketNo's and 'ByteSize32's. +toTuples :: HasByteSize sz => TxSeq sz tx -> [(tx, TicketNo, ByteSize32)] toTuples (TxSeq ftree) = fmap (\ticket -> ( txTicketTx ticket , txTicketNo ticket - , txTicketTxSizeInBytes ticket) + , txMeasureByteSize (txTicketSize ticket) + ) ) (Foldable.toList ftree) --- | \( O(1) \). Return the 'MempoolSize' of the given 'TxSeq'. -toMempoolSize :: TxSeq tx -> MempoolSize -toMempoolSize (TxSeq ftree) = MempoolSize - { msNumTxs = fromIntegral mSize - , msNumBytes = getSizeInBytes mSizeBytes - } +-- | \( O(1) \). Return the total size of the given 'TxSeq'. +toSize :: Measure sz => TxSeq sz tx -> sz +toSize (TxSeq ftree) = mSize where - TxSeqMeasure { mSizeBytes, mSize } = FingerTree.measure ftree + TxSeqMeasure { mSize } = FingerTree.measure ftree diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs index 3a1925db2f..372ea15c29 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs @@ -10,8 +10,10 @@ module Ouroboros.Consensus.Mempool.Update ( import Control.Concurrent.Class.MonadMVar (MVar, withMVar) import Control.Exception (assert) +import Control.Monad.Except (runExcept) import Control.Tracer -import Data.Maybe (isJust, isNothing) +import Data.Maybe (isJust) +import qualified Data.Measure as Measure import qualified Data.Set as Set import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract @@ -91,7 +93,7 @@ implAddTx istate remoteFifo allFifo cfg trcr onbehalf tx = TryAddTx _ result ev -> do return (result, ev) -- or block until space is available to fit the next transaction - NoSpaceLeft -> retry + NotEnoughSpaceLeft -> retry traceWith trcr ev return result @@ -102,9 +104,8 @@ implAddTx istate remoteFifo allFifo cfg trcr onbehalf tx = -- | Result of trying to add a transaction to the mempool. data TryAddTx blk = - -- | No space is left in the mempool and no more transactions could be - -- added. - NoSpaceLeft + -- | Adding the next transaction would put the mempool over capacity. + NotEnoughSpaceLeft -- | A transaction was processed. | TryAddTx (Maybe (InternalState blk)) @@ -124,7 +125,7 @@ data TryAddTx blk = -- Transactions are added one by one, updating the Mempool each time one was -- added successfully. -- --- See the necessary invariants on the Haddock for 'API.tryAddTxs'. +-- See the necessary invariants on the Haddock for 'API.addTxs'. -- -- This function does not sync the Mempool contents with the ledger state in -- case the latter changes, it relies on the background thread to do that. @@ -150,16 +151,11 @@ implTryAddTx istate cfg wti tx = do let outcome = pureTryAddTx cfg wti tx is case outcome of TryAddTx (Just is') _ _ -> writeTVar istate is' - _ -> return () + TryAddTx Nothing _ _ -> return () + NotEnoughSpaceLeft -> return () return outcome --- | Craft a 'TryAddTx' value containing the resulting state if applicable, the --- tracing event and the result of adding this transaction. See the --- documentation of 'implTryAddTx' for some more context. --- --- It returns 'NoSpaceLeft' only when the current mempool size is bigger or --- equal than then mempool capacity. Otherwise it will validate the transaction --- and add it to the mempool if there is at least one byte free on the mempool. +-- | See the documentation of 'implTryAddTx' for some more context. pureTryAddTx :: ( LedgerSupportsMempool blk , HasTxId (GenTx blk) @@ -172,28 +168,84 @@ pureTryAddTx :: -> InternalState blk -- ^ The current internal state of the mempool. -> TryAddTx blk -pureTryAddTx cfg wti tx is - -- We add the transaction if there is at least one byte free left in the - -- mempool. - | let curSize = msNumBytes $ isMempoolSize is - , curSize < getMempoolCapacityBytes (isCapacity is) - = - case eVtx of - -- We only extended the ValidationResult with a single transaction - -- ('tx'). So if it's not in 'vrInvalid', it must be in 'vrNewValid'. - Right vtx -> - assert (isJust (vrNewValid vr)) $ - TryAddTx - (Just is') - (MempoolTxAdded vtx) - (TraceMempoolAddedTx - vtx - (isMempoolSize is) - (isMempoolSize is') - ) - Left err -> - assert (isNothing (vrNewValid vr)) $ - assert (length (vrInvalid vr) == 1) $ +pureTryAddTx cfg wti tx is = + case runExcept $ txMeasure cfg (isLedgerState is) tx of + Left err -> + -- The transaction does not have a valid measure (eg its ExUnits is + -- greater than what this ledger state allows for a single transaction). + -- + -- It might seem simpler to remove the failure case from 'txMeasure' and + -- simply fully validate the tx before determining whether it'd fit in + -- the mempool; that way we could reject invalid txs ASAP. However, for a + -- valid tx, we'd pay that validation cost every time the node's + -- selection changed, even if the tx wouldn't fit. So it'd very much be + -- as if the mempool were effectively over capacity! What's worse, each + -- attempt would not be using 'extendVRPrevApplied'. + TryAddTx + Nothing + (MempoolTxRejected tx err) + (TraceMempoolRejectedTx + tx + err + (isMempoolSize is) + ) + Right txsz + -- Check for overflow + -- + -- No measure of a transaction can ever be negative, so the only way + -- adding two measures could result in a smaller measure is if some + -- modular arithmetic overflowed. Also, overflow necessarily yields a + -- lesser result, since adding 'maxBound' is modularly equivalent to + -- subtracting one. Recall that we're checking each individual addition. + -- + -- We assume that the 'txMeasure' limit and the mempool capacity + -- 'isCapacity' are much smaller than the modulus, and so this should + -- never happen. Despite that, blocking until adding the transaction + -- doesn't overflow seems like a reasonable way to handle this case. + | not $ currentSize Measure.<= currentSize `Measure.plus` txsz + -> + NotEnoughSpaceLeft + -- We add the transaction if and only if it wouldn't overrun any component + -- of the mempool capacity. + -- + -- In the past, this condition was instead @TxSeq.toSize (isTxs is) < + -- isCapacity is@. Thus the effective capacity of the mempool was + -- actually one increment less than the reported capacity plus one + -- transaction. That subtlety's cost paid for two benefits. + -- + -- First, the absence of addition avoids a risk of overflow, since the + -- transaction's sizes (eg ExUnits) have not yet been bounded by + -- validation (which presumably enforces a low enough bound that any + -- reasonably-sized mempool would never overflow the representation's + -- 'maxBound'). + -- + -- Second, it is more fair, since it does not depend on the transaction + -- at all. EG a large transaction might struggle to win the race against + -- a firehose of tiny transactions. + -- + -- However, we prefer to avoid the subtlety. Overflow is handled by the + -- previous guard. And fairness is already ensured elsewhere (the 'MVar's + -- in 'implAddTx' --- which the "Test.Consensus.Mempool.Fairness" test + -- exercises). Moreover, the notion of "is under capacity" becomes + -- difficult to assess independently of the pending tx when the measure + -- is multi-dimensional; both typical options (any component is not full + -- or every component is not full) lead to some confusing behaviors + -- (denying some txs that would "obviously" fit and accepting some txs + -- that "obviously" don't, respectively). + -- + -- Even with the overflow handler, it's important that 'txMeasure' + -- returns a well-bounded result. Otherwise, if an adversarial tx arrived + -- that could't even fit in an empty mempool, then that thread would + -- never release the 'MVar'. In particular, we tacitly assume here that a + -- tx that wouldn't even fit in an empty mempool would be rejected by + -- 'txMeasure'. + | not $ currentSize `Measure.plus` txsz Measure.<= isCapacity is + -> + NotEnoughSpaceLeft + | otherwise + -> + case extendVRNew cfg wti tx $ validationResultFromIS is of + Left err -> TryAddTx Nothing (MempoolTxRejected tx err) @@ -202,11 +254,20 @@ pureTryAddTx cfg wti tx is err (isMempoolSize is) ) - | otherwise - = NoSpaceLeft - where - (eVtx, vr) = extendVRNew cfg wti tx $ validationResultFromIS is - is' = internalStateFromVR vr + Right (vtx, vr) -> + let is' = internalStateFromVR vr + in + assert (isJust (vrNewValid vr)) $ + TryAddTx + (Just is') + (MempoolTxAdded vtx) + (TraceMempoolAddedTx + vtx + (isMempoolSize is) + (isMempoolSize is') + ) + where + currentSize = TxSeq.toSize (isTxs is) {------------------------------------------------------------------------------- Remove transactions diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs index 07bdb5ec62..7e91f15fe5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs @@ -31,19 +31,22 @@ localTxMonitorServer mempool = { recvMsgDone = do pure () , recvMsgAcquire = do - s <- atomically $ (,) <$> getCapacity mempool <*> getSnapshot mempool + s <- atomically $ + (,) + <$> (txMeasureByteSize <$> getCapacity mempool) + <*> getSnapshot mempool pure $ serverStAcquiring s } serverStAcquiring - :: (MempoolCapacityBytes, MempoolSnapshot blk) + :: (ByteSize32, MempoolSnapshot blk) -> ServerStAcquiring (GenTxId blk) (GenTx blk) SlotNo m () serverStAcquiring s@(_, snapshot) = SendMsgAcquired (snapshotSlotNo snapshot) (serverStAcquired s (snapshotTxs snapshot)) serverStAcquired - :: (MempoolCapacityBytes, MempoolSnapshot blk) - -> [(Validated (GenTx blk), idx)] + :: (ByteSize32, MempoolSnapshot blk) + -> [(Validated (GenTx blk), idx, ByteSize32)] -> ServerStAcquired (GenTxId blk) (GenTx blk) SlotNo m () serverStAcquired s@(capacity, snapshot) txs = ServerStAcquired @@ -51,21 +54,24 @@ localTxMonitorServer mempool = case txs of [] -> pure $ SendMsgReplyNextTx Nothing (serverStAcquired s []) - (txForgetValidated -> h, _):q -> + (txForgetValidated -> h, _tno, _byteSize):q -> pure $ SendMsgReplyNextTx (Just h) (serverStAcquired s q) , recvMsgHasTx = \txid -> pure $ SendMsgReplyHasTx (snapshotHasTx snapshot txid) (serverStAcquired s txs) , recvMsgGetSizes = do let MempoolSize{msNumTxs,msNumBytes} = snapshotMempoolSize snapshot let sizes = MempoolSizeAndCapacity - { capacityInBytes = getMempoolCapacityBytes capacity - , sizeInBytes = msNumBytes + { capacityInBytes = unByteSize32 capacity + , sizeInBytes = unByteSize32 msNumBytes , numberOfTxs = msNumTxs } pure $ SendMsgReplyGetSizes sizes (serverStAcquired s txs) , recvMsgAwaitAcquire = do s' <- atomically $ do - s'@(_, snapshot') <- (,) <$> getCapacity mempool <*> getSnapshot mempool + s'@(_, snapshot') <- + (,) + <$> (txMeasureByteSize <$> getCapacity mempool) + <*> getSnapshot mempool s' <$ check (not (snapshot `isSameSnapshot` snapshot')) pure $ serverStAcquiring s' , recvMsgRelease = @@ -78,6 +84,8 @@ localTxMonitorServer mempool = -> MempoolSnapshot blk -> Bool isSameSnapshot a b = - (snd <$> snapshotTxs a) == (snd <$> snapshotTxs b) + (tno <$> snapshotTxs a) == (tno <$> snapshotTxs b) && snapshotSlotNo a == snapshotSlotNo b + + tno (_a, b, _c) = b :: TicketNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs index ae6d091b3d..532bf23e9c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs @@ -22,6 +22,8 @@ module Ouroboros.Consensus.TypeFamilyWrappers ( , WrapTentativeHeaderState (..) , WrapTentativeHeaderView (..) , WrapTipInfo (..) + , WrapTxMeasure (..) + , WrapValidatedGenTx (..) -- * Protocol based , WrapCanBeLeader (..) , WrapChainDepState (..) @@ -31,7 +33,6 @@ module Ouroboros.Consensus.TypeFamilyWrappers ( , WrapLedgerView (..) , WrapSelectView (..) , WrapValidateView (..) - , WrapValidatedGenTx (..) , WrapValidationErr (..) -- * Versioning , WrapNodeToClientVersion (..) @@ -79,7 +80,8 @@ newtype WrapTipInfo blk = WrapTipInfo { unwrapTipInf -- :.: g)@ requires @'Data.Functor.Classes.Eq1' f)). The bespoke composition -- 'WrapValidatedGenTx' therefore serves much the same purpose as the other -- wrappers in this module. -newtype WrapValidatedGenTx blk = WrapValidatedGenTx { unwrapValidatedGenTx :: Validated (GenTx blk)} +newtype WrapValidatedGenTx blk = WrapValidatedGenTx { unwrapValidatedGenTx :: Validated (GenTx blk) } +newtype WrapTxMeasure blk = WrapTxMeasure { unwrapTxMeasure :: TxMeasure blk } {------------------------------------------------------------------------------- Consensus based diff --git a/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs b/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs index 6892c5610f..f63de8b33d 100644 --- a/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs +++ b/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Mempool with a mocked ledger interface module Test.Consensus.Mempool.Mocked ( @@ -96,11 +97,13 @@ removeTxs :: -> m () removeTxs = Mempool.removeTxs . getMempool -getTxs :: +getTxs :: forall blk. (Ledger.LedgerSupportsMempool blk) => MockedMempool IO blk -> IO [Ledger.GenTx blk] getTxs mockedMempool = do snapshotTxs <- fmap Mempool.snapshotTxs $ atomically $ Mempool.getSnapshot $ getMempool mockedMempool - pure $ fmap (Ledger.txForgetValidated . fst) snapshotTxs + pure $ fmap prjTx snapshotTxs + where + prjTx (a, _b, _c) = Ledger.txForgetValidated a :: Ledger.GenTx blk 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 8a001f70c2..9b2767cefe 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 @@ -59,6 +59,8 @@ module Ouroboros.Consensus.Mock.Ledger.Block ( , decodeSimpleHeader , encodeSimpleHeader , simpleBlockBinaryBlockInfo + -- * For tests + , simpleBlockCapacity ) where import Cardano.Binary (ToCBOR (..)) @@ -431,12 +433,20 @@ instance MockProtocolSpecific c ext reapplyTx _cfg slot vtx st = updateSimpleUTxO slot (forgetValidatedSimpleGenTx vtx) st + txForgetValidated = forgetValidatedSimpleGenTx + +instance TxLimits (SimpleBlock c ext) where + type TxMeasure (SimpleBlock c ext) = IgnoringOverflow ByteSize32 + -- Large value so that the Mempool tests never run out of capacity when they -- don't override it. - txsMaxBytes = const 1000000000 - txInBlockSize = txSize + -- + -- But not 'maxbound'!, since the mempool sometimes holds multiple blocks worth. + blockCapacityTxMeasure _cfg _st = IgnoringOverflow simpleBlockCapacity + txMeasure _cfg _st = pure . IgnoringOverflow . txSize - txForgetValidated = forgetValidatedSimpleGenTx +simpleBlockCapacity :: ByteSize32 +simpleBlockCapacity = ByteSize32 512 newtype instance TxId (GenTx (SimpleBlock c ext)) = SimpleGenTxId { unSimpleGenTxId :: Mock.TxId @@ -480,8 +490,8 @@ mkSimpleGenTx tx = SimpleGenTx , simpleGenTxId = Hash.hashWithSerialiser toCBOR tx } -txSize :: GenTx (SimpleBlock c ext) -> Word32 -txSize = fromIntegral . Lazy.length . serialise +txSize :: GenTx (SimpleBlock c ext) -> ByteSize32 +txSize = ByteSize32 . fromIntegral . Lazy.length . serialise {------------------------------------------------------------------------------- Support for QueryLedger diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs index c2a006fb97..3cbb3b8a75 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs @@ -46,8 +46,9 @@ import Data.List as List (foldl', isSuffixOf, nub, partition, sortOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) +import Data.Semigroup (stimes) import qualified Data.Set as Set -import Data.Word +import Data.Word (Word32) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime @@ -95,6 +96,8 @@ tests = testGroup "Mempool" , testProperty "removeTxs [..] == forM [..] removeTxs" prop_Mempool_semigroup_removeTxs ] +type TheMeasure = IgnoringOverflow ByteSize32 + {------------------------------------------------------------------------------- Mempool Implementation Properties -------------------------------------------------------------------------------} @@ -104,9 +107,8 @@ prop_Mempool_snapshotTxs_snapshotTxsAfter :: TestSetup -> Property prop_Mempool_snapshotTxs_snapshotTxsAfter setup = withTestMempool setup $ \TestMempool { mempool } -> do let Mempool { getSnapshot } = mempool - prj (tx, tn, _sz) = (tx, tn) MempoolSnapshot { snapshotTxs, snapshotTxsAfter} <- atomically getSnapshot - return $ snapshotTxs === map prj (snapshotTxsAfter zeroTicketNo) + return $ snapshotTxs === snapshotTxsAfter zeroTicketNo -- | Test that all valid transactions added to a 'Mempool' can be retrieved -- afterward. @@ -116,7 +118,7 @@ prop_Mempool_addTxs_getTxs setup = _ <- addTxs mempool (allTxs setup) MempoolSnapshot { snapshotTxs } <- atomically $ getSnapshot mempool return $ counterexample (ppTxs (txs setup)) $ - validTxs setup `isSuffixOf` map (txForgetValidated . fst) snapshotTxs + validTxs setup `isSuffixOf` map (txForgetValidated . prjTx) snapshotTxs -- | Test that both adding the transactions one by one and adding them in one go -- produce the same result. @@ -155,10 +157,10 @@ prop_Mempool_addTxs_result setup = prop_Mempool_InvalidTxsNeverAdded :: TestSetupWithTxs -> Property prop_Mempool_InvalidTxsNeverAdded setup = withTestMempool (testSetup setup) $ \TestMempool { mempool } -> do - txsInMempoolBefore <- map fst . snapshotTxs <$> + txsInMempoolBefore <- map prjTx . snapshotTxs <$> atomically (getSnapshot mempool) _ <- addTxs mempool (allTxs setup) - txsInMempoolAfter <- map fst . snapshotTxs <$> + txsInMempoolAfter <- map prjTx . snapshotTxs <$> atomically (getSnapshot mempool) return $ counterexample (ppTxs (txs setup)) $ conjoin -- Check for each transaction in the mempool (ignoring those already @@ -178,7 +180,7 @@ prop_Mempool_removeTxs (TestSetupWithTxInMempool testSetup txToRemove) = withTestMempool testSetup $ \TestMempool { mempool } -> do let Mempool { removeTxs, getSnapshot } = mempool removeTxs [txId txToRemove] - txsInMempoolAfter <- map fst . snapshotTxs <$> atomically getSnapshot + txsInMempoolAfter <- map prjTx . snapshotTxs <$> atomically getSnapshot return $ counterexample ("Transactions in the mempool after removing (" <> show txToRemove <> "): " <> show txsInMempoolAfter) @@ -203,8 +205,8 @@ prop_Mempool_semigroup_removeTxs (TestSetupWithTxsInMempool testSetup txsToRemov snapshotMempoolSize snapshot1 === snapshotMempoolSize snapshot2 .&&. snapshotSlotNo snapshot1 === snapshotSlotNo snapshot1 --- | Test that 'getCapacity' returns the 'MempoolCapacityBytes' value that the --- mempool was initialized with. +-- | Test that 'getCapacity' returns the greatest multiple of the block +-- capacity that is not greater than the requested capacity. -- -- Ignore the "100% empty Mempool" label in the test output, that is there -- because we reuse 'withTestMempool' and always start with an empty Mempool @@ -212,12 +214,20 @@ prop_Mempool_semigroup_removeTxs (TestSetupWithTxsInMempool testSetup txsToRemov prop_Mempool_getCapacity :: MempoolCapTestSetup -> Property prop_Mempool_getCapacity mcts = withTestMempool testSetup $ \TestMempool{mempool} -> do - actualCapacity <- atomically $ getCapacity mempool - pure (actualCapacity === testCapacity) + IgnoringOverflow actualCapacity <- atomically $ getCapacity mempool + pure $ actualCapacity === expectedCapacity where MempoolCapacityBytesOverride testCapacity = testMempoolCapOverride testSetup MempoolCapTestSetup (TestSetupWithTxs testSetup _txsToAdd) = mcts + ByteSize32 dnom = simpleBlockCapacity + + expectedCapacity = + (\n -> stimes n simpleBlockCapacity) + $ max 1 + -- adding one less than the denom to the numer achieves rounding up + $ (unByteSize32 testCapacity + dnom - 1) `div` dnom + -- | Test that all valid transactions added to a 'Mempool' via 'addTxs' are -- appropriately represented in the trace of events. prop_Mempool_TraceValidTxs :: TestSetupWithTxs -> Property @@ -260,7 +270,7 @@ prop_Mempool_TraceRemovedTxs setup = MempoolSnapshot { snapshotTxs } <- atomically $ getSnapshot mempool -- We add all the transactions in the mempool to the ledger. Some of -- them will become invalid because all inputs have been spent. - let txsInMempool = map fst snapshotTxs + let txsInMempool = map prjTx snapshotTxs errs <- atomically $ addTxsToLedger (map txForgetValidated txsInMempool) -- Sync the mempool with the ledger. Now some of the transactions in the @@ -291,6 +301,11 @@ prop_Mempool_TraceRemovedTxs setup = | (tx, Left err) <- fst $ validateTxs ledgerState txsInMempool ] +prjTx :: + (Validated (GenTx TestBlock), TicketNo, ByteSize32) + -> Validated (GenTx TestBlock) +prjTx (a, _b, _c) = a + {------------------------------------------------------------------------------- TestSetup: how to set up a TestMempool -------------------------------------------------------------------------------} @@ -330,32 +345,30 @@ ppTestSetup :: TestSetup -> String ppTestSetup TestSetup { testInitialTxs , testMempoolCapOverride } = unlines $ - ["Initial contents of the Mempool:"] <> - (map ppTestTxWithHash testInitialTxs) <> - ["Mempool capacity override:"] <> + ["Initial contents of the Mempool:"] <> + (map ppTestTxWithHash testInitialTxs) <> + ["Total size:"] <> + [show $ foldMap txSize $ testInitialTxs] <> + ["Mempool capacity override:"] <> [show testMempoolCapOverride] ppTestTxWithHash :: TestTx -> String ppTestTxWithHash x = condense (hashWithSerialiser toCBOR (simpleGenTx x) :: Hash SHA256 Tx, x) --- | Given some transactions, calculate the sum of their sizes in bytes. -txSizesInBytes :: [TestTx] -> SizeInBytes -txSizesInBytes = SizeInBytes . List.foldl' (\acc tx -> acc + txSize tx) 0 - -- | Generate a 'TestSetup' and return the ledger obtained by applying all of -- the initial transactions. -- -- The generated 'testMempoolCap' will be: --- > 'txSizesInBytes' 'testInitialTxs' + extraCapacity -genTestSetupWithExtraCapacity :: Int -> Word32 -> Gen (TestSetup, LedgerState TestBlock) +-- > foldMap 'txSize' '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 = txSizesInBytes txs2 - mpCap = MempoolCapacityBytes (getSizeInBytes initTxsSizeInBytes + extraCapacity) + let initTxsSizeInBytes = foldMap txSize txs2 + mpCap = initTxsSizeInBytes <> extraCapacity testSetup = TestSetup { testLedgerState = ledger1 , testInitialTxs = txs2 @@ -367,34 +380,38 @@ genTestSetupWithExtraCapacity maxInitialTxs extraCapacity = do -- the initial transactions. Generates setups with a fixed -- 'MempoolCapacityBytesOverride', no 'NoMempoolCapacityBytesOverride'. genTestSetup :: Int -> Gen (TestSetup, LedgerState TestBlock) -genTestSetup maxInitialTxs = genTestSetupWithExtraCapacity maxInitialTxs 0 +genTestSetup maxInitialTxs = + genTestSetupWithExtraCapacity maxInitialTxs (ByteSize32 0) -- | Random 'MempoolCapacityBytesOverride' instance Arbitrary TestSetup where arbitrary = sized $ \n -> do - extraCapacity <- fromIntegral <$> choose (0, n) + extraCapacity <- (ByteSize32 . fromIntegral) <$> choose (0, n) testSetup <- fst <$> genTestSetupWithExtraCapacity n extraCapacity noOverride <- arbitrary + let initialSize = foldMap txSize $ testInitialTxs testSetup + defaultCap = simpleBlockCapacity <> simpleBlockCapacity return $ - if noOverride + if noOverride && initialSize <= defaultCap then testSetup { testMempoolCapOverride = NoMempoolCapacityBytesOverride } else testSetup shrink TestSetup { testLedgerState , testInitialTxs - , testMempoolCapOverride = MempoolCapacityBytesOverride - (MempoolCapacityBytes mpCap) + , testMempoolCapOverride = + MempoolCapacityBytesOverride (ByteSize32 mpCap) } = -- TODO we could shrink @testLedgerState@ too [ TestSetup { testLedgerState , testInitialTxs = testInitialTxs' - , testMempoolCapOverride = MempoolCapacityBytesOverride - (MempoolCapacityBytes mpCap') + , testMempoolCapOverride = + MempoolCapacityBytesOverride mpCap' } - | let extraCap = mpCap - getSizeInBytes (txSizesInBytes testInitialTxs) + | let ByteSize32 initial = foldMap txSize testInitialTxs + extraCap = mpCap - initial , testInitialTxs' <- shrinkList (const []) testInitialTxs , isRight $ txsAreValid testLedgerState testInitialTxs' - , let mpCap' = getSizeInBytes (txSizesInBytes testInitialTxs') + extraCap + , let mpCap' = foldMap txSize testInitialTxs' <> ByteSize32 extraCap ] -- TODO shrink to an override, that's an easier test case @@ -591,15 +608,19 @@ instance Arbitrary TestSetupWithTxs where (testSetup, ledger) <- genTestSetup n (txs, _ledger') <- genTxs nbTxs ledger testSetup' <- case testMempoolCapOverride testSetup of - NoMempoolCapacityBytesOverride -> return testSetup - MempoolCapacityBytesOverride (MempoolCapacityBytes mpCap) -> do + NoMempoolCapacityBytesOverride -> return testSetup + MempoolCapacityBytesOverride mpCap -> do noOverride <- arbitrary + let initialSize = foldMap txSize $ testInitialTxs testSetup + defaultCap = simpleBlockCapacity <> simpleBlockCapacity + newSize = + foldMap (txSize . fst) (filter snd txs) + <> maximum (ByteSize32 0 : map (txSize . fst) (filter (not . snd) txs)) return testSetup { testMempoolCapOverride = - if noOverride + if noOverride && initialSize <> newSize <= defaultCap then NoMempoolCapacityBytesOverride - else MempoolCapacityBytesOverride $ MempoolCapacityBytes $ - mpCap + getSizeInBytes (txSizesInBytes $ map fst txs) + else MempoolCapacityBytesOverride $ mpCap <> newSize } return TestSetupWithTxs { testSetup = testSetup', txs } @@ -796,7 +817,7 @@ withTestMempool setup@TestSetup {..} prop = Right _ -> property True Left e -> counterexample (mkErrMsg e) $ property False where - txs = map (txForgetValidated . fst) snapshotTxs + txs = map (txForgetValidated . prjTx) snapshotTxs mkErrMsg e = "At the end of the test, the Mempool contents were invalid: " <> show e @@ -816,21 +837,24 @@ 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 = sum (map txSize (testInitialTxs testSetup)) + let currentSize = foldMap txSize (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 + sum (map txSize validTxsToAdd) + capacityMaxBound = currentSize <> foldMap txSize validTxsToAdd -- Note that we could pick @currentSize@, meaning that we can't add any -- more transactions to the Mempool + capacity <- choose - ( capacityMinBound - , capacityMaxBound + ( unByteSize32 capacityMinBound + , unByteSize32 capacityMaxBound ) let testSetup' = testSetup { - testMempoolCapOverride = MempoolCapacityBytesOverride $ - MempoolCapacityBytes capacity + testMempoolCapOverride = + MempoolCapacityBytesOverride + $ ByteSize32 + $ capacity } return $ MempoolCapTestSetup testSetupWithTxs { testSetup = testSetup' } @@ -839,17 +863,19 @@ instance Arbitrary MempoolCapTestSetup where -------------------------------------------------------------------------------} -- | Finds elements in the sequence -prop_TxSeq_lookupByTicketNo_complete :: [Int] -> Bool +prop_TxSeq_lookupByTicketNo_complete :: [Int] -> Property prop_TxSeq_lookupByTicketNo_complete xs = - and [ case TxSeq.lookupByTicketNo txseq tn of - Just tx' -> tx == tx' - Nothing -> False - | (tx, tn, _sz) <- TxSeq.toTuples txseq ] + counterexample (show txseq) + $ conjoin + [ case TxSeq.lookupByTicketNo txseq tn of + Just tx' -> tx === tx' + Nothing -> property False + | (tx, tn, _byteSize) <- TxSeq.toTuples txseq ] where - txseq :: TxSeq Int + txseq :: TxSeq TheMeasure Int txseq = TxSeq.fromList - $ [ TxTicket x (TicketNo i) 0 | x <- xs | i <- [0..] ] + $ [ TxTicket x (TicketNo i) mempty | x <- xs | i <- [0..] ] -- | Only finds elements in the sequence prop_TxSeq_lookupByTicketNo_sound :: @@ -873,16 +899,16 @@ prop_TxSeq_lookupByTicketNo_sound smalls small = needle = abs (getSmall small) -- the identity mapping over haystack - txseq :: TxSeq Int + txseq :: TxSeq TheMeasure Int txseq = List.foldl' (TxSeq.:>) TxSeq.Empty $ map mkTicket haystack - mkTicket x = TxTicket x (mkTicketNo x) 0 + mkTicket x = TxTicket x (mkTicketNo x) mempty mkTicketNo = TicketNo . toEnum -- | Test that the 'fst' of the result of 'splitAfterTxSize' only contains -- 'TxTicket's whose summed up transaction sizes are less than or equal to --- that of the 'SizeInBytes' which the 'TxSeq' was split on. +-- that of the byte size which the 'TxSeq' was split on. prop_TxSeq_splitAfterTxSize :: TxSizeSplitTestSetup -> Property prop_TxSeq_splitAfterTxSize tss = property $ txSizeSum (TxSeq.toList before) <= tssTxSizeToSplitOn @@ -891,11 +917,11 @@ prop_TxSeq_splitAfterTxSize tss = (before, _after) = splitAfterTxSize txseq tssTxSizeToSplitOn - txseq :: TxSeq Int + txseq :: TxSeq TheMeasure Int txseq = txSizeSplitTestSetupToTxSeq tss - txSizeSum :: [TxTicket tx] -> SizeInBytes - txSizeSum = sum . map txTicketTxSizeInBytes + txSizeSum :: [TxTicket TheMeasure tx] -> TheMeasure + txSizeSum = foldMap txTicketSize -- | Test that the results of 'splitAfterTxSizeSpec', a specification of @@ -912,7 +938,7 @@ prop_TxSeq_splitAfterTxSizeSpec tss = (specBefore, specAfter) = splitAfterTxSizeSpec txseq tssTxSizeToSplitOn - txseq :: TxSeq Int + txseq :: TxSeq TheMeasure Int txseq = txSizeSplitTestSetupToTxSeq tss {------------------------------------------------------------------------------- @@ -920,14 +946,14 @@ prop_TxSeq_splitAfterTxSizeSpec tss = -------------------------------------------------------------------------------} data TxSizeSplitTestSetup = TxSizeSplitTestSetup - { tssTxSizes :: ![SizeInBytes] - , tssTxSizeToSplitOn :: !SizeInBytes + { tssTxSizes :: ![TheMeasure] + , tssTxSizeToSplitOn :: !TheMeasure } deriving Show instance Arbitrary TxSizeSplitTestSetup where arbitrary = do - let txSizeMaxBound = 10 * 1024 * 1024 -- 10MB transaction max bound - txSizes <- listOf $ choose (1, txSizeMaxBound) + let txSizeMaxBound = 10 * 1024 * 1024 -- 10 mebibyte transaction max bound + txSizes <- listOf $ choose (1, txSizeMaxBound :: Word32) let totalTxsSize = sum txSizes txSizeToSplitOn <- frequency [ (1, pure 0) @@ -936,23 +962,28 @@ instance Arbitrary TxSizeSplitTestSetup where , (1, choose (totalTxsSize + 1, totalTxsSize + 1000)) ] pure TxSizeSplitTestSetup - { tssTxSizes = map SizeInBytes txSizes - , tssTxSizeToSplitOn = SizeInBytes txSizeToSplitOn + { tssTxSizes = map (IgnoringOverflow . ByteSize32) txSizes + , tssTxSizeToSplitOn = IgnoringOverflow $ ByteSize32 txSizeToSplitOn } shrink TxSizeSplitTestSetup { tssTxSizes, tssTxSizeToSplitOn } = [ TxSizeSplitTestSetup - { tssTxSizes = tssTxSizes' - , tssTxSizeToSplitOn = tssTxSizeToSplitOn' + { tssTxSizes = map (IgnoringOverflow . ByteSize32) tssTxSizes' + , tssTxSizeToSplitOn = IgnoringOverflow $ ByteSize32 tssTxSizeToSplitOn' } - | tssTxSizes' <- shrinkList (const []) tssTxSizes - , tssTxSizeToSplitOn' <- shrinkIntegral tssTxSizeToSplitOn + | tssTxSizes' <- shrinkList (const []) [ y | IgnoringOverflow (ByteSize32 y) <- tssTxSizes ] + , tssTxSizeToSplitOn' <- shrinkIntegral x ] + where + IgnoringOverflow (ByteSize32 x) = tssTxSizeToSplitOn -- | Convert a 'TxSizeSplitTestSetup' to a 'TxSeq'. -txSizeSplitTestSetupToTxSeq :: TxSizeSplitTestSetup -> TxSeq Int +txSizeSplitTestSetupToTxSeq :: TxSizeSplitTestSetup -> TxSeq TheMeasure Int txSizeSplitTestSetupToTxSeq TxSizeSplitTestSetup { tssTxSizes } = - TxSeq.fromList [TxTicket 0 (TicketNo 0) tssTxSize | tssTxSize <- tssTxSizes] + TxSeq.fromList [ TxTicket 1 (TicketNo i) tssTxSize + | tssTxSize <- tssTxSizes + | i <- [0 ..] + ] {------------------------------------------------------------------------------- TicketNo Properties @@ -979,7 +1010,7 @@ prop_Mempool_idx_consistency :: Actions -> Property prop_Mempool_idx_consistency (Actions actions) = withTestMempool emptyTestSetup $ \testMempool@TestMempool { mempool } -> fmap conjoin $ forM actions $ \action -> do - txsInMempool <- map fst . snapshotTxs <$> + txsInMempool <- map prjTx . snapshotTxs <$> atomically (getSnapshot mempool) actionProp <- executeAction testMempool action currentAssignment <- currentTicketAssignment mempool @@ -1010,7 +1041,10 @@ prop_Mempool_idx_consistency (Actions actions) = { testLedgerState = testInitLedger , testInitialTxs = [] , testMempoolCapOverride = - MempoolCapacityBytesOverride $ MempoolCapacityBytes maxBound + MempoolCapacityBytesOverride + $ ByteSize32 + $ 1024*1024*1024 + -- There's no way this test will need more than a gibibyte. } lastOfMempoolRemoved txsInMempool = \case @@ -1109,7 +1143,7 @@ currentTicketAssignment Mempool { syncWithLedger } = do MempoolSnapshot { snapshotTxs } <- syncWithLedger return $ Map.fromList [ (ticketNo, txId (txForgetValidated tx)) - | (tx, ticketNo) <- snapshotTxs + | (tx, ticketNo, _byteSize) <- snapshotTxs ] instance Arbitrary Actions where diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs index 74d959aa32..3e79e9b983 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs @@ -20,9 +20,9 @@ import qualified Control.Tracer as Tracer import Data.Foldable (asum) import qualified Data.List as List import Data.Void (Void, vacuous) -import Data.Word (Word32) import Ouroboros.Consensus.Config.SecurityParam as Consensus import qualified Ouroboros.Consensus.HardFork.History as HardFork +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32 (..)) import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Mempool import Ouroboros.Consensus.Mempool (Mempool) import qualified Ouroboros.Consensus.Mempool as Mempool @@ -39,11 +39,11 @@ import Test.Util.TestBlock (testBlockLedgerConfigFrom, tests :: TestTree tests = testGroup "Mempool fairness" [ testCase "There is no substantial bias in added transaction sizes" $ - testTxSizeFairness TestParams { mempoolMaxCapacity = 100 - , smallTxSize = 1 - , largeTxSize = 10 + testTxSizeFairness TestParams { mempoolMaxCapacity = ByteSize32 100 + , smallTxSize = ByteSize32 1 + , largeTxSize = ByteSize32 10 , nrOftxsToCollect = 1_000 - , toleranceThreshold = 0.2 -- Somewhat arbitrarily chosen. + , toleranceThreshold = 0.2 -- Somewhat arbitrarily chosen. } ] @@ -145,10 +145,10 @@ runConcurrently = Async.runConcurrently . asum . fmap Async.Concurrently -- added before the mempool is saturated. -- data TestParams = TestParams { - mempoolMaxCapacity :: Word32 - , smallTxSize :: Word32 + mempoolMaxCapacity :: ByteSize32 + , smallTxSize :: ByteSize32 -- ^ Size of what we consider to be a small transaction. - , largeTxSize :: Word32 + , largeTxSize :: ByteSize32 -- ^ Size of what we consider to be a large transaction. , nrOftxsToCollect :: Int -- ^ How many added transactions we count. @@ -168,7 +168,7 @@ data TestParams = TestParams { adders :: TestMempool -- ^ Mempool to which transactions will be added - -> Word32 + -> ByteSize32 -- ^ Transaction size -> IO a adders mempool fixedTxSize = vacuous $ runConcurrently $ fmap adder [0..2] @@ -215,5 +215,7 @@ getTxsInSnapshot :: Mempool IO TestBlock -> STM IO [Mempool.GenTx TestBlock] getTxsInSnapshot mempool = fmap txsInSnapshot $ Mempool.getSnapshot mempool where - txsInSnapshot = fmap (Mempool.txForgetValidated . fst) + txsInSnapshot = fmap prjTx . Mempool.snapshotTxs + + prjTx (a, _b, _c) = Mempool.txForgetValidated a :: Mempool.GenTx TestBlock diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs index ad1bd7d1f7..1b1ab36aad 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs @@ -9,14 +9,12 @@ module Test.Consensus.Mempool.Fairness.TestBlock ( TestBlock , Tx - , genTxSize , mkGenTx , txSize , unGenTx ) where import Control.DeepSeq (NFData) -import Data.Word (Word32) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import qualified Ouroboros.Consensus.Block as Block @@ -36,7 +34,7 @@ type TestBlock = TestBlockWith Tx -- We do need to keep track of the transaction id. -- -- All transactions will be accepted by the mempool. -data Tx = Tx { txNumber :: Int, txSize :: Word32 } +data Tx = Tx { txNumber :: Int, txSize :: Ledger.ByteSize32 } deriving stock (Eq, Ord, Generic, Show) deriving anyclass (NoThunks, NFData) @@ -80,10 +78,7 @@ newtype instance Ledger.TxId (Ledger.GenTx TestBlock) = TestBlockTxId Tx instance Ledger.HasTxId (Ledger.GenTx TestBlock) where txId (TestBlockGenTx tx) = TestBlockTxId tx -genTxSize :: Ledger.GenTx TestBlock -> Word32 -genTxSize = txSize . unGenTx - -mkGenTx :: Int -> Word32 -> Ledger.GenTx TestBlock +mkGenTx :: Int -> Ledger.ByteSize32 -> Ledger.GenTx TestBlock mkGenTx anId aSize = TestBlockGenTx $ Tx { txNumber = anId, txSize = aSize } instance Ledger.LedgerSupportsMempool TestBlock where @@ -91,14 +86,17 @@ instance Ledger.LedgerSupportsMempool TestBlock where reapplyTx _cfg _slot _gtx gst = pure gst - txsMaxBytes _ = error "The tests should override this value" - -- The tests should be in control of the mempool capacity, - -- since the judgement on whether the mempool is fair depends - -- on this parameter. + txForgetValidated (ValidatedGenTx tx) = tx + +instance Ledger.TxLimits TestBlock where + type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 - txInBlockSize = txSize . unGenTx + blockCapacityTxMeasure _cfg _st = + -- The tests will override this value. By using 1, @computeMempoolCapacity@ + -- can be exactly what each test requests. + Ledger.IgnoringOverflow $ Ledger.ByteSize32 1 - txForgetValidated (ValidatedGenTx tx) = tx + txMeasure _cfg _st = pure . Ledger.IgnoringOverflow . txSize . unGenTx {------------------------------------------------------------------------------- Ledger support