Skip to content

Commit

Permalink
Merge pull request #4766 from IntersectMBO/td/nonzero-costmodels-in-t…
Browse files Browse the repository at this point in the history
…ests

Use non-zero costmodels in Imp tests
  • Loading branch information
teodanciu authored Dec 6, 2024
2 parents d99e0cd + b5b8b4a commit e9f9b18
Show file tree
Hide file tree
Showing 6 changed files with 42 additions and 32 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -224,7 +224,7 @@ spec = describe "Invalid transactions" $ do
let scriptHash = alwaysSucceedsWithDatumHash
scriptInput <- produceScript scriptHash
(collateralHash, collateralAddr) <- freshKeyAddr
collateralInput <- sendCoinTo collateralAddr $ Coin 1_000_000
collateralInput <- sendCoinTo collateralAddr $ Coin 3_000_000
let
tx =
mkBasicTx mkBasicTxBody
Expand Down Expand Up @@ -275,7 +275,7 @@ spec = describe "Invalid transactions" $ do
, mkDelegStakeTxCert cred poolId -- 1: Needs a redeemer
, mkDelegStakeTxCert cred poolId -- 2: Duplicate, ignored, no redeemer needed
]
redeemer = (Data (P.I 32), ExUnits 5000 5000)
redeemer = (Data (P.I 32), ExUnits 5000 1_000_000)
redeemers = Map.fromList [(mkCertifyingPurpose (AsIx i), redeemer) | i <- [1 .. 2]]
tx =
mkBasicTx mkBasicTxBody
Expand Down
44 changes: 31 additions & 13 deletions eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs
Original file line number Diff line number Diff line change
Expand Up @@ -132,7 +132,7 @@ class
makeCollateralInput :: ShelleyEraImp era => ImpTestM era (TxIn (EraCrypto era))
makeCollateralInput = do
-- TODO: make more accurate
let collateral = Coin 10_000_000
let collateral = Coin 30_000_000
addr <- freshKeyAddr_
withFixup fixupTx $ sendCoinTo addr collateral

Expand Down Expand Up @@ -198,14 +198,9 @@ fixupRedeemers ::
fixupRedeemers tx = impAnn "fixupRedeemers" $ do
contexts <- impGetPlutusContexts tx
pp <- getsNES $ nesEsL . curPParamsEpochStateL
let
maxExUnit = pp ^. ppMaxTxExUnitsL
mkNewMaxRedeemers (prpIdx, _, ScriptTestContext _ (PlutusArgs dat _)) =
(hoistPlutusPurpose @era toAsIx prpIdx, (Data dat, maxExUnit))
Redeemers oldRedeemers = tx ^. witsTxL . rdmrsTxWitsL
newMaxRedeemers = Map.fromList (mkNewMaxRedeemers <$> contexts)
txWithMaxExUnits =
tx & witsTxL . rdmrsTxWitsL .~ Redeemers newMaxRedeemers
let Redeemers oldRedeemers = tx ^. witsTxL . rdmrsTxWitsL
txWithMaxExUnits <- txWithMaxRedeemers tx
let Redeemers newMaxRedeemers = txWithMaxExUnits ^. witsTxL . rdmrsTxWitsL
utxo <- getUTxO
Globals {systemStart, epochInfo} <- use impGlobalsL
let reports = evalTxExUnits pp txWithMaxExUnits utxo epochInfo systemStart
Expand Down Expand Up @@ -233,6 +228,21 @@ fixupRedeemers tx = impAnn "fixupRedeemers" $ do
tx
& witsTxL . rdmrsTxWitsL .~ Redeemers (Map.unions [oldRedeemers, newRedeemers, newMaxRedeemers])

txWithMaxRedeemers ::
forall era.
AlonzoEraImp era =>
Tx era ->
ImpTestM era (Tx era)
txWithMaxRedeemers tx = do
contexts <- impGetPlutusContexts tx
pp <- getsNES $ nesEsL . curPParamsEpochStateL
let
maxExUnit = pp ^. ppMaxTxExUnitsL
mkNewMaxRedeemers (prpIdx, _, ScriptTestContext _ (PlutusArgs dat _)) =
(hoistPlutusPurpose @era toAsIx prpIdx, (Data dat, maxExUnit))
newMaxRedeemers = Map.fromList (mkNewMaxRedeemers <$> contexts)
pure $ tx & witsTxL . rdmrsTxWitsL .~ Redeemers newMaxRedeemers

fixupScriptWits ::
forall era.
AlonzoEraImp era =>
Expand Down Expand Up @@ -353,12 +363,21 @@ alonzoFixupTx =
>=> fixupOutputDatums
>=> fixupDatums
>=> fixupRedeemerIndices
>=> fixupTxOuts
>=> alonzoFixupFees
>=> fixupRedeemers
>=> fixupPPHash
>=> fixupTxOuts
>=> fixupFees
>=> updateAddrTxWits

