consensus: consolidate transaction limits in the mempool

Remove `Mempool.`getTxSize`; the snapshot interface contains sizes now.

Transaction size, block capacity, and mempool capacity are multi-dimensional
vectors (incl ExUnits, etc), instead of merely bytes: see `TxMeasure`.

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).

Author: nfrisby

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

@@ -141,7 +141,7 @@ forgeRegularBlock cfg bno sno st txs isLeader =
         foldr
           extendBlockPayloads
           initBlockPayloads
-          (takeLargestPrefixThatFits st txs)
+      $ takeLargestPrefixThatFits (byronGenesisConfig cfg) st txs
 
     txPayload :: CC.UTxO.TxPayload
     txPayload = CC.UTxO.mkTxPayload (bpTxs blockPayloads)

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

@@ -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,19 +122,24 @@ instance LedgerSupportsMempool ByronBlock where
     where
       validationMode = CC.ValidationMode CC.NoBlockValidation Utxo.TxValidationNoCrypto
 
-  txsMaxBytes st =
-    CC.getMaxBlockSize (tickedByronLedgerState st) - byronBlockEncodingOverhead
+  txForgetValidated = forgetValidatedByronTx
 
-  txInBlockSize =
-      fromIntegral
+instance TxLimits ByronBlock where
+  type TxMeasure ByronBlock = ByteSize
+
+  blockCapacityTxMeasure _cfg st =
+      ByteSize
+    $ CC.getMaxBlockSize cvs - byronBlockEncodingOverhead
+    where
+      cvs = tickedByronLedgerState st
+
+  txMeasure _cfg _st =
+      ByteSize
+    . fromIntegral
     . Strict.length
     . CC.mempoolPayloadRecoverBytes
     . toMempoolPayload
 
-  txForgetValidated = forgetValidatedByronTx
-
-  txRefScriptSize _ _ _ = 0
-
 data instance TxId (GenTx ByronBlock)
   = ByronTxId             !Utxo.TxId
   | ByronDlgId            !Delegation.CertificateId

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 (ByteSize,
+                     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`
+    fromAlonzo   `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 :: ByteSize -> 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/Ledger/Forge.hs

@@ -20,7 +20,6 @@ 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)
@@ -40,7 +39,7 @@ import           Ouroboros.Consensus.Util.Assert
 
 forgeShelleyBlock ::
      forall m era proto.
-      (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era), Monad m)
+     (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era), Monad m)
   => HotKey (EraCrypto era) m
   -> CanBeLeader proto
   -> TopLevelConfig (ShelleyBlock proto era)
@@ -66,13 +65,15 @@ forgeShelleyBlock
       assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus cfg) blk) $
       assertWithMsg bodySizeEstimate blk
   where
+    lcfg = configLedger cfg
+
     protocolVersion = shelleyProtocolVersion $ configBlock cfg
 
     body =
         SL.toTxSeq @era
       . Seq.fromList
       . fmap extractTx
-      $ takeLargestPrefixThatFits tickedLedger txs
+      $ takeLargestPrefixThatFits lcfg tickedLedger txs
 
     extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx era
     extractTx (ShelleyValidatedTx _txid vtx) = SL.extractTx vtx
@@ -97,6 +98,12 @@ forgeShelleyBlock
       | otherwise
       = return ()
 
-    estimatedBodySize, actualBodySize :: Int
-    estimatedBodySize = fromIntegral $ foldl' (+) 0 $ map (txInBlockSize . txForgetValidated) txs
-    actualBodySize    = SL.bBodySize protocolVersion body
+    actualBodySize, estimatedBodySize :: Int
+    actualBodySize = SL.bBodySize protocolVersion body
+
+    estimatedBodySize =
+        fromIntegral . unByteSize
+      $ foldl' (<>) mempty
+      $ map
+          (txMeasureByteSize . txMeasure lcfg tickedLedger . txForgetValidated)
+          txs