Introduce computeGenTxSize

Co-authored-by: Thomas Winant <thomas@well-typed.com>

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

@@ -49,6 +49,7 @@ import           Codec.Serialise (Serialise, decode, encode)
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import qualified Data.Bimap as Bimap
+import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import           Data.Coerce (coerce)
 import           Data.FingerTree (Measured (..))
@@ -416,6 +417,11 @@ instance (ByronGiven, Typeable cfg, ConfigContainsGenesis cfg)
 
   computeGenTxId = ByronTxId . Crypto.hash . CC.UTxO.taTx . unByronTx
 
+  computeGenTxSize (ByronTx atxaux) = fromIntegral txByteSize
+    where
+      txByteSize = (Strict.length . annotation . CC.UTxO.aTaTx      $ atxaux)
+                 + (Strict.length . annotation . CC.UTxO.aTaWitness $ atxaux)
+
   type ApplyTxErr (ByronBlock cfg) = CC.UTxO.UTxOValidationError
 
   applyTx   = applyByronGenTx False

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

@@ -50,7 +50,7 @@ import           Data.Typeable (Typeable)
 import           Data.Word
 import           GHC.Generics (Generic)
 
-import           Cardano.Binary (ToCBOR(..))
+import           Cardano.Binary (ToCBOR (..))
 import           Cardano.Crypto.Hash
 
 import           Ouroboros.Network.Block
@@ -247,6 +247,8 @@ instance (SimpleCrypto c, Typeable ext, SupportedBlock (SimpleBlock c ext))
 
   computeGenTxId = SimpleGenTxId . hash . simpleGenTx
 
+  computeGenTxSize _ = 2000  -- TODO #745
+
   type ApplyTxErr (SimpleBlock c ext) = MockError (SimpleBlock c ext)
 
   applyTx            = \_ -> updateSimpleLedgerState

ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs

@@ -9,6 +9,8 @@ module Ouroboros.Consensus.Mempool.API (
   , MempoolSnapshot(..)
   , ApplyTx(..)
   , TraceEventMempool(..)
+    -- * Re-exports
+  , TxSizeInBytes
   ) where
 
 import           Control.Monad.Except
@@ -17,6 +19,8 @@ import           GHC.Stack (HasCallStack)
 
 import           Control.Monad.Class.MonadSTM
 
+import           Ouroboros.Network.Protocol.TxSubmission.Type (TxSizeInBytes)
+
 import           Ouroboros.Consensus.Ledger.Abstract
 
 class UpdateLedger blk => ApplyTx blk where
@@ -35,6 +39,9 @@ class UpdateLedger blk => ApplyTx blk where
   -- Should be cheap as this will be called often.
   computeGenTxId :: GenTx blk -> GenTxId blk
 
+  -- | Given a 'GenTx', compute its post-serialization size in bytes.
+  computeGenTxSize :: GenTx blk -> TxSizeInBytes
+
   -- | Updating the ledger with a single transaction may result in a different
   -- error type as when updating it with a block
   type family ApplyTxErr blk :: *