alonzoFixupFees :: forall era. (HasCallStack, AlonzoEraImp era) => Tx era -> ImpTestM era (Tx era)
alonzoFixupFees tx = do
let originalRedeemers = tx ^. witsTxL . rdmrsTxWitsL
txWithMax <- txWithMaxRedeemers tx
-- we are maximizing the fees relative to the the redeemers, in order to break the circular dependency
-- of the fee being impacted by the redeemers and viceversa
txWithFees <- fixupFees txWithMax
pure $ txWithFees & witsTxL . rdmrsTxWitsL .~ originalRedeemers

mkScriptTestEntry ::
(PlutusLanguage l, Crypto c) =>
Plutus l ->
Expand Down Expand Up @@ -413,8 +432,7 @@ instance
pure
AlonzoGenesis
{ agCoinsPerUTxOWord = CoinPerWord (Coin 34482)
, -- TODO: Replace with correct cost model.
agCostModels = testingCostModels [PlutusV1]
, agCostModels = testingCostModels [PlutusV1]
, agPrices =
Prices
{ prMem = 577 %! 10_000
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -108,7 +108,7 @@ spec = describe "BBODY" $ do
mkTxIn :: ImpTestM era (TxIn (EraCrypto era))
mkTxIn = do
addr <- freshKeyAddr_
sendCoinTo addr (Coin 7_000_000)
sendCoinTo addr (Coin 8_000_000)

largeScript :: Maybe (Script era)
largeScript = do
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -321,8 +321,7 @@ instance
, ucppDRepDeposit = Coin 70_000_000
, ucppDRepActivity = EpochInterval 100
, ucppMinFeeRefScriptCostPerByte = 15 %! 1
, -- TODO: Replace with correct cost model.
ucppPlutusV3CostModel = testingCostModel PlutusV3
, ucppPlutusV3CostModel = testingCostModel PlutusV3
}
, cgConstitution = Constitution constitutionAnchor (SJust guardrailScriptHash)
, cgCommittee = committee
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -147,7 +147,7 @@ import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Block (Block)
import Cardano.Ledger.CertState (certDStateL, dsUnifiedL)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText)
import Cardano.Ledger.Crypto (Crypto (..))
import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis (..))
Expand Down Expand Up @@ -252,6 +252,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, mapMaybe)
import Data.Ratio ((%))
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
Expand Down Expand Up @@ -1010,9 +1011,10 @@ fixupFees txOriginal = impAnn "fixupFees" $ do
txNoWits = tx & bodyTxL . outputsTxBodyL %~ (:|> changeBeforeFeeTxOut)
outsBeforeFee = tx ^. bodyTxL . outputsTxBodyL
suppliedFee = txOriginal ^. bodyTxL . feeTxBodyL
fee
fee0
| suppliedFee == zero = calcMinFeeTxNativeScriptWits utxo pp txNoWits nativeScriptKeyWits
| otherwise = suppliedFee
fee = rationalToCoinViaCeiling $ coinToRational fee0 * (11 % 10)
logString "Validating change"
change <- ensureNonNegativeCoin $ changeBeforeFeeTxOut ^. coinTxOutL <-> fee
logToExpr change
Expand Down
15 changes: 3 additions & 12 deletions libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs
Original file line number Diff line number Diff line change
Expand Up @@ -106,22 +106,13 @@ testingCostModel = \case
PlutusV3 -> testingCostModelV3

testingCostModelV1 :: HasCallStack => CostModel
testingCostModelV1 =
if True
then zeroTestingCostModelV1
else mkCostModel' PlutusV1 $ snd <$> PV1.costModelParamsForTesting
testingCostModelV1 = mkCostModel' PlutusV1 $ snd <$> PV1.costModelParamsForTesting

testingCostModelV2 :: HasCallStack => CostModel
testingCostModelV2 =
if True
then zeroTestingCostModelV2
else mkCostModel' PlutusV2 $ snd <$> PV2.costModelParamsForTesting
testingCostModelV2 = mkCostModel' PlutusV2 $ snd <$> PV2.costModelParamsForTesting

testingCostModelV3 :: HasCallStack => CostModel
testingCostModelV3 =
if True
then zeroTestingCostModelV3
else mkCostModel' PlutusV3 $ snd <$> PV3.costModelParamsForTesting
testingCostModelV3 = mkCostModel' PlutusV3 $ snd <$> PV3.costModelParamsForTesting

testingEvaluationContext :: Language -> PV1.EvaluationContext
testingEvaluationContext = getCostModelEvaluationContext . testingCostModel
Expand Down

0 comments on commit e9f9b18

Please sign in to comment.