consensus: consolidate transaction limits in the mempool

Transaction size, block capacity, and mempool capacity are multi-dimensional
vectors (incl ExUnits, etc), instead of merely bytes: see `TxMeasure`.
`TxLimits` has fittingly been promoted from the `Capacity` module to the proper
`SupportsMempool` module, cannibalizing some methds from the
`LedgerSupporstMempool` class.

A transaction cannot be added if it would push any component of the size over
that component's capacity.

The capacity override is still only specified in byte size, but the value is
interpreted as a block count (rounded up).

Enforce block capacity _before_ the forging logic.
Now the forging logic simply includes whatever transactions its given, which is
reasonable and simpler. It's the NodeKernel logic that uses the mempool's
finger tree in order to slice an appropriately-sized prefix, which is then
passed to the now-dumb forging function.

Explicit attention is given to overflow and the DoS vector of providing an
erroneously massive tx that would block the mempool's growth, were it not for
the new guards.

Also, anachronistically use ConwayMeasure in Babbage, since it should have been
counting ref script bytes, as Conway now does.

Many comments are improved and also updated for the new scheme.

Author: nfrisby

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

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)

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs

@@ -48,13 +48,13 @@ import           Cardano.Ledger.Binary (ByteSpan, DecoderError (..),
                      byronProtVer, fromByronCBOR, serialize, slice, toByronCBOR,
                      unsafeDeserialize)
 import           Cardano.Ledger.Binary.Plain (enforceSize)
-import           Cardano.Prelude (cborError)
+import           Cardano.Prelude (Natural, cborError)
 import           Codec.CBOR.Decoding (Decoder)
 import qualified Codec.CBOR.Decoding as CBOR
 import           Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Encoding as CBOR
 import           Control.Monad (void)
-import           Control.Monad.Except (Except)
+import           Control.Monad.Except (Except, throwError)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
@@ -71,19 +71,9 @@ import           Ouroboros.Consensus.Byron.Ledger.Serialisation
                      (byronBlockEncodingOverhead)
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool
-import           Ouroboros.Consensus.Mempool
 import           Ouroboros.Consensus.Util (ShowProxy (..))
 import           Ouroboros.Consensus.Util.Condense
 
-{-------------------------------------------------------------------------------
-  TxLimits
--------------------------------------------------------------------------------}
-
-instance TxLimits ByronBlock where
-  type TxMeasure ByronBlock = ByteSize
-  txMeasure _st    = ByteSize . txInBlockSize . txForgetValidated
-  txsBlockCapacity = ByteSize . txsMaxBytes
-
 {-------------------------------------------------------------------------------
   Transactions
 -------------------------------------------------------------------------------}
@@ -132,16 +122,39 @@ instance LedgerSupportsMempool ByronBlock where
     where
       validationMode = CC.ValidationMode CC.NoBlockValidation Utxo.TxValidationNoCrypto
 
-  txsMaxBytes st =
-    CC.getMaxBlockSize (tickedByronLedgerState st) - byronBlockEncodingOverhead
+  txForgetValidated = forgetValidatedByronTx
 
-  txInBlockSize =
-      fromIntegral
-    . Strict.length
-    . CC.mempoolPayloadRecoverBytes
-    . toMempoolPayload
+instance TxLimits ByronBlock where
+  type TxMeasure ByronBlock = IgnoringOverflow ByteSize32
 
-  txForgetValidated = forgetValidatedByronTx
+  blockCapacityTxMeasure _cfg st =
+      IgnoringOverflow
+    $ ByteSize32
+    $ CC.getMaxBlockSize cvs - byronBlockEncodingOverhead
+    where
+      cvs = tickedByronLedgerState st
+
+  txMeasure _cfg st tx =
+      if txszNat > maxTxSize then throwError err else
+      pure $ IgnoringOverflow $ ByteSize32 $ fromIntegral txsz
+    where
+      maxTxSize =
+          Update.ppMaxTxSize
+        $ CC.adoptedProtocolParameters
+        $ CC.cvsUpdateState
+        $ tickedByronLedgerState st
+
+      txszNat = fromIntegral txsz :: Natural
+
+      txsz =
+          Strict.length
+        $ CC.mempoolPayloadRecoverBytes
+        $ toMempoolPayload tx
+
+      err =
+          CC.MempoolTxErr
+        $ Utxo.UTxOValidationTxValidationError
+        $ Utxo.TxValidationTxTooLarge txszNat maxTxSize
 
 data instance TxId (GenTx ByronBlock)
   = ByronTxId             !Utxo.TxId

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     #-}
@@ -56,7 +58,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
@@ -77,6 +79,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
@@ -282,6 +286,8 @@ type CardanoHardForkConstraints c =
   )
 
 instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
+  type HardForkTxMeasure (CardanoEras c) = ConwayMeasure
+
   hardForkEraTranslation = EraTranslation {
       translateLedgerState   =
           PCons translateLedgerStateByronToShelleyWrapper
@@ -310,7 +316,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 =
@@ -348,6 +354,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
 

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs

@@ -172,7 +172,7 @@ isBeforeConway _ =
 -- | The default implementation of 'applyShelleyBasedTx', a thin wrapper around
 -- 'SL.applyTx'
 defaultApplyShelleyBasedTx ::
-     ShelleyBasedEra era
+     forall era. ShelleyBasedEra era
   => SL.Globals
   -> SL.LedgerEnv era
   -> SL.LedgerState era

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,22 +28,21 @@ import           Ouroboros.Consensus.Shelley.Ledger.Mempool
 import           Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto,
                      ProtocolHeaderSupportsKES (configSlotsPerKESPeriod),
                      mkHeader)
-import           Ouroboros.Consensus.Util.Assert
 
 {-------------------------------------------------------------------------------
   Forging
 -------------------------------------------------------------------------------}
 
 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