Expose over-the-wire encoded transaction size (#1211)

# Description

This change introduces a new method wireSizeTx for the
LedgerSupportsMempool class. It provides actual CBOR encoded transaction
size as it is when transmitted over the network, which the difffusion
layer could exploit.

Also note that:

- New code should be properly tested (even if it does not add new
features).
- The fix for a regression should include a test that reproduces said
regression.

IntersectMBO/cardano-ledger#4521
IntersectMBO/ouroboros-network#4926

Author: crocodile-dentist

cabal.project

@@ -59,8 +59,8 @@ if impl(ghc >= 9.10)
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/ouroboros-network
-  tag: d900a38c55e02f5eed8c8d6d6a4671cd8c5acc6a
-  --sha256: sha256-VVccbWFmd9GlL2N/xNsKtXg2U2asGc4fIX1lLEo+Ar8=
+  tag: 388cc6906b83f41ac2da192b1fd89ab986b4af74
+  --sha256: sha256-LUwryrP5jK+/c4lDitJf/oKg/DqLgbIc68bn83FsHI0=
   subdir:
     cardano-client
     cardano-ping

ouroboros-consensus-cardano/changelog.d/20240808_125131_marcin.wojtowicz_tx_wire_size.md

@@ -0,0 +1,21 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+### Breaking
+
+- Implement txWireSize of TxLimits instantiations for Byron and Shelley

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

@@ -73,6 +73,7 @@ import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Util (ShowProxy (..))
 import           Ouroboros.Consensus.Util.Condense
+import           Ouroboros.Network.SizeInBytes as Network
 
 {-------------------------------------------------------------------------------
   Transactions
@@ -127,6 +128,11 @@ instance LedgerSupportsMempool ByronBlock where
 instance TxLimits ByronBlock where
   type TxMeasure ByronBlock = IgnoringOverflow ByteSize32
 
+  txWireSize =   fromIntegral
+               . Strict.length
+               . CC.mempoolPayloadRecoverBytes
+               . toMempoolPayload
+
   blockCapacityTxMeasure _cfg st =
       IgnoringOverflow
     $ ByteSize32

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

@@ -39,7 +39,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool (
 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)
+                     fromTxSeq, ppMaxBBSizeL, ppMaxBlockExUnitsL, sizeTxF, wireSizeTxF)
 import qualified Cardano.Ledger.Alonzo.Rules as AlonzoEra
 import           Cardano.Ledger.Alonzo.Scripts (ExUnits, ExUnits',
                      pointWiseExUnits, unWrapExUnits)
@@ -146,6 +146,8 @@ instance (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era))
 
   reapplyTx = reapplyShelleyTx
 
+  wireTxSize (ShelleyTx _ tx) = fromIntegral $ tx ^. wireSizeTxF
+
   txForgetValidated (ShelleyValidatedTx txid vtx) = ShelleyTx txid (SL.extractTx vtx)
 
 mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era)
@@ -385,16 +387,19 @@ instance MaxTxSizeUTxO (ConwayEra c) where
 
 instance ShelleyCompatible p (ShelleyEra c) => TxLimits (ShelleyBlock p (ShelleyEra c)) where
   type TxMeasure (ShelleyBlock p (ShelleyEra c)) = IgnoringOverflow ByteSize32
+  txWireSize (ShelleyTx _ tx) = fromIntegral (tx ^. wireSizeTxF)
   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
+  txWireSize (ShelleyTx _ tx) = fromIntegral (tx ^. wireSizeTxF)
   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
+  txWireSize (ShelleyTx _ tx) = fromIntegral (tx ^. wireSizeTxF)
   txMeasure              _cfg st tx = runValidation $ txInBlockSize st tx
   blockCapacityTxMeasure _cfg       = txsMaxBytes
 
@@ -485,6 +490,7 @@ instance ( ShelleyCompatible p (AlonzoEra c)
          ) => TxLimits (ShelleyBlock p (AlonzoEra c)) where
 
   type TxMeasure (ShelleyBlock p (AlonzoEra c)) = AlonzoMeasure
