ouroboros-consensus-cardano: always use Conway ref scripts minfee in mempool

Even in Babbage! This is temporary.

Author: amesgen

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

@@ -143,6 +143,8 @@ instance LedgerSupportsMempool ByronBlock where
 
   txForgetValidated = forgetValidatedByronTx
 
+  txRefScriptSize _ _ _ = 0
+
 data instance TxId (GenTx ByronBlock)
   = ByronTxId             !Utxo.TxId
   | ByronDlgId            !Delegation.CertificateId

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

@@ -5,6 +5,7 @@
 {-# LANGUAGE GADTs                   #-}
 {-# LANGUAGE LambdaCase              #-}
 {-# LANGUAGE MultiParamTypeClasses   #-}
+{-# LANGUAGE NumericUnderscores      #-}
 {-# LANGUAGE ScopedTypeVariables     #-}
 {-# LANGUAGE TypeApplications        #-}
 {-# LANGUAGE TypeFamilies            #-}
@@ -28,6 +29,7 @@ module Ouroboros.Consensus.Shelley.Eras (
   , StandardMary
   , StandardShelley
     -- * Shelley-based era
+  , BabbageTxDict (..)
   , ConwayEraGovDict (..)
   , ShelleyBasedEra (..)
   , WrapTx (..)
@@ -45,6 +47,7 @@ import           Cardano.Ledger.Alonzo (AlonzoEra)
 import qualified Cardano.Ledger.Alonzo.Rules as Alonzo
 import qualified Cardano.Ledger.Alonzo.Translation as Alonzo
 import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
+import qualified Cardano.Ledger.Api as SL
 import qualified Cardano.Ledger.Api.Era as L
 import           Cardano.Ledger.Babbage (BabbageEra)
 import qualified Cardano.Ledger.Babbage.Rules as Babbage
@@ -57,6 +60,8 @@ import qualified Cardano.Ledger.Conway.Rules as Conway
 import qualified Cardano.Ledger.Conway.Rules as SL
                      (ConwayLedgerPredFailure (..))
 import qualified Cardano.Ledger.Conway.Translation as Conway
+import qualified Cardano.Ledger.Conway.Tx as SL
+import qualified Cardano.Ledger.Conway.UTxO as SL
 import           Cardano.Ledger.Core as Core
 import           Cardano.Ledger.Crypto (StandardCrypto)
 import           Cardano.Ledger.Keys (DSignable, Hash)
@@ -68,11 +73,13 @@ import           Cardano.Ledger.Shelley.Core as Core
 import qualified Cardano.Ledger.Shelley.LedgerState as SL
 import qualified Cardano.Ledger.Shelley.Rules as SL
 import qualified Cardano.Ledger.Shelley.Transition as SL
+import qualified Cardano.Ledger.Val as SL
 import qualified Cardano.Protocol.TPraos.API as SL
 import           Control.Monad.Except
 import           Control.State.Transition (PredicateFailure)
 import           Data.Data (Proxy (Proxy))
 import           Data.List.NonEmpty (NonEmpty ((:|)))
+import           Lens.Micro ((^.))
 import           NoThunks.Class (NoThunks)
 import           Ouroboros.Consensus.Ledger.SupportsMempool
                      (WhetherToIntervene (..))
@@ -162,6 +169,16 @@ class ( Core.EraSegWits era
   -- | Whether the era has an instance of 'CG.ConwayEraGov'
   getConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era)
 
+  getBabbageTxDict :: proxy era -> Maybe (BabbageTxDict era)
+
+data BabbageTxDict era where
+    BabbageTxDict ::
+         SL.BabbageEraTxBody era
+      => (Integer -> Integer -> SL.ApplyTxError era)
+         -- ^ Construct an arbitrary ledger error with two integers as its
+         -- payload.
+      -> BabbageTxDict era
+
 data ConwayEraGovDict era where
     ConwayEraGovDict :: CG.ConwayEraGov era => ConwayEraGovDict era
 
@@ -172,7 +189,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
@@ -183,12 +200,51 @@ defaultApplyShelleyBasedTx ::
        ( SL.LedgerState era
        , SL.Validated (Core.Tx era)
        )
-defaultApplyShelleyBasedTx globals ledgerEnv mempoolState _wti tx =
+defaultApplyShelleyBasedTx globals ledgerEnv mempoolState _wti tx = do
+    refScriptPredicate
     SL.applyTx
       globals
       ledgerEnv
       mempoolState
       tx
+  where
+    refScriptPredicate = case getBabbageTxDict (Proxy @era) of
+      Nothing -> pure ()
+      Just (BabbageTxDict mkError)
+        -- Reject it if it has more than 100 kibibytes of ref script.
+        | refScriptsSize > totalRefScriptsSizeLimit
+        -> throwError $ mkError
+            -- As we are reusing an existing error message, we add a large
+            -- number to make users running into this are productively irritated
+            -- and post this error message somewhere where they can receive
+            -- help/context.
+            (toInteger refScriptsSize           + 1_000_000_000)
+            (toInteger totalRefScriptsSizeLimit + 1_000_000_000)
+        -- Reject it if it has more than 50 kibibytes of ref script and does not
+        -- satisfy an additional fee as calculated in the table below.
+        | refScriptsSize > freeOfChargeRefScriptsBytes
+        , actualFee < expectedFee
+        -> throwError $ mkError
+            -- See above for why we add a large constant.
+            (SL.unCoin actualFee   + 100_000_000)
+            (SL.unCoin expectedFee + 100_000_000)
+        | otherwise -> pure ()
+        where
+          totalRefScriptsSizeLimit :: Int
+          totalRefScriptsSizeLimit = 100 * 1024
+
+          freeOfChargeRefScriptsBytes :: Int
+          freeOfChargeRefScriptsBytes = 50 * 1024
+
+          actualFee = tx ^. SL.bodyTxL . SL.feeTxBodyL
+          expectedFee = minFee SL.<+> refScriptsFee
+            where
+              minFee = SL.getMinFeeTx (SL.ledgerPp ledgerEnv) tx 0
+              refScriptsFee = SL.tierRefScriptFee 1.2 25600 15 refScriptsSize
+
+          refScriptsSize = SL.txNonDistinctRefScriptsSize utxo tx
+
+          utxo = SL.utxosUtxo . SL.lsUTxOState $ mempoolState
 
 defaultGetConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era)
 defaultGetConwayEraGovDict _ = Nothing
@@ -199,34 +255,52 @@ instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
 
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
+  getBabbageTxDict _ = Nothing
+
 instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => ShelleyBasedEra (AllegraEra c) where
   applyShelleyBasedTx = defaultApplyShelleyBasedTx
 
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
+  getBabbageTxDict _ = Nothing
+
 instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => ShelleyBasedEra (MaryEra c) where
   applyShelleyBasedTx = defaultApplyShelleyBasedTx
 
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
+  getBabbageTxDict _ = Nothing
+
 instance (SL.PraosCrypto c, DSignable c (Hash c EraIndependentTxBody))
   => ShelleyBasedEra (AlonzoEra c) where
   applyShelleyBasedTx = applyAlonzoBasedTx
 
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
+  getBabbageTxDict _ = Nothing
+
 instance (Praos.PraosCrypto c) => ShelleyBasedEra (BabbageEra c) where
   applyShelleyBasedTx = applyAlonzoBasedTx
 
   getConwayEraGovDict = defaultGetConwayEraGovDict
 
+  getBabbageTxDict _ = Just $ BabbageTxDict $ \a b ->
+      SL.ApplyTxError
+    $ pure
+    $ SL.UtxowFailure
+    $ Babbage.UtxoFailure
+    $ Babbage.AlonzoInBabbageUtxoPredFailure
+    $ Alonzo.MaxTxSizeUTxO a b
+
 instance (Praos.PraosCrypto c) => ShelleyBasedEra (ConwayEra c) where
   applyShelleyBasedTx = applyAlonzoBasedTx
 
   getConwayEraGovDict _ = Just ConwayEraGovDict
 
+  getBabbageTxDict _ = Nothing
+
 applyAlonzoBasedTx :: forall era.
   ( ShelleyBasedEra era,
     SupportsTwoPhaseValidation era,

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

@@ -42,6 +42,7 @@ import           Cardano.Ledger.Alonzo.Tx (totExUnits)
 import           Cardano.Ledger.Binary (Annotator (..), DecCBOR (..),
                      EncCBOR (..), FromCBOR (..), FullByteString (..),
                      ToCBOR (..), toPlainDecoder)
+import qualified Cardano.Ledger.Conway.UTxO as SL
 import qualified Cardano.Ledger.Core as SL (txIdTxBody)
 import           Cardano.Ledger.Crypto (Crypto)
 import qualified Cardano.Ledger.SafeHash as SL
@@ -147,6 +148,12 @@ instance ShelleyCompatible proto era
 
   txForgetValidated (ShelleyValidatedTx txid vtx) = ShelleyTx txid (SL.extractTx vtx)
 
+  txRefScriptSize _cfg st (ShelleyTx _ tx) = case getBabbageTxDict (Proxy @era) of
+      Nothing              -> 0
+      Just BabbageTxDict{} -> SL.txNonDistinctRefScriptsSize utxo tx
+    where
+      utxo = SL.getUTxO . tickedShelleyLedgerState $ st
+
 mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era)
 mkShelleyTx tx = ShelleyTx (SL.txIdTxBody @era (tx ^. bodyTxL)) tx
 

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

@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE GADTs                #-}
+{-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
@@ -124,6 +125,40 @@ instance CanHardFork xs => LedgerSupportsMempool (HardForkBlock xs) where
       . getOneEraValidatedGenTx
       . getHardForkValidatedGenTx
 
+  txRefScriptSize cfg st tx = case matchPolyTx injs tx' hardForkState of
+      Left {}       ->
+        -- This is ugly/adhoc, but fine, as in the mempool, we only call
+        -- txRefScriptSize after applyTx (which internall also calls
+        -- matchPolyTx), so this case is unreachable.
+        0
+      Right matched ->
+          hcollapse
+        $ hczipWith proxySingle
+            (\(WrapLedgerConfig eraCfg) (Pair eraTx (Comp eraSt)) ->
+               K $ txRefScriptSize eraCfg eraSt eraTx)
+            cfgs
+            (State.tip matched)
+    where
+      HardForkLedgerConfig {
+          hardForkLedgerConfigPerEra
+        , hardForkLedgerConfigShape
+        } = cfg
+      TickedHardForkLedgerState transition hardForkState = st
+      tx' = getOneEraGenTx . getHardForkGenTx $ tx
+
+      pcfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra
+      cfgs  = hcmap proxySingle (completeLedgerConfig'' ei) pcfgs
+      ei    = State.epochInfoPrecomputedTransitionInfo
+                hardForkLedgerConfigShape
+                transition
+                hardForkState
+
+      injs :: InPairs (InjectPolyTx GenTx) xs
+      injs =
+          InPairs.hmap
+            (\(Pair2 injTx _injValidatedTx) -> injTx)
+            (InPairs.requiringBoth cfgs hardForkInjectTxs)
+
 -- | A private type used only to clarify the parameterization of 'applyHelper'
 data ApplyHelperMode :: (Type -> Type) -> Type where
   ModeApply   :: ApplyHelperMode GenTx

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

@@ -624,6 +624,12 @@ instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where
           , vDualGenTxBridge
           } = vtx
 
+  txRefScriptSize cfg st tx =
+      txRefScriptSize
+        (dualLedgerConfigMain cfg)
+        (tickedDualLedgerStateMain st)
+        (dualGenTxMain tx)
+
 -- We don't need a pair of IDs, as long as we can unique ID the transaction
 newtype instance TxId (GenTx (DualBlock m a)) = DualGenTxId {
       dualGenTxIdMain :: GenTxId m

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

@@ -127,6 +127,8 @@ class ( UpdateLedger blk
   -- | Discard the evidence that transaction has been previously validated
   txForgetValidated :: Validated (GenTx blk) -> GenTx blk
 
+  txRefScriptSize :: LedgerConfig blk -> TickedLedgerState blk -> GenTx blk -> Int
+
 -- | A generalized transaction, 'GenTx', identifier.
 data family TxId tx :: Type
 

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

@@ -13,6 +13,7 @@ module Ouroboros.Consensus.Mempool.Impl.Common (
     -- * Internal state
     InternalState (..)
   , isMempoolSize
+  , isTotalRefScriptSize
     -- * Mempool environment
   , MempoolEnv (..)
   , initMempoolEnv
@@ -139,6 +140,9 @@ deriving instance ( NoThunks (Validated (GenTx blk))
 isMempoolSize :: InternalState blk -> MempoolSize
 isMempoolSize = TxSeq.toMempoolSize . isTxs
 
+isTotalRefScriptSize :: InternalState blk -> Int
+isTotalRefScriptSize = TxSeq.toRefScriptSize . isTxs
+
 initInternalState ::
      LedgerSupportsMempool blk
   => MempoolCapacityBytesOverride
@@ -340,6 +344,7 @@ extendVRNew cfg txSize wti tx vr = assert (isNothing vrNewValid) $
       Right (st', vtx) ->
         ( Right vtx
         , vr { vrValid        = vrValid :> TxTicket vtx nextTicketNo (txSize tx)
+                                             (txRefScriptSize cfg vrAfter tx)
              , vrValidTxIds   = Set.insert (txId tx) vrValidTxIds
              , vrNewValid     = Just vtx
              , vrAfter        = st'

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

@@ -22,6 +22,7 @@ module Ouroboros.Consensus.Mempool.TxSeq (
   , splitAfterTxSize
   , toList
   , toMempoolSize
+  , toRefScriptSize
   , toTuples
   , zeroTicketNo
     -- * Reference implementations for testing
@@ -63,6 +64,7 @@ data TxTicket tx = TxTicket
   , txTicketTxSizeInBytes :: !TxSizeInBytes
     -- ^ The byte size of the transaction ('txTicketTx') associated with this
     -- ticket.
+  , txTicketRefScriptSize :: !Int
   } deriving (Eq, Show, Generic, NoThunks)
 
 -- | The mempool is a sequence of transactions with their ticket numbers and
@@ -102,25 +104,27 @@ instance Foldable TxSeq where
 -- instance.
 --
 data TxSeqMeasure = TxSeqMeasure {
-       mMinTicket :: !TicketNo,
-       mMaxTicket :: !TicketNo,
-       mSizeBytes :: !TxSizeInBytes,
-       mSize      :: !Int
+       mMinTicket     :: !TicketNo,
+       mMaxTicket     :: !TicketNo,
+       mSizeBytes     :: !TxSizeInBytes,
+       mSize          :: !Int,
+       mRefScriptSize :: !Int
      }
   deriving Show
 
 instance FingerTree.Measured TxSeqMeasure (TxTicket tx) where
-  measure (TxTicket _ tno tsz) = TxSeqMeasure tno tno tsz 1
+  measure (TxTicket _ tno tsz trssz) = TxSeqMeasure tno tno tsz 1 trssz
 
 instance Semigroup TxSeqMeasure where
   vl <> vr = TxSeqMeasure
                (mMinTicket vl `min` mMinTicket vr)
                (mMaxTicket vl `max` mMaxTicket vr)
                (mSizeBytes vl   +   mSizeBytes vr)
                (mSize      vl   +   mSize      vr)
+               (mRefScriptSize vl + mRefScriptSize vr)
 
 instance Monoid TxSeqMeasure where
-  mempty  = TxSeqMeasure maxBound minBound 0 0
+  mempty  = TxSeqMeasure maxBound minBound 0 0 0
   mappend = (<>)
 
 -- | A helper function for the ':>' pattern.
@@ -171,8 +175,8 @@ lookupByTicketNo :: TxSeq tx -> TicketNo -> Maybe tx
 lookupByTicketNo (TxSeq txs) n =
     case FingerTree.search (\ml mr -> mMaxTicket ml >= n
                                    && mMinTicket mr >  n) txs of
-      FingerTree.Position _ (TxTicket tx n' _) _ | n' == n -> Just tx
-      _                                                    -> Nothing
+      FingerTree.Position _ (TxTicket tx n' _ _) _ | n' == n -> Just tx
+      _                                                      -> Nothing
 
 -- | \( O(\log(n)) \). Split the sequence of transactions into two parts
 -- based on the given 'TicketNo'. The first part has transactions with tickets
@@ -244,3 +248,8 @@ toMempoolSize (TxSeq ftree) = MempoolSize
     }
   where
     TxSeqMeasure { mSizeBytes, mSize } = FingerTree.measure ftree
+
+toRefScriptSize :: TxSeq tx -> Int
+toRefScriptSize (TxSeq ftree) = mRefScriptSize
+  where
+    TxSeqMeasure { mRefScriptSize } = FingerTree.measure ftree

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

@@ -181,9 +181,15 @@ pureTryAddTx ::
      -- ^ The current internal state of the mempool.
   -> TryAddTx blk
 pureTryAddTx cfg txSize wti tx is
+    -- We add the transaction if there is at least one byte free left in the
+    -- mempool, and...
   | let curSize = msNumBytes  $ isMempoolSize is
   , curSize < getMempoolCapacityBytes (isCapacity is)
-  = -- We add the transaction if there is at least one byte free left in the mempool.
+    -- ... if the mempool has less than 2.5 mebibytes of ref scripts.
+  , let maxTotalRefScriptSize = 5 * 512 * 1024 -- 2.5 Mebibytes
+        curTotalRefScriptSize = isTotalRefScriptSize is
+  , curTotalRefScriptSize Prelude.< maxTotalRefScriptSize
+  =
   case eVtx of
       -- We only extended the ValidationResult with a single transaction
       -- ('tx'). So if it's not in 'vrInvalid', it must be in 'vrNewValid'.