Merge pull request #5140 from IntersectMBO/td/refactor-max-refscript-size-check

Refactor max refscript size check

Author: teodanciu

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.14.0.0
 
+* Add `Generic` instance for `AlonzoBbodyEvent`
 * Fix `AlonzoPlutusPurpose` CBOR(Group) instances. #5135
   * Reset shuffled serialization indexes for `AlonzoPlutusPurpose AsItem`.
 * Deprecated `toAlonzoTransitionConfigPairs`

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs

@@ -86,6 +86,7 @@ data AlonzoBbodyPredFailure era
 
 newtype AlonzoBbodyEvent era
   = ShelleyInAlonzoEvent (ShelleyBbodyEvent era)
+  deriving (Generic)
 
 type instance EraRuleFailure "BBODY" AlonzoEra = AlonzoBbodyPredFailure AlonzoEra
 

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs

@@ -145,7 +145,7 @@ spec = describe "Invalid transactions" $ do
                            _ -> error "Expected non-empty outputs"
                        )
 
-            txInAt (0 :: Int)
+            txInAt 0
               <$> withPostFixup
                 (fixupResetAddrWits <$> resetTxOutDataHash)
                 (submitTx tx)

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Valid.hs

@@ -62,7 +62,7 @@ spec = describe "Valid transactions" $ do
       datumHash = hashData @era $ Data (P.I 123)
       txOut = mkBasicTxOut addr (inject amount) & dataHashTxOutL .~ SJust datumHash
       tx1 = mkBasicTx mkBasicTxBody & bodyTxL . outputsTxBodyL .~ [txOut]
-    txIn <- txInAt (0 :: Int) <$> submitTx tx1
+    txIn <- txInAt 0 <$> submitTx tx1
     let
       tx2 = mkBasicTx mkBasicTxBody & bodyTxL . inputsTxBodyL .~ [txIn]
     submitTx_ tx2

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs

@@ -179,3 +179,7 @@ instance
 instance
   ToExpr (PredicateFailure (EraRule "LEDGERS" era)) =>
   ToExpr (AlonzoBbodyPredFailure era)
+
+instance
+  ToExpr (Event (EraRule "LEDGERS" era)) =>
+  ToExpr (AlonzoBbodyEvent era)

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxoSpec.hs

@@ -59,7 +59,7 @@ spec = describe "UTXO" $ do
         submitTx $
           mkBasicTx mkBasicTxBody
             & bodyTxL . outputsTxBodyL .~ SSeq.singleton txOut
-      let txIn = txInAt (0 :: Integer) tx
+      let txIn = txInAt 0 tx
       majorVer <- pvMajor <$> getsPParams ppProtocolVersionL
       when (majorVer < natVersion @9 || majorVer > natVersion @10) $
         submitTx_ @era $

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -13,6 +14,9 @@ module Test.Cardano.Ledger.Babbage.ImpTest (
   module Test.Cardano.Ledger.Alonzo.ImpTest,
   produceRefScript,
   produceRefScripts,
+  produceRefScriptsTx,
+  mkTxWithRefInputs,
+  submitTxWithRefInputs,
 ) where
 
 import Cardano.Ledger.Alonzo.Tx (IsValid (..))
@@ -35,6 +39,7 @@ import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Data.Maybe (isNothing)
 import qualified Data.Sequence.Strict as SSeq
+import qualified Data.Set as Set
 import GHC.Stack (HasCallStack)
 import Lens.Micro
 import Test.Cardano.Ledger.Alonzo.ImpTest
@@ -120,12 +125,37 @@ produceRefScripts ::
   NonEmpty (Script era) ->
   ImpTestM era (NonEmpty TxIn)
 produceRefScripts scripts = do
+  txId <- txIdTx <$> produceRefScriptsTx scripts
+  pure $ NE.zipWith (\_ -> mkTxInPartial txId) scripts (0 :| [1 ..])
+
+produceRefScriptsTx ::
+  (ShelleyEraImp era, BabbageEraTxOut era) =>
+  NonEmpty (Script era) ->
+  ImpTestM era (Tx era)
+produceRefScriptsTx scripts = do
   pp <- getsNES $ nesEsL . curPParamsEpochStateL
   txOuts <- forM scripts $ \script -> do
     addr <- freshKeyAddr_
     let txOutZero =
           mkBasicTxOut addr mempty & referenceScriptTxOutL .~ SJust script
     pure $ setMinCoinTxOut pp txOutZero
   let txBody = mkBasicTxBody & outputsTxBodyL .~ SSeq.fromList (NE.toList txOuts)