+  txWireSize (ShelleyTx _ tx) = fromIntegral (tx ^. wireSizeTxF)
   txMeasure              _cfg st tx = runValidation $ txMeasureAlonzo st tx
   blockCapacityTxMeasure _cfg       = blockCapacityAlonzoMeasure
 
@@ -582,12 +588,14 @@ instance ( ShelleyCompatible p (BabbageEra c)
          ) => TxLimits (ShelleyBlock p (BabbageEra c)) where
 
   type TxMeasure (ShelleyBlock p (BabbageEra c)) = ConwayMeasure
+  txWireSize (ShelleyTx _ tx) = fromIntegral (tx ^. wireSizeTxF)
   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
+  txWireSize (ShelleyTx _ tx) = fromIntegral (tx ^. wireSizeTxF)
   txMeasure              _cfg st tx = runValidation $ txMeasureConway st tx
   blockCapacityTxMeasure _cfg       = blockCapacityConwayMeasure

ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs

@@ -57,6 +57,7 @@ instance TxLimits ByronSpecBlock where
   type TxMeasure ByronSpecBlock = IgnoringOverflow ByteSize32
 
   -- Dummy values, as these are not used in practice.
+  txWireSize = const . fromIntegral $ (0 :: Int)
   blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 1
 
   txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0

ouroboros-consensus-diffusion/changelog.d/20240808_125632_marcin.wojtowicz_tx_wire_size.md

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+
+### Non-Breaking
+
+- Provide txWireSize to tx-submission protocol
+
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -99,7 +99,6 @@ library
     serialise ^>=0.2,
     si-timers ^>=1.5,
     strict-stm ^>=1.5,
-    strict-mvar ^>=1.5,
     text,
     time,
     transformers,

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -748,6 +748,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
                    (getSharedTxStateVar kernel)
                    (mapTxSubmissionMempoolReader txForgetValidated
                    $ getMempoolReader (getMempool kernel))
+                   txWireSize
                    them $ \api ->
                      runServer (newTxSubmissionServer api)
 

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs

@@ -27,7 +27,6 @@ module Ouroboros.Consensus.NodeKernel (
   ) where
 
 
-import qualified Control.Concurrent.Class.MonadMVar.Strict as StrictSTM
 import qualified Control.Concurrent.Class.MonadSTM as LazySTM
 import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM
 import           Control.DeepSeq (force)
@@ -43,7 +42,6 @@ import           Data.Functor ((<&>))
 import           Data.Hashable (Hashable)
 import           Data.List.NonEmpty (NonEmpty)
 import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
 import           Data.Maybe (isJust, mapMaybe)
 import           Data.Proxy
 import qualified Data.Text as Text
@@ -114,8 +112,8 @@ import           Ouroboros.Network.TxSubmission.Inbound
                      (TxSubmissionMempoolWriter)
 import qualified Ouroboros.Network.TxSubmission.Inbound as Inbound
 import           Ouroboros.Network.TxSubmission.Inbound.Registry
-                     (SharedTxStateVar, TxChannels (..), TxChannelsVar,
-                     decisionLogicThread, newSharedTxStateVar)
+                     (SharedTxStateVar, TxChannelsVar,
+                     decisionLogicThread, newSharedTxStateVar, newTxChannelsVar)
 import           Ouroboros.Network.TxSubmission.Mempool.Reader
                      (TxSubmissionMempoolReader)
 import qualified Ouroboros.Network.TxSubmission.Mempool.Reader as MempoolReader
@@ -294,7 +292,7 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
                                         ps_POLICY_PEER_SHARE_STICKY_TIME
                                         ps_POLICY_PEER_SHARE_MAX_PEERS
 
-    txChannelsVar <- StrictSTM.newMVar (TxChannels Map.empty)
+    txChannelsVar <- newTxChannelsVar
     sharedTxStateVar <- newSharedTxStateVar
 
     case gnkaGetLoEFragment genesisArgs of

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs

@@ -330,6 +330,7 @@ instance LedgerSupportsMempool BlockA where
 
 instance TxLimits BlockA where
   type TxMeasure BlockA = IgnoringOverflow ByteSize32
+  txWireSize = const . fromIntegral $ (0 :: Int)
   blockCapacityTxMeasure _cfg _st     = IgnoringOverflow $ ByteSize32 $ 100 * 1024   -- arbitrary
   txMeasure              _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0
 

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs

@@ -266,6 +266,7 @@ instance LedgerSupportsMempool BlockB where
 
 instance TxLimits BlockB where
   type TxMeasure BlockB = IgnoringOverflow ByteSize32
+  txWireSize = const . fromIntegral $ (0 :: Int)
   blockCapacityTxMeasure _cfg _st     = IgnoringOverflow $ ByteSize32 $ 100 * 1024   -- arbitrary
   txMeasure              _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0
 

ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs

@@ -151,6 +151,7 @@ instance Ledger.LedgerSupportsMempool TestBlock where
 instance Ledger.TxLimits TestBlock where
   type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32
 
+  txWireSize = fromIntegral . Ledger.unByteSize32 . txSize
   -- 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 =

ouroboros-consensus/changelog.d/20240808_101916_marcin.wojtowicz_tx_wire_size.md

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+### Breaking
+
+- Added txWireSize method to TxLimits class to provide
+  a CBOR-encoded transaction size as it is when transmitted
+  over the network.

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs

@@ -119,6 +119,12 @@ instance CanHardFork xs => LedgerSupportsMempool (HardForkBlock xs) where
 instance CanHardFork xs => TxLimits (HardForkBlock xs) where
   type TxMeasure (HardForkBlock xs) = HardForkTxMeasure xs
 
+  txWireSize =
+        hcollapse
+      . hcmap proxySingle (K . txWireSize)
+      . getOneEraGenTx
+      . getHardForkGenTx
+
   blockCapacityTxMeasure
     HardForkLedgerConfig{..}
     (TickedHardForkLedgerState transition hardForkState)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs

@@ -625,6 +625,7 @@ instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where
 instance Bridge m a => TxLimits (DualBlock m a) where
   type TxMeasure (DualBlock m a) = TxMeasure m
 
+  txWireSize = txWireSize . dualGenTxMain
   txMeasure DualLedgerConfig{..} TickedDualLedgerState{..} DualGenTx{..} = do
       mapExcept (inj +++ id)
     $ txMeasure dualLedgerConfigMain tickedDualLedgerStateMain dualGenTxMain

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs

@@ -37,6 +37,7 @@ import           NoThunks.Class
 import           Ouroboros.Consensus.Block.Abstract
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ticked
+import           Ouroboros.Network.SizeInBytes as Network
 
 -- | Generalized transaction
 --
@@ -179,6 +180,10 @@ class ( Measure     (TxMeasure blk)
   -- | The (possibly multi-dimensional) size of a transaction in a block.
   type TxMeasure blk
 
+  -- | The size of the transaction from the perspective of diffusion layer
+  --
+  txWireSize :: GenTx blk -> Network.SizeInBytes
+
   -- | The various sizes (bytes, Plutus script ExUnits, etc) of a tx /when it's
   -- in a block/
   --

ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs

@@ -438,6 +438,7 @@ instance MockProtocolSpecific c ext
 instance TxLimits (SimpleBlock c ext) where
   type TxMeasure (SimpleBlock c ext) = IgnoringOverflow ByteSize32
 
+  txWireSize = fromIntegral . unByteSize32 . txSize
   -- Large value so that the Mempool tests never run out of capacity when they
   -- don't override it.
   --

ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs

@@ -91,6 +91,7 @@ instance Ledger.LedgerSupportsMempool TestBlock where
 instance Ledger.TxLimits TestBlock where
   type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32
 
+  txWireSize = fromIntegral . Ledger.unByteSize32 . txSize . unGenTx
   blockCapacityTxMeasure _cfg _st =
     -- The tests will override this value. By using 1, @computeMempoolCapacity@
     -- can be exactly what each test requests.