consensus: 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.

Author: nfrisby

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 (byronGenesisConfig cfg) st txs
+          txs
 
     txPayload :: CC.UTxO.TxPayload
     txPayload = CC.UTxO.mkTxPayload (bpTxs blockPayloads)

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,8 +12,6 @@ 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 (foldl')
 import qualified Data.Sequence.Strict as Seq
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
@@ -31,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
@@ -63,17 +59,16 @@ forgeShelleyBlock
     let blk = mkShelleyBlock $ SL.Block hdr body
     return $
       assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus cfg) blk) $
-      assertWithMsg bodySizeEstimate blk
+      blk
   where
-    lcfg = configLedger cfg
-
     protocolVersion = shelleyProtocolVersion $ configBlock cfg
 
     body =
         SL.toTxSeq @era
-      . Seq.fromList
-      . fmap extractTx
-      $ takeLargestPrefixThatFits lcfg 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
@@ -84,26 +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 ()
-
-    actualBodySize, estimatedBodySize :: Int
-    actualBodySize = SL.bBodySize protocolVersion body
-
-    estimatedBodySize =
-        fromIntegral . unByteSize
-      $ foldl' (<>) mempty
-      $ map
-          (txMeasureByteSize . txMeasure lcfg tickedLedger . txForgetValidated)
-          txs

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

@@ -514,7 +514,11 @@ forkBlockForging IS{..} blockForging =
                       (ForgeInKnownSlot currentSlot tickedLedgerState)
             pure (mempoolHash, mempoolSlotNo, snap)
 
-        let txs = [ vtx | (vtx, _tno, _byteSize) <- 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)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs

@@ -20,13 +20,10 @@ 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
@@ -125,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
@@ -143,28 +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 ::
-     LedgerSupportsMempool blk
-  => LedgerConfig blk
-  -> TickedLedgerState blk
-  -> [Validated (GenTx blk)]
-  -> [Validated (GenTx blk)]
-takeLargestPrefixThatFits cfg ledger txs =
-    Measure.take toMeasure capacity txs
-  where
-    toMeasure = txMeasure cfg ledger . txForgetValidated
-    capacity  = blockCapacityTxMeasure cfg 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

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

@@ -334,6 +334,10 @@ data MempoolSnapshot blk = MempoolSnapshot {
     -- number greater than the one provided.
   , snapshotTxsAfter    :: TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize)]
 
+    -- | 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.
   , snapshotLookupTx    :: TicketNo -> Maybe (Validated (GenTx blk))

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

@@ -429,6 +429,7 @@ snapshotFromIS is = MempoolSnapshot {
     , snapshotMempoolSize = implSnapshotGetMempoolSize is
     , snapshotSlotNo      = isSlotNo                   is
     , snapshotLedgerState = isLedgerState              is
+    , snapshotTake        = implSnapshotTake           is
     }
  where
   implSnapshotGetTxs :: InternalState blk
@@ -441,6 +442,12 @@ snapshotFromIS is = MempoolSnapshot {
   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))