@@ -192,14 +199,14 @@ data Mempool m blk idx = Mempool {
 -- when the transaction has been removed from the mempool between snapshots.
 --
 data MempoolSnapshot blk idx = MempoolSnapshot {
-    -- | Get all transactions in the mempool snapshot along with their
-    -- associated ticket numbers (oldest to newest).
-    getTxs      :: [(GenTxId blk, GenTx blk, idx)]
-
-    -- | Get all transactions in the mempool snapshot, along with their
-    -- associated ticket numbers, which are associated with a ticket number
-    -- greater than the one provided.
-  , getTxsAfter :: idx -> [(GenTxId blk, GenTx blk, idx)]
+    -- | Get all transactions (oldest to newest) in the mempool snapshot along
+    -- with their ticket number and size.
+    getTxs      :: [(GenTx blk, idx, TxSizeInBytes)]
+
+    -- | Get all transactions (oldest to newest) in the mempool snapshot,
+    -- along with their ticket number and size, which are associated with a
+    -- ticket number greater than the one provided.
+  , getTxsAfter :: idx -> [(GenTx blk, idx, TxSizeInBytes)]
 
     -- | Get a specific transaction from the mempool snapshot by its ticket
     -- number, if it exists.

ouroboros-consensus/src/Ouroboros/Consensus/Mempool/Impl.hs

@@ -184,15 +184,15 @@ getMempoolSize MempoolEnv{mpEnvStateVar} =
 
 implSnapshotGetTxs :: ApplyTx blk
                    => InternalState blk
-                   -> [(GenTxId blk, GenTx blk, TicketNo)]
+                   -> [(GenTx blk, TicketNo, TxSizeInBytes)]
 implSnapshotGetTxs = (flip implSnapshotGetTxsAfter) zeroTicketNo
 
 implSnapshotGetTxsAfter :: ApplyTx blk
                         => InternalState blk
                         -> TicketNo
-                        -> [(GenTxId blk, GenTx blk, TicketNo)]
+                        -> [(GenTx blk, TicketNo, TxSizeInBytes)]
 implSnapshotGetTxsAfter IS{isTxs} tn = map
-  (\(tx, txTn) -> (computeGenTxId tx, tx, txTn))
+  (\(tx, txTn) -> (tx, txTn, computeGenTxSize tx))
   (TxSeq.fromTxSeq $ snd $ splitAfterTicketNo isTxs tn)
 
 implSnapshotGetTx :: ApplyTx blk

ouroboros-consensus/src/Ouroboros/Consensus/Node.hs

@@ -326,7 +326,7 @@ forkBlockProduction IS{..} =
             _                   <- pure $ syncState mempool
             mempoolSnapshot     <- getSnapshot mempool
 
-            let txs             =  map sndOfTriple (getTxs mempoolSnapshot)
+            let txs             =  map fst3 (getTxs mempoolSnapshot)
             newBlock            <- runProtocol varDRG $
                                      produceBlock
                                        proof
@@ -345,8 +345,8 @@ forkBlockProduction IS{..} =
   where
     NodeCallbacks{..} = callbacks
 
-    -- Return the second item in a triple.
-    sndOfTriple (_, b, _) = b
+    -- Return the first item in a 3-tuple.
+    fst3 (a, _, _) = a
 
     -- Return the point and block number of the most recent block in the
     -- current chain with a slot < the given slot. These will either

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

@@ -85,11 +85,8 @@ prop_Mempool_addTxs_getTxs bc txs =
         txs
         (\_ MempoolSnapshot{getTxs} ->
           filter (genTxIsValid . snd) (testTxsToGenTxPairs txs)
-              === dropThd getTxs)
+              === map (\(tx, _, _) -> (computeGenTxId tx, tx)) getTxs)
   where
-    dropThd :: [(a, b, c)] -> [(a, b)]
-    dropThd = map (\(a, b, _) -> (a, b))
-    --
     genTxIsValid :: GenTx TestBlock -> Bool
     genTxIsValid (TestGenTx (ValidTestTx _)) = True
     genTxIsValid _                           = False
@@ -107,7 +104,7 @@ prop_Mempool_InvalidTxsNeverAdded bc txs =
         bc
         txs
         (\_ MempoolSnapshot{getTxs} ->
-          filter (\(_, tx, _) -> genTxIsInvalid tx) getTxs === [])
+          filter (\(tx, _, _) -> genTxIsInvalid tx) getTxs === [])
   where
     genTxIsInvalid :: GenTx TestBlock -> Bool
     genTxIsInvalid (TestGenTx (InvalidTestTx _)) = True

ouroboros-consensus/test-util/Test/Util/TestBlock.hs

@@ -297,6 +297,8 @@ instance ApplyTx TestBlock where
   computeGenTxId (TestGenTx (ValidTestTx txid))   = TestGenTxId txid
   computeGenTxId (TestGenTx (InvalidTestTx txid)) = TestGenTxId txid
 
+  computeGenTxSize _ = 2000 -- TODO #745
+
   type ApplyTxErr TestBlock = TestTxError
 
   applyTx = \_ (TestGenTx tx) st -> case tx of