-  txId <- txIdTx <$> submitTx (mkBasicTx txBody)
-  pure $ NE.zipWith (\_ -> mkTxInPartial txId) scripts (0 :| [1 ..])
+  submitTx (mkBasicTx txBody)
+
+mkTxWithRefInputs ::
+  (ShelleyEraImp era, BabbageEraTxBody era) =>
+  TxIn ->
+  NonEmpty TxIn ->
+  Tx era
+mkTxWithRefInputs txIn refIns =
+  mkBasicTx $
+    mkBasicTxBody
+      & referenceInputsTxBodyL .~ Set.fromList (NE.toList refIns)
+      & inputsTxBodyL .~ [txIn]
+
+submitTxWithRefInputs ::
+  (ShelleyEraImp era, BabbageEraTxBody era) =>
+  TxIn ->
+  NonEmpty TxIn ->
+  ImpTestM era (Tx era)
+submitTxWithRefInputs txIn refIns = submitTx $ mkTxWithRefInputs txIn refIns

eras/conway/impl/CHANGELOG.md

@@ -2,11 +2,13 @@
 
 ## 1.20.0.0
 
-- Move some hard-fork triggers and export them from `Cardano.Ledger.Conway` module.
+* Add `AlonzoEraTx` constraint to `STS` instance for `ConwayBBODY`
+* Add `totalRefScriptSizeInBlock`
+* Move some hard-fork triggers and export them from `Cardano.Ledger.Conway` module.
   - `bootstrapPhase` to `hardforkConwayBootstrapPhase`.
   - `disallowUnelectedCommitteeFromVoting` to `hardforkConwayDisallowUnelectedCommitteeFromVoting`.
-- Add `UnelectedCommitteeVoters` to `ConwayGovPredFailure` #5091
-- Change the type of `authorizedELectedCommitteeCredentials` to
+* Add `UnelectedCommitteeVoters` to `ConwayGovPredFailure` #5091
+* Change the type of `authorizedELectedCommitteeCredentials` to
   `StrictMaybe (Committee era) -> CommitteeState era -> Set.Set (Credential 'HotCommitteeRole)` #5091
 * Deprecated `toConwayTransitionConfigPairs`
 * Fixed `FromJSON` instance for `TransitionConfig ConwayEra`

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -21,6 +22,7 @@ module Cardano.Ledger.Conway.Rules.Bbody (
   maxRefScriptSizePerBlock,
   alonzoToConwayBbodyPredFailure,
   shelleyToConwayBbodyPredFailure,
+  totalRefScriptSizeInBlock,
 ) where
 
 import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure)
@@ -35,13 +37,21 @@ import Cardano.Ledger.Alonzo.Rules (
  )
 import qualified Cardano.Ledger.Alonzo.Rules as Alonzo (AlonzoBbodyPredFailure (..))
 import Cardano.Ledger.Alonzo.Scripts (ExUnits (..))
-import Cardano.Ledger.Alonzo.Tx (AlonzoTx)
+import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx, AlonzoTx, IsValid (..), isValidTxL)
 import Cardano.Ledger.Alonzo.TxSeq (AlonzoTxSeq, txSeqTxns)
 import Cardano.Ledger.Alonzo.TxWits (AlonzoEraTxWits (..))
 import Cardano.Ledger.BHeaderView (BHeaderView (..))
+import Cardano.Ledger.Babbage.Collateral (collOuts)
 import Cardano.Ledger.Babbage.Core (BabbageEraTxBody)
 import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure)
-import Cardano.Ledger.BaseTypes (Mismatch (..), Relation (..), ShelleyBase)
+import Cardano.Ledger.BaseTypes (
+  Mismatch (..),
+  ProtVer,
+  Relation (..),
+  ShelleyBase,
+  natVersion,
+  pvMajor,
+ )
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
 import Cardano.Ledger.Block (Block (..))
@@ -71,6 +81,7 @@ import Cardano.Ledger.Shelley.Rules (
   ShelleyUtxowPredFailure,
  )
 import qualified Cardano.Ledger.Shelley.Rules as Shelley (ShelleyBbodyPredFailure (..))
