diff --git a/ouroboros-consensus-cardano/changelog.d/20240711_064942_nick.frisby_consolidate_txlimits.md b/ouroboros-consensus-cardano/changelog.d/20240711_064942_nick.frisby_consolidate_txlimits.md new file mode 100644 index 0000000000..ada8df1474 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20240711_064942_nick.frisby_consolidate_txlimits.md @@ -0,0 +1,23 @@ + + +### Patch + +- Updates for the `TxLimits` mempool consolidation. + +### Non-Breaking + +- Do not check transaction sizes in the forging functions; simply include all + given transactions. + +- Remove the hotfix Babbage mempool checks. + + diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 4b151442b0..55fc8e1e6b 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 4c3c0fdc75..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,18 +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 - txRefScriptSize _ _ _ = 0 + 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/Eras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs index bc3137ff54..10be05be15 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -5,7 +5,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -29,7 +28,6 @@ module Ouroboros.Consensus.Shelley.Eras ( , StandardMary , StandardShelley -- * Shelley-based era - , BabbageTxDict (..) , ConwayEraGovDict (..) , ShelleyBasedEra (..) , WrapTx (..) @@ -47,7 +45,6 @@ import Cardano.Ledger.Alonzo (AlonzoEra) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo import qualified Cardano.Ledger.Alonzo.Translation as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo -import qualified Cardano.Ledger.Api as SL import qualified Cardano.Ledger.Api.Era as L import Cardano.Ledger.Babbage (BabbageEra) import qualified Cardano.Ledger.Babbage.Rules as Babbage @@ -60,8 +57,6 @@ import qualified Cardano.Ledger.Conway.Rules as Conway import qualified Cardano.Ledger.Conway.Rules as SL (ConwayLedgerPredFailure (..)) import qualified Cardano.Ledger.Conway.Translation as Conway -import qualified Cardano.Ledger.Conway.Tx as SL -import qualified Cardano.Ledger.Conway.UTxO as SL import Cardano.Ledger.Core as Core import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Keys (DSignable, Hash) @@ -73,13 +68,11 @@ import Cardano.Ledger.Shelley.Core as Core import qualified Cardano.Ledger.Shelley.LedgerState as SL import qualified Cardano.Ledger.Shelley.Rules as SL import qualified Cardano.Ledger.Shelley.Transition as SL -import qualified Cardano.Ledger.Val as SL import qualified Cardano.Protocol.TPraos.API as SL import Control.Monad.Except import Control.State.Transition (PredicateFailure) import Data.Data (Proxy (Proxy)) import Data.List.NonEmpty (NonEmpty ((:|))) -import Lens.Micro ((^.)) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Ledger.SupportsMempool (WhetherToIntervene (..)) @@ -169,16 +162,6 @@ class ( Core.EraSegWits era -- | Whether the era has an instance of 'CG.ConwayEraGov' getConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era) - getBabbageTxDict :: proxy era -> Maybe (BabbageTxDict era) - -data BabbageTxDict era where - BabbageTxDict :: - SL.BabbageEraTxBody era - => (Integer -> Integer -> SL.ApplyTxError era) - -- ^ Construct an arbitrary ledger error with two integers as its - -- payload. - -> BabbageTxDict era - data ConwayEraGovDict era where ConwayEraGovDict :: CG.ConwayEraGov era => ConwayEraGovDict era @@ -189,7 +172,7 @@ isBeforeConway _ = -- | The default implementation of 'applyShelleyBasedTx', a thin wrapper around -- 'SL.applyTx' defaultApplyShelleyBasedTx :: - forall era. ShelleyBasedEra era + ShelleyBasedEra era => SL.Globals -> SL.LedgerEnv era -> SL.LedgerState era @@ -201,55 +184,11 @@ defaultApplyShelleyBasedTx :: , SL.Validated (Core.Tx era) ) defaultApplyShelleyBasedTx globals ledgerEnv mempoolState _wti tx = do - refScriptPredicate SL.applyTx globals ledgerEnv mempoolState tx - where - refScriptPredicate = case getBabbageTxDict (Proxy @era) of - Nothing -> pure () - Just (BabbageTxDict mkError) - -- The ledger rules of Conway (and later eras) already handle ref - -- scripts appropriately, so we only need to perform the checks below - -- for Babbage. - | not $ isBeforeConway (Proxy @era) - -> pure () - -- Reject it if it has more than 100 kibibytes of ref script. - | refScriptsSize > totalRefScriptsSizeLimit - -> throwError $ mkError - -- As we are reusing an existing error message, we add a large - -- number to make users running into this are productively irritated - -- and post this error message somewhere where they can receive - -- help/context. - (toInteger refScriptsSize + 1_000_000_000) - (toInteger totalRefScriptsSizeLimit + 1_000_000_000) - -- Reject it if it has more than 50 kibibytes of ref script and does not - -- satisfy an additional fee as calculated in the table below. - | refScriptsSize > freeOfChargeRefScriptsBytes - , actualFee < expectedFee - -> throwError $ mkError - -- See above for why we add a large constant. - (SL.unCoin actualFee + 100_000_000) - (SL.unCoin expectedFee + 100_000_000) - | otherwise -> pure () - where - totalRefScriptsSizeLimit :: Int - totalRefScriptsSizeLimit = 100 * 1024 - - freeOfChargeRefScriptsBytes :: Int - freeOfChargeRefScriptsBytes = 50 * 1024 - - actualFee = tx ^. SL.bodyTxL . SL.feeTxBodyL - expectedFee = minFee SL.<+> refScriptsFee - where - minFee = SL.getMinFeeTx (SL.ledgerPp ledgerEnv) tx 0 - refScriptsFee = SL.tierRefScriptFee 1.2 25600 15 refScriptsSize - - refScriptsSize = SL.txNonDistinctRefScriptsSize utxo tx - - utxo = SL.utxosUtxo . SL.lsUTxOState $ mempoolState defaultGetConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era) defaultGetConwayEraGovDict _ = Nothing @@ -260,57 +199,34 @@ instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) getConwayEraGovDict = defaultGetConwayEraGovDict - getBabbageTxDict _ = Nothing - instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) => ShelleyBasedEra (AllegraEra c) where applyShelleyBasedTx = defaultApplyShelleyBasedTx getConwayEraGovDict = defaultGetConwayEraGovDict - getBabbageTxDict _ = Nothing - instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) => ShelleyBasedEra (MaryEra c) where applyShelleyBasedTx = defaultApplyShelleyBasedTx getConwayEraGovDict = defaultGetConwayEraGovDict - getBabbageTxDict _ = Nothing - instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody)) => ShelleyBasedEra (AlonzoEra c) where applyShelleyBasedTx = applyAlonzoBasedTx getConwayEraGovDict = defaultGetConwayEraGovDict - getBabbageTxDict _ = Nothing - instance (Praos.PraosCrypto c) => ShelleyBasedEra (BabbageEra c) where applyShelleyBasedTx = applyAlonzoBasedTx getConwayEraGovDict = defaultGetConwayEraGovDict - getBabbageTxDict _ = Just $ BabbageTxDict $ \a b -> - SL.ApplyTxError - $ pure - $ SL.UtxowFailure - $ Babbage.UtxoFailure - $ Babbage.AlonzoInBabbageUtxoPredFailure - $ Alonzo.MaxTxSizeUTxO a b - instance (Praos.PraosCrypto c) => ShelleyBasedEra (ConwayEra c) where applyShelleyBasedTx = applyAlonzoBasedTx getConwayEraGovDict _ = Just ConwayEraGovDict - getBabbageTxDict _ = Just $ BabbageTxDict $ \a b -> - SL.ApplyTxError - $ pure - $ Conway.ConwayUtxowFailure - $ Conway.UtxoFailure - $ Conway.MaxTxSizeUTxO a b - applyAlonzoBasedTx :: forall era. ( ShelleyBasedEra era, SupportsTwoPhaseValidation era, 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 9cd18a66a6..38c7f24db2 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,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -18,12 +18,14 @@ {-# 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 (..) , TxId (..) , Validated (..) - , WithTop (..) , fixedBlockBodyOverhead , mkShelleyTx , mkShelleyValidatedTx @@ -35,28 +37,35 @@ 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.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 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 (BoundedMeasure, Measure) -import qualified Data.Measure as Measure +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 ((^.)) @@ -64,7 +73,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 @@ -130,7 +138,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 @@ -138,25 +146,8 @@ 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) - txRefScriptSize _cfg st (ShelleyTx _ tx) = case getBabbageTxDict (Proxy @era) of - Nothing -> 0 - Just BabbageTxDict{} -> SL.txNonDistinctRefScriptsSize utxo tx - where - utxo = SL.getUTxO . tickedShelleyLedgerState $ st - mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era) mkShelleyTx tx = ShelleyTx (SL.txIdTxBody @era (tx ^. bodyTxL)) tx @@ -296,134 +287,307 @@ 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 + +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 - , exUnits :: !(ExUnits' (WithTop Natural)) + byteSize :: !(IgnoringOverflow ByteSize32) + , exUnits :: !(ExUnits' Natural) } deriving stock (Eq, Generic, Show) - deriving (BoundedMeasure, Measure) + deriving anyclass (NoThunks) + deriving (Measure) via (InstantiatedAt Generic AlonzoMeasure) -fromExUnits :: ExUnits -> ExUnits' (WithTop Natural) -fromExUnits = fmap NotTop . unWrapExUnits +instance HasByteSize AlonzoMeasure where + txMeasureByteSize = unIgnoringOverflow . byteSize -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 +fromExUnits :: ExUnits -> ExUnits' Natural +fromExUnits = unWrapExUnits -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 (BoundedMeasure, Measure) + 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 - txsBlockCapacity st = - ConwayMeasure { - alonzoMeasure = txsBlockCapacityAlonzo st - , refScriptsSize = Mempool.ByteSize $ fromIntegral $ - -- For post-Conway eras, this will become a protocol parameter. - SL.maxRefScriptSizePerBlock - } + refScriptBytes = + validateMaybe (txRefScriptsSizeTooBig limit txsz) $ do + guard $ txsz <= limit + Just $ IgnoringOverflow $ ByteSize32 $ fromIntegral txsz -{------------------------------------------------------------------------------- - WithTop --------------------------------------------------------------------------------} +class TxRefScriptsSizeTooBig era where + txRefScriptsSizeTooBig :: Int -> Int -> SL.ApplyTxError era --- | Add a unique top element to a lattice. --- --- TODO This should be relocated to `cardano-base:Data.Measure'. -data WithTop a = NotTop a | Top - deriving (Eq, Generic, Show) - -instance Ord a => Ord (WithTop a) where - compare = curry $ \case - (Top , Top ) -> EQ - (Top , _ ) -> GT - (_ , Top ) -> LT - (NotTop l, NotTop r) -> compare l r - -instance Measure a => Measure (WithTop a) where - zero = NotTop Measure.zero - plus = curry $ \case - (Top , _ ) -> Top - (_ , Top ) -> Top - (NotTop l, NotTop r) -> NotTop $ Measure.plus l r - min = curry $ \case - (Top , r ) -> r - (l , Top ) -> l - (NotTop l, NotTop r) -> NotTop $ Measure.min l r - max = curry $ \case - (Top , _ ) -> Top - (_ , Top ) -> Top - (NotTop l, NotTop r) -> NotTop $ Measure.max l r - -instance Measure a => BoundedMeasure (WithTop a) where - maxBound = Top +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') = + (\x -> ConwayMeasure x refScriptBytes) <$> txMeasureAlonzo st tx + where + utxo = SL.getUTxO $ tickedShelleyLedgerState st + + -- The Babbage rules should have checked this ref script size against a + -- limit, but they did not. Now that Cardano @mainnet@ is in Conway, that + -- omission is no longer an attack vector. Any other chain intending to + -- ever use Babbage as its current era ought to patch this. + refScriptBytes = + IgnoringOverflow + $ ByteSize32 + $ fromIntegral (SL.txNonDistinctRefScriptsSize utxo tx' :: Int) + +-- | 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 e4e4c69b4c..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,10 +51,12 @@ instance LedgerSupportsMempool ByronSpecBlock where fmap fst $ applyTx cfg DoNotIntervene slot (forgetValidatedByronSpecGenTx vtx) st - -- Dummy values, as these are not used in practice. - txsMaxBytes = const maxBound - txInBlockSize = const 0 - txForgetValidated = forgetValidatedByronSpecGenTx - txRefScriptSize _cfg _tlst _tx = 0 +instance TxLimits ByronSpecBlock where + type TxMeasure ByronSpecBlock = IgnoringOverflow ByteSize32 + + -- Dummy values, as these are not used in practice. + blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 1 + + 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 b56ee74d71..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,10 +740,12 @@ 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 - (SizeInBytes . LedgerSupportsMempool.txInBlockSize) void $ processAll db registry GetBlock startFrom limit Nothing (process howManyBlocks ref mempool) pure Nothing 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 7b8498adb5..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 { @@ -86,7 +87,6 @@ tests = mempool <- Mocked.openMockedMempool capcityBytesOverride tracer - (SizeInBytes . LedgerSupportsMempool.txInBlockSize) mempoolParams mempool `should_process` [ _137 ] 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/changelog.d/20240711_064938_nick.frisby_consolidate_txlimits.md b/ouroboros-consensus-diffusion/changelog.d/20240711_064938_nick.frisby_consolidate_txlimits.md new file mode 100644 index 0000000000..f5b93fa410 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20240711_064938_nick.frisby_consolidate_txlimits.md @@ -0,0 +1,23 @@ + + + +### Patch + +- Updates for the `TxLimits` mempool consolidation. + + + 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 12b356ed66..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 @@ -380,7 +380,6 @@ initInternalState NodeKernelArgs { tracers, chainDB, registry, cfg (configLedger cfg) mempoolCapacityOverride (mempoolTracer tracers) - (SizeInBytes . txInBlockSize) fetchClientRegistry <- newFetchClientRegistry @@ -545,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) @@ -733,8 +736,11 @@ getMempoolReader mempool = MempoolReader.TxSubmissionMempoolReader snapshotHasTx } = MempoolReader.MempoolSnapshot { mempoolTxIdsAfter = \idx -> - [ (txId (txForgetValidated tx), idx', getTxSize mempool (txForgetValidated tx)) - | (tx, idx') <- 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 a98dfefecc..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,12 +326,12 @@ instance LedgerSupportsMempool BlockA where reapplyTx cfg slot = fmap fst .: (applyTx cfg DoNotIntervene slot . forgetValidatedGenTxA) - txsMaxBytes _ = maxBound - txInBlockSize _ = 0 - txForgetValidated = forgetValidatedGenTxA - txRefScriptSize _cfg _tlst _tx = 0 +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) 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 e68570ddbe..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,12 +262,12 @@ instance LedgerSupportsMempool BlockB where applyTx = \_ _ _wti tx -> case tx of {} reapplyTx = \_ _ vtx -> case vtx of {} - txsMaxBytes _ = maxBound - txInBlockSize _ = 0 - txForgetValidated = \case {} - txRefScriptSize _cfg _tlst _tx = 0 +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) 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 e2becb2cfa..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,15 +146,17 @@ instance Ledger.LedgerSupportsMempool TestBlock where fst <$> Ledger.applyTx cfg Ledger.DoNotIntervene slot genTx tickedSt -- FIXME: it is ok to use 'DoNotIntervene' here? - -- 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 + txForgetValidated (ValidatedGenTx tx) = tx - txInBlockSize = getSizeInBytes . txSize +instance Ledger.TxLimits TestBlock where + type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 - txForgetValidated (ValidatedGenTx tx) = tx + -- 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'. + blockCapacityTxMeasure _cfg _st = + Ledger.IgnoringOverflow $ Ledger.ByteSize32 20 - txRefScriptSize _cfg _tlst _tx = 0 + 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 bcc45a2db0..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,13 +134,10 @@ 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 - TestBlock.txSize Mocked.MempoolAndModelParams { Mocked.immpInitialState = TestBlock.initialLedgerState , Mocked.immpLedgerConfig = TestBlock.sampleLedgerConfig diff --git a/ouroboros-consensus/changelog.d/20240711_064934_nick.frisby_consolidate_txlimits.md b/ouroboros-consensus/changelog.d/20240711_064934_nick.frisby_consolidate_txlimits.md new file mode 100644 index 0000000000..b5ff7cbaee --- /dev/null +++ b/ouroboros-consensus/changelog.d/20240711_064934_nick.frisby_consolidate_txlimits.md @@ -0,0 +1,38 @@ + + + + + +### Breaking + +- Consolidate `TxLimits` in the mempool. + - Remove `Mempool.`getTxSize`; the snapshot interface contains byte sizes + now. + + - Transaction size, block capacity, and mempool capacity are + multi-dimensional vectors (`ExUnits`, etc), instead of merely bytes: + `TxMeasure`. + + - A transaction cannot be added if it would push any component of the size + over that component of the mempool capacity. + + - The mempool capacity override is still specified in terms of bytes, but + the magnitude is interpreted via division as a block count, rounded up. + +- Pass a correctly-sized prefix of the mempool to the forging functions, + instead of its entire contents. The mempool's finger tree is best way to find + that cutoff. diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index f9094400e2..26eb7af350 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 b18e3fb6ac..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 @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -26,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 (..)) @@ -47,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 @@ -106,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 @@ -125,39 +116,79 @@ instance CanHardFork xs => LedgerSupportsMempool (HardForkBlock xs) where . getOneEraValidatedGenTx . getHardForkValidatedGenTx - txRefScriptSize cfg st tx = case matchPolyTx injs tx' hardForkState of - Left {} -> - -- This is ugly/adhoc, but fine, as in the mempool, we only call - -- txRefScriptSize after applyTx (which internall also calls - -- matchPolyTx), so this case is unreachable. - 0 - Right matched -> - hcollapse - $ hczipWith proxySingle - (\(WrapLedgerConfig eraCfg) (Pair eraTx (Comp eraSt)) -> - K $ txRefScriptSize eraCfg eraSt eraTx) - cfgs - (State.tip matched) +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 - HardForkLedgerConfig { - hardForkLedgerConfigPerEra - , hardForkLedgerConfigShape - } = cfg - TickedHardForkLedgerState transition hardForkState = st - tx' = getOneEraGenTx . getHardForkGenTx $ tx + 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 - cfgs = hcmap proxySingle (completeLedgerConfig'' ei) pcfgs 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) + 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 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 bfcbd06154..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,11 +622,17 @@ instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where , vDualGenTxBridge } = vtx - txRefScriptSize cfg st tx = - txRefScriptSize - (dualLedgerConfigMain cfg) - (tickedDualLedgerStateMain st) - (dualGenTxMain tx) +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 { 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 336d1c1403..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,39 +111,9 @@ 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 - txRefScriptSize :: LedgerConfig blk -> TickedLedgerState blk -> GenTx blk -> Int - -- | A generalized transaction, 'GenTx', identifier. data family TxId tx :: Type @@ -168,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 3a321ce7a4..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,22 +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 - - -- | Return the post-serialisation size in bytes of a 'GenTx'. - , getTxSize :: GenTx blk -> SizeInBytes + , getCapacity :: STM m (TxMeasure blk) } {------------------------------------------------------------------------------- @@ -330,12 +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)] + , snapshotTxsAfter :: + 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 68221cd84e..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.Measure (BoundedMeasure, Measure) +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 BoundedMeasure (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 (BoundedMeasure, 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 3448785e98..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 @@ -13,7 +13,6 @@ module Ouroboros.Consensus.Mempool.Impl.Common ( -- * Internal state InternalState (..) , isMempoolSize - , isTotalRefScriptSize -- * Mempool environment , MempoolEnv (..) , initMempoolEnv @@ -74,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. -- @@ -124,40 +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 - -isTotalRefScriptSize :: InternalState blk -> Int -isTotalRefScriptSize = TxSeq.toRefScriptSize . 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 } {------------------------------------------------------------------------------- @@ -191,7 +192,6 @@ data MempoolEnv m blk = MempoolEnv { , mpEnvAddTxsRemoteFifo :: MVar m () , mpEnvAddTxsAllFifo :: MVar m () , mpEnvTracer :: Tracer m (TraceEventMempool blk) - , mpEnvTxSize :: GenTx blk -> SizeInBytes , mpEnvCapacityOverride :: MempoolCapacityBytesOverride } @@ -204,12 +204,13 @@ initMempoolEnv :: ( IOLike m -> LedgerConfig blk -> MempoolCapacityBytesOverride -> Tracer m (TraceEventMempool blk) - -> (GenTx blk -> SizeInBytes) -> m (MempoolEnv m blk) -initMempoolEnv ledgerInterface cfg capacityOverride tracer txSize = do +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 @@ -219,7 +220,6 @@ initMempoolEnv ledgerInterface cfg capacityOverride tracer txSize = do , mpEnvAddTxsRemoteFifo = addTxRemoteFifo , mpEnvAddTxsAllFifo = addTxAllFifo , mpEnvTracer = tracer - , mpEnvTxSize = txSize , mpEnvCapacityOverride = capacityOverride } @@ -261,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) @@ -304,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 = @@ -327,42 +327,39 @@ extendVRPrevApplied cfg txTicket vr = -- again. extendVRNew :: (LedgerSupportsMempool blk, HasTxId (GenTx blk)) => LedgerConfig blk - -> (GenTx blk -> SizeInBytes) -> WhetherToIntervene -> GenTx blk -> ValidationResult (GenTx blk) blk - -> ( Either (ApplyTxErr blk) (Validated (GenTx blk)) - , ValidationResult (GenTx blk) blk - ) -extendVRNew cfg txSize 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 (txSize tx) - (txRefScriptSize cfg vrAfter tx) - , 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 + 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 @@ -417,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 { @@ -429,32 +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)] + -> [(Validated (GenTx blk), TicketNo, ByteSize32)] implSnapshotGetTxs = flip implSnapshotGetTxsAfter TxSeq.zeroTicketNo implSnapshotGetTxsAfter :: InternalState blk -> TicketNo - -> [(Validated (GenTx blk), TicketNo)] + -> [(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 @@ -503,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 @@ -511,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/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs index 685aebdf5c..2ca0bad909 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs @@ -39,10 +39,9 @@ openMempool :: -> LedgerConfig blk -> MempoolCapacityBytesOverride -> Tracer m (TraceEventMempool blk) - -> (GenTx blk -> SizeInBytes) -> m (Mempool m blk) -openMempool registry ledger cfg capacityOverride tracer txSize = do - env <- initMempoolEnv ledger cfg capacityOverride tracer txSize +openMempool registry ledger cfg capacityOverride tracer = do + env <- initMempoolEnv ledger cfg capacityOverride tracer forkSyncStateOnTipPointChange registry env return $ mkMempool env @@ -91,10 +90,9 @@ openMempoolWithoutSyncThread :: -> LedgerConfig blk -> MempoolCapacityBytesOverride -> Tracer m (TraceEventMempool blk) - -> (GenTx blk -> SizeInBytes) -> m (Mempool m blk) -openMempoolWithoutSyncThread ledger cfg capacityOverride tracer txSize = - mkMempool <$> initMempoolEnv ledger cfg capacityOverride tracer txSize +openMempoolWithoutSyncThread ledger cfg capacityOverride tracer = + mkMempool <$> initMempoolEnv ledger cfg capacityOverride tracer mkMempool :: ( IOLike m @@ -104,19 +102,17 @@ mkMempool :: ) => MempoolEnv m blk -> Mempool m blk mkMempool mpEnv = Mempool - { addTx = implAddTx istate remoteFifo allFifo cfg txSize trcr + { addTx = implAddTx istate remoteFifo allFifo cfg trcr , removeTxs = implRemoveTxs mpEnv , syncWithLedger = implSyncWithLedger mpEnv , getSnapshot = snapshotFromIS <$> readTVar istate , getSnapshotFor = \fls -> pureGetSnapshotFor cfg fls co <$> readTVar istate , getCapacity = isCapacity <$> readTVar istate - , getTxSize = txSize } where MempoolEnv { mpEnvStateVar = istate , mpEnvAddTxsRemoteFifo = remoteFifo , mpEnvAddTxsAllFifo = allFifo , mpEnvLedgerCfg = cfg - , mpEnvTxSize = txSize , mpEnvTracer = trcr , mpEnvCapacityOverride = co } = mpEnv 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 4b0e4c11bb..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,22 +22,24 @@ module Ouroboros.Consensus.Mempool.TxSeq ( , splitAfterTicketNo , splitAfterTxSize , toList - , toMempoolSize - , toRefScriptSize + , 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 @@ -56,15 +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. - , txTicketRefScriptSize :: !Int + , txTicketSize :: !sz + -- ^ The size of 'txTicketTx'. } deriving (Eq, Show, Generic, NoThunks) -- | The mempool is a sequence of transactions with their ticket numbers and @@ -83,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 @@ -103,47 +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, - mRefScriptSize :: !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 trssz) = TxSeqMeasure tno tno tsz 1 trssz +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) - (mRefScriptSize vl + mRefScriptSize vr) - -instance Monoid TxSeqMeasure where - mempty = TxSeqMeasure maxBound minBound 0 0 0 + (mCount vl + mCount vr) + (mMinTicket vl `min` mMinTicket vr) + (mMaxTicket vl `max` mMaxTicket vr) + (mSize vl `Measure.plus` mSize vr) + +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 @@ -151,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 @@ -160,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 :>, :< @@ -168,34 +180,41 @@ 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 - FingerTree.Position _ (TxTicket tx n' _ _) _ | n' == n -> Just tx - _ -> Nothing + FingerTree.Position _ (TxTicket tx n' _) _ | n' == n -> Just tx + _ -> Nothing -- | \( O(\log(n)) \). Split the sequence of transactions into two parts -- based on the given 'TicketNo'. The first part has transactions with tickets -- 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'. @@ -204,52 +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)] +-- associated 'TicketNo's and 'ByteSize32's. +toTuples :: HasByteSize sz => TxSeq sz tx -> [(tx, TicketNo, ByteSize32)] toTuples (TxSeq ftree) = fmap - (\ticket -> (txTicketTx ticket, txTicketNo ticket)) + (\ticket -> + ( txTicketTx ticket + , txTicketNo 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 - } - where - TxSeqMeasure { mSizeBytes, mSize } = FingerTree.measure ftree - -toRefScriptSize :: TxSeq tx -> Int -toRefScriptSize (TxSeq ftree) = mRefScriptSize +-- | \( O(1) \). Return the total size of the given 'TxSeq'. +toSize :: Measure sz => TxSeq sz tx -> sz +toSize (TxSeq ftree) = mSize where - TxSeqMeasure { mRefScriptSize } = 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 dec61a9ed9..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 @@ -44,16 +46,13 @@ implAddTx :: -- ^ The FIFO for all remote peers and local clients -> LedgerConfig blk -- ^ The configuration of the ledger. - -> (GenTx blk -> SizeInBytes) - -- ^ The function to calculate the size of a - -- transaction. -> Tracer m (TraceEventMempool blk) -> AddTxOnBehalfOf -- ^ Whether we're acting on behalf of a remote peer or a local client. -> GenTx blk -- ^ The transaction to add to the mempool. -> m (MempoolAddTxResult blk) -implAddTx istate remoteFifo allFifo cfg txSize trcr onbehalf tx = +implAddTx istate remoteFifo allFifo cfg trcr onbehalf tx = -- To ensure fair behaviour between threads that are trying to add -- transactions, we make them all queue in a fifo. Only the one at the head -- of the queue gets to actually wait for space to get freed up in the @@ -87,14 +86,14 @@ implAddTx istate remoteFifo allFifo cfg txSize trcr onbehalf tx = where implAddTx' = do (result, ev) <- atomically $ do - outcome <- implTryAddTx istate cfg txSize + outcome <- implTryAddTx istate cfg (whetherToIntervene onbehalf) tx case outcome of 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 @@ -105,9 +104,8 @@ implAddTx istate remoteFifo allFifo cfg txSize 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)) @@ -127,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. @@ -144,83 +142,110 @@ implTryAddTx :: -- ^ The InternalState TVar. -> LedgerConfig blk -- ^ The configuration of the ledger. - -> (GenTx blk -> SizeInBytes) - -- ^ The function to calculate the size of a - -- transaction. -> WhetherToIntervene -> GenTx blk -- ^ The transaction to add to the mempool. -> STM m (TryAddTx blk) -implTryAddTx istate cfg txSize wti tx = do +implTryAddTx istate cfg wti tx = do is <- readTVar istate - let outcome = pureTryAddTx cfg txSize wti tx is + 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) ) => LedgerCfg (LedgerState blk) -- ^ The ledger configuration. - -> (GenTx blk -> SizeInBytes) - -- ^ The function to claculate the size of a transaction. -> WhetherToIntervene -> GenTx blk -- ^ The transaction to add to the mempool. -> InternalState blk -- ^ The current internal state of the mempool. -> TryAddTx blk -pureTryAddTx cfg txSize wti tx is - -- We add the transaction if there is at least one byte free left in the - -- mempool, and... - | let curSize = msNumBytes $ isMempoolSize is - , curSize < getMempoolCapacityBytes (isCapacity is) - -- ... if the mempool will have at most 1 mebibyte of ref scripts. - , let curTotalRefScriptSize = isTotalRefScriptSize is - newTxRefScriptSize = txRefScriptSize cfg (isLedgerState is) tx - maxTotalRefScriptSize = 1024 * 1024 -- 1MiB - -- In case the tx exceeds the per-tx limit, let it be rejected by tx - -- validation (such that we are not blocked here forever/for a long - -- time). - -- - -- For Babbage, this is 100KiB (see @totalRefScriptsSizeLimit@ in - -- "Ouroboros.Consensus.Shelley.Eras"), and for Conway, this is 200KiB - -- (see @maxRefScriptSizePerTx@ in "Cardano.Ledger.Conway.Rules.Ledger"). - txRefScriptSizeTooLarge = newTxRefScriptSize Prelude.> 200 * 1024 - -- There is a potential overflow in this check, causing it to be 'False' - -- erroneously. In practice, this can only happen if - -- 'newTxRefScriptSize' is huge, in which case 'txRefScriptSizeTooLarge' - -- is 'True', so the disjunction below is still 'True'. - mempoolStaysBelowCapacity = - curTotalRefScriptSize + newTxRefScriptSize Prelude.<= maxTotalRefScriptSize - , txRefScriptSizeTooLarge || mempoolStaysBelowCapacity - = - 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) @@ -229,11 +254,20 @@ pureTryAddTx cfg txSize wti tx is err (isMempoolSize is) ) - | otherwise - = NoSpaceLeft - where - (eVtx, vr) = extendVRNew cfg txSize 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 e05161aa9c..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 ( @@ -58,10 +59,9 @@ openMockedMempool :: ) => Mempool.MempoolCapacityBytesOverride -> Tracer IO (Mempool.TraceEventMempool blk) - -> (Ledger.GenTx blk -> Mempool.SizeInBytes) -> InitialMempoolAndModelParams blk -> IO (MockedMempool IO blk) -openMockedMempool capacityOverride tracer txSizeImpl initialParams = do +openMockedMempool capacityOverride tracer initialParams = do currentLedgerStateTVar <- newTVarIO (immpInitialState initialParams) let ledgerItf = Mempool.LedgerInterface { Mempool.getCurrentLedgerState = readTVar currentLedgerStateTVar @@ -71,7 +71,6 @@ openMockedMempool capacityOverride tracer txSizeImpl initialParams = do (immpLedgerConfig initialParams) capacityOverride tracer - txSizeImpl pure MockedMempool { getLedgerInterface = ledgerItf , getLedgerStateTVar = currentLedgerStateTVar @@ -98,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 fa5f49c1a9..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,14 +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 - - txForgetValidated = forgetValidatedSimpleGenTx + -- + -- But not 'maxbound'!, since the mempool sometimes holds multiple blocks worth. + blockCapacityTxMeasure _cfg _st = IgnoringOverflow simpleBlockCapacity + txMeasure _cfg _st = pure . IgnoringOverflow . txSize - txRefScriptSize _cfg _tlst _tx = 0 +simpleBlockCapacity :: ByteSize32 +simpleBlockCapacity = ByteSize32 512 newtype instance TxId (GenTx (SimpleBlock c ext)) = SimpleGenTxId { unSimpleGenTxId :: Mock.TxId @@ -482,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 126b012ebb..14cea0bb2d 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 @@ -64,7 +65,6 @@ import Ouroboros.Consensus.Util (repeatedly, repeatedlyM, safeMaximumOn, (.:)) import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Network.SizeInBytes import Test.QuickCheck hiding (elements) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -95,6 +95,8 @@ tests = testGroup "Mempool" , testProperty "removeTxs [..] == forM [..] removeTxs" prop_Mempool_semigroup_removeTxs ] +type TheMeasure = IgnoringOverflow ByteSize32 + {------------------------------------------------------------------------------- Mempool Implementation Properties -------------------------------------------------------------------------------} @@ -115,7 +117,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. @@ -154,10 +156,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 @@ -177,7 +179,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) @@ -202,8 +204,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 @@ -211,12 +213,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 @@ -259,7 +269,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 @@ -290,6 +300,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 -------------------------------------------------------------------------------} @@ -329,32 +344,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 @@ -366,34 +379,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 @@ -590,15 +607,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 } @@ -734,7 +755,6 @@ withTestMempool setup@TestSetup {..} prop = testLedgerConfig testMempoolCapOverride tracer - (SizeInBytes . txSize) result <- addTxs mempool testInitialTxs -- the invalid transactions are reported in the same order they were -- added, so the first error is not the result of a cascade @@ -796,7 +816,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 +836,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 +862,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) <- 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 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 +898,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 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 +916,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 +937,7 @@ prop_TxSeq_splitAfterTxSizeSpec tss = (specBefore, specAfter) = splitAfterTxSizeSpec txseq tssTxSizeToSplitOn - txseq :: TxSeq Int + txseq :: TxSeq TheMeasure Int txseq = txSizeSplitTestSetupToTxSeq tss {------------------------------------------------------------------------------- @@ -920,14 +945,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 +961,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 0 | tssTxSize <- tssTxSizes] + TxSeq.fromList [ TxTicket 1 (TicketNo i) tssTxSize + | tssTxSize <- tssTxSizes + | i <- [0 ..] + ] {------------------------------------------------------------------------------- TicketNo Properties @@ -979,7 +1009,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 +1040,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 +1142,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 a8a50fb32b..a66a9898c7 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs @@ -20,15 +20,14 @@ 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 import qualified Ouroboros.Consensus.Mempool.Capacity as Mempool import Ouroboros.Consensus.Util.IOLike (STM, atomically, retry) -import Ouroboros.Network.SizeInBytes import System.Random (randomIO) import Test.Consensus.Mempool.Fairness.TestBlock import Test.Tasty (TestTree, testGroup) @@ -39,11 +38,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. } ] @@ -93,7 +92,6 @@ testTxSizeFairness TestParams { mempoolMaxCapacity, smallTxSize, largeTxSize, nr (testBlockLedgerConfigFrom eraParams) (Mempool.mkCapacityBytesOverride mempoolMaxCapacity) Tracer.nullTracer - (SizeInBytes . genTxSize) ---------------------------------------------------------------------------- -- Add and collect transactions @@ -146,10 +144,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. @@ -169,7 +167,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] @@ -216,5 +214,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 39a1615329..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,16 +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 - txInBlockSize = txSize . unGenTx +instance Ledger.TxLimits TestBlock where + type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 - txForgetValidated (ValidatedGenTx tx) = tx + 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 - txRefScriptSize _cfg _tlst _tx = 0 + txMeasure _cfg _st = pure . Ledger.IgnoringOverflow . txSize . unGenTx {------------------------------------------------------------------------------- Ledger support