consensus: remove the ref script mempool hotfix

Author: nfrisby

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

@@ -143,8 +143,6 @@ 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,7 +5,6 @@
 {-# LANGUAGE GADTs                   #-}
 {-# LANGUAGE LambdaCase              #-}
 {-# LANGUAGE MultiParamTypeClasses   #-}
-{-# LANGUAGE NumericUnderscores      #-}
 {-# LANGUAGE ScopedTypeVariables     #-}
 {-# LANGUAGE TypeApplications        #-}
 {-# LANGUAGE TypeFamilies            #-}
@@ -29,7 +28,6 @@ module Ouroboros.Consensus.Shelley.Eras (
   , StandardMary
   , StandardShelley
     -- * Shelley-based era
-  , BabbageTxDict (..)
   , ConwayEraGovDict (..)
   , ShelleyBasedEra (..)
   , WrapTx (..)
@@ -47,7 +45,6 @@ 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
@@ -60,8 +57,6 @@ 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)
@@ -73,13 +68,11 @@ 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 (..))
@@ -169,16 +162,6 @@ 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
 
@@ -189,7 +172,7 @@ isBeforeConway _ =
 -- | The default implementation of 'applyShelleyBasedTx', a thin wrapper around
 -- 'SL.applyTx'
 defaultApplyShelleyBasedTx ::
-     forall era. ShelleyBasedEra era
+     ShelleyBasedEra era
   => SL.Globals
   -> SL.LedgerEnv era
   -> SL.LedgerState era
@@ -201,55 +184,11 @@ defaultApplyShelleyBasedTx ::
        , SL.Validated (Core.Tx era)
        )
 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)
-        -- The ledger rules of Conway (and later eras) already handle ref
-        -- scripts appropriately, so we only need to perform the checks below
-        -- for Babbage.
-        | not $ isBeforeConway (Proxy @era)
-        -> pure ()
-        -- 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
@@ -260,57 +199,34 @@ 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 _ = Just $ BabbageTxDict $ \a b ->
-      SL.ApplyTxError
-    $ pure
-    $ Conway.ConwayUtxowFailure
-    $ Conway.UtxoFailure
-    $ Conway.MaxTxSizeUTxO a b
-
 applyAlonzoBasedTx :: forall era.
   ( ShelleyBasedEra era,
     SupportsTwoPhaseValidation era,

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

@@ -149,12 +149,6 @@ 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-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs

@@ -56,5 +56,3 @@ instance LedgerSupportsMempool ByronSpecBlock where
   txInBlockSize = const 0
 
   txForgetValidated = forgetValidatedByronSpecGenTx
-
-  txRefScriptSize _cfg _tlst _tx = 0

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

@@ -331,8 +331,6 @@ instance LedgerSupportsMempool BlockA where
 
   txForgetValidated = forgetValidatedGenTxA
 
-  txRefScriptSize _cfg _tlst _tx = 0
-
 newtype instance TxId (GenTx BlockA) = TxIdA Int
   deriving stock   (Show, Eq, Ord, Generic)
   deriving newtype (NoThunks, Serialise)

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

@@ -267,8 +267,6 @@ instance LedgerSupportsMempool BlockB where
 
   txForgetValidated = \case {}
 
-  txRefScriptSize _cfg _tlst _tx = 0
-
 data instance TxId (GenTx BlockB)
   deriving stock    (Show, Eq, Ord, Generic)
   deriving anyclass (NoThunks, Serialise)

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

@@ -153,8 +153,6 @@ instance Ledger.LedgerSupportsMempool TestBlock where
 
   txForgetValidated (ValidatedGenTx tx) = tx
 
-  txRefScriptSize _cfg _tlst _tx = 0
-
 newtype instance Ledger.TxId (Ledger.GenTx TestBlock) = TestBlockTxId Tx
   deriving stock (Generic)
   deriving newtype (Show, Ord, Eq)

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

@@ -5,7 +5,6 @@
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE GADTs                #-}
-{-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
@@ -125,40 +124,6 @@ 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,12 +624,6 @@ 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,8 +127,6 @@ 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