+import Cardano.Ledger.Shelley.UTxO (UTxO (..), txouts, unUTxO)
 import Control.State.Transition (
   Embed (..),
   STS (..),
@@ -80,10 +91,14 @@ import Control.State.Transition (
   (?!),
  )
 import Data.Foldable (Foldable (foldMap'))
+import qualified Data.Foldable as F (foldl')
+import qualified Data.Map.Strict as Map
 import Data.Monoid (Sum (getSum))
 import qualified Data.Monoid as Monoid (Sum (..))
 import Data.Sequence (Seq)
+import Data.Sequence.Strict (StrictSeq (..))
 import GHC.Generics (Generic)
+import Lens.Micro ((^.))
 import NoThunks.Class (NoThunks (..))
 
 -- | In the next era this will become a proper protocol parameter.
@@ -242,7 +257,7 @@ instance
   , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era
   , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
   , EraRule "BBODY" era ~ ConwayBBODY era
-  , EraTx era
+  , AlonzoEraTx era
   , BabbageEraTxBody era
   ) =>
   STS (ConwayBBODY era)
@@ -266,27 +281,26 @@ conwayBbodyTransition ::
   forall era.
   ( Signal (EraRule "BBODY" era) ~ Block BHeaderView era
   , State (EraRule "BBODY" era) ~ ShelleyBbodyState era
+  , Environment (EraRule "BBODY" era) ~ BbodyEnv era
   , State (EraRule "LEDGERS" era) ~ LedgerState era
   , TxSeq era ~ AlonzoTxSeq era
-  , Tx era ~ AlonzoTx era
   , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era
   , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
-  , EraTx era
+  , AlonzoEraTx era
   , BabbageEraTxBody era
   ) =>
   TransitionRule (EraRule "BBODY" era)
 conwayBbodyTransition = do
   judgmentContext
     >>= \( TRC
-             ( _
+             ( BbodyEnv pp _
                , state@(BbodyState ls _)
                , Block _ txsSeq
                )
            ) -> do
         let utxo = utxosUtxo (lsUTxOState ls)
             txs = txSeqTxns txsSeq
-            totalRefScriptSize =
-              getSum $ foldMap' (Monoid.Sum . txNonDistinctRefScriptsSize utxo) txs
+            totalRefScriptSize = totalRefScriptSizeInBlock (pp ^. ppProtocolVersionL) txs utxo
         totalRefScriptSize
           <= maxRefScriptSizePerBlock
             ?! injectFailure
@@ -308,3 +322,18 @@ instance
   where
   wrapFailed = LedgersFailure
   wrapEvent = ShelleyInAlonzoEvent . LedgersEvent
+
+totalRefScriptSizeInBlock ::
+  (AlonzoEraTx era, BabbageEraTxBody era) => ProtVer -> StrictSeq (Tx era) -> UTxO era -> Int
+totalRefScriptSizeInBlock protVer txs (UTxO utxo)
+  | pvMajor protVer <= natVersion @10 =
+      getSum $ foldMap' (Monoid.Sum . txNonDistinctRefScriptsSize (UTxO utxo)) txs
+  | otherwise =
+      snd $ F.foldl' accum (utxo, 0) txs
+  where
+    accum (!accUtxo, !accSum) tx =
+      let updatedUtxo = accUtxo `Map.union` unUTxO toAdd
+          toAdd
+            | IsValid True <- tx ^. isValidTxL = txouts $ tx ^. bodyTxL
+            | otherwise = collOuts $ tx ^. bodyTxL
+       in (updatedUtxo, accSum + txNonDistinctRefScriptsSize (UTxO accUtxo) tx)

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs

@@ -90,6 +90,7 @@ spec ::
   , ToExpr (Event (EraRule "ENACT" era))
   , Eq (Event (EraRule "ENACT" era))
   , Typeable (Event (EraRule "ENACT" era))
+  , ToExpr (Event (EraRule "BBODY" era))
   ) =>
   Spec
 spec = do
@@ -125,6 +126,7 @@ conwaySpec ::
   , ToExpr (Event (EraRule "ENACT" era))
   , Eq (Event (EraRule "ENACT" era))
   , Typeable (Event (EraRule "ENACT" era))
+  , ToExpr (Event (EraRule "BBODY" era))
   ) =>
   SpecWith (ImpInit (LedgerSpec era))
 conwaySpec = do