diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Scripts.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Scripts.hs index 5c1c934a109..5cfeef826f0 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Scripts.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Scripts.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -110,19 +111,17 @@ babbageInputDataHashes hashScriptMap tx (UTxO mp) = txbody = body tx spendinputs = getField @"inputs" txbody :: (Set (TxIn (Crypto era))) smallUtxo = spendinputs SplitMap.◁ mp - accum ans@(hashSet, inputSet) txin txout = + accum ans@(!hashSet, !inputSet) txin txout = case txout of - (TxOut addr _ NoDatum _) -> + TxOut addr _ NoDatum _ -> if isTwoPhaseScriptAddressFromMap @era hashScriptMap addr then (hashSet, Set.insert txin inputSet) else ans - (TxOut addr _ (DatumHash dhash) _) -> + TxOut addr _ (DatumHash dhash) _ -> if isTwoPhaseScriptAddressFromMap @era hashScriptMap addr then (Set.insert dhash hashSet, inputSet) else ans - (TxOut addr _ (Datum _) _) -> - if isTwoPhaseScriptAddressFromMap @era hashScriptMap addr - then ans -- An a TwoPhaseScript with Explict Datum and does not need a DataHash - else (hashSet, Set.insert txin inputSet) - --- FIXME -- An onePhase script with an unneeded Explict Datum, is that an error? + -- Though it is somewhat odd to allow non-two-phase-scripts to include a datum, + -- the Alonzo era already set the precedent with datum hashes, and several dapp + -- developers see this as a helpful feature. + TxOut _ _ (Datum _) _ -> ans diff --git a/libs/cardano-ledger-test/cardano-ledger-test.cabal b/libs/cardano-ledger-test/cardano-ledger-test.cabal index 8b0b38eaaa1..6b008489042 100644 --- a/libs/cardano-ledger-test/cardano-ledger-test.cabal +++ b/libs/cardano-ledger-test/cardano-ledger-test.cabal @@ -45,6 +45,7 @@ library exposed-modules: Test.Cardano.Ledger.Alonzo.Tools Test.Cardano.Ledger.BaseTypes + Test.Cardano.Ledger.Examples.BabbageFeatures Test.Cardano.Ledger.Examples.TwoPhaseValidation Test.Cardano.Ledger.Generic.Indexed Test.Cardano.Ledger.Generic.Fields diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs new file mode 100644 index 00000000000..dae2eef352e --- /dev/null +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Cardano.Ledger.Examples.BabbageFeatures where + +import qualified Cardano.Crypto.Hash as CH +import Cardano.Ledger.Address (Addr (..)) +import Cardano.Ledger.Alonzo.Data (Data (..), dataToBinaryData) +import Cardano.Ledger.Alonzo.Language (Language (..)) +import Cardano.Ledger.Alonzo.Scripts (ExUnits (..)) +import qualified Cardano.Ledger.Alonzo.Scripts as Tag (Tag (..)) +import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr (..), Redeemers (..)) +import qualified Cardano.Ledger.Babbage.TxBody as Babbage +import Cardano.Ledger.BaseTypes + ( Network (..), + StrictMaybe (..), + mkTxIxPartial, + ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Core (EraRule) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Credential + ( Credential (..), + StakeReference (..), + ) +import qualified Cardano.Ledger.Crypto as CC +import Cardano.Ledger.Era (Era (..), ValidateScript (hashScript)) +import Cardano.Ledger.Keys + ( KeyPair (..), + KeyRole (..), + hashKey, + ) +import Cardano.Ledger.Pretty.Babbage () +import Cardano.Ledger.SafeHash (hashAnnotated) +import Cardano.Ledger.Shelley.API (ProtVer (..), UTxO (..)) +import Cardano.Ledger.Shelley.LedgerState (UTxOState (..), smartUTxOState) +import Cardano.Ledger.Shelley.UTxO (makeWitnessVKey) +import Cardano.Ledger.TxIn (TxIn (..)) +import Cardano.Ledger.Val (inject) +import Control.State.Transition.Extended hiding (Assertion) +import qualified Data.Compact.SplitMap as SplitMap +import Data.Default.Class (Default (..)) +import qualified Data.Map as Map +import GHC.Stack +import qualified Plutus.V1.Ledger.Api as Plutus +import Test.Cardano.Ledger.Examples.TwoPhaseValidation + ( Expect (..), + expectedUTxO, + freeCostModel, + testUTXOW, + trustMeP, + ) +import Test.Cardano.Ledger.Generic.Fields + ( PParamsField (..), + TxBodyField (..), + TxField (..), + TxOutField (..), + WitnessesField (..), + ) +import Test.Cardano.Ledger.Generic.PrettyCore () +import Test.Cardano.Ledger.Generic.Proof +import Test.Cardano.Ledger.Generic.Scriptic (PostShelley, Scriptic (..)) +import Test.Cardano.Ledger.Generic.Updaters +import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId) +import Test.Cardano.Ledger.Shelley.Utils (RawSeed (..), mkKeyPair) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase) + +-- ======================= +-- Setup the initial state +-- ======================= + +scriptAddr :: forall era. (Scriptic era) => Proof era -> Core.Script era -> Addr (Crypto era) +scriptAddr _pf s = Addr Testnet pCred sCred + where + pCred = ScriptHashObj . hashScript @era $ s + (_ssk, svk) = mkKeyPair @(Crypto era) (RawSeed 0 0 0 0 0) + sCred = StakeRefBase . KeyHashObj . hashKey $ svk + +someKeys :: forall era. Era era => Proof era -> KeyPair 'Payment (Crypto era) +someKeys _pf = KeyPair vk sk + where + (sk, vk) = mkKeyPair @(Crypto era) (RawSeed 1 1 1 1 1) + +plainAddr :: forall era. Era era => Proof era -> Addr (Crypto era) +plainAddr pf = Addr Testnet pCred sCred + where + (_ssk, svk) = mkKeyPair @(Crypto era) (RawSeed 0 0 0 0 2) + pCred = KeyHashObj . hashKey . vKey $ someKeys pf + sCred = StakeRefBase . KeyHashObj . hashKey $ svk + +somePlainOutput :: Scriptic era => Proof era -> Core.TxOut era +somePlainOutput pf = + newTxOut pf [Address $ plainAddr pf, Amount (inject $ Coin 1000)] + +mkGenesisTxIn :: (CH.HashAlgorithm (CC.HASH crypto), HasCallStack) => Integer -> TxIn crypto +mkGenesisTxIn = TxIn genesisId . mkTxIxPartial + +collateralOutput :: Scriptic era => Proof era -> Core.TxOut era +collateralOutput pf = + newTxOut pf [Address $ plainAddr pf, Amount (inject $ Coin 5)] + +datumExample1 :: Data era +datumExample1 = Data (Plutus.I 123) + +inlineDatumOutput :: forall era. (Scriptic era) => Proof era -> Core.TxOut era +inlineDatumOutput pf = + newTxOut + pf + [ Address (scriptAddr pf (alwaysAlt 3 pf)), + Amount (inject $ Coin 5000), + Datum (Babbage.Datum . dataToBinaryData $ datumExample1 @era) + ] + +referenceScriptOutput :: forall era. (Scriptic era) => Proof era -> Core.TxOut era +referenceScriptOutput pf = + newTxOut + pf + [ Address (plainAddr pf), + Amount (inject $ Coin 10), + Datum (Babbage.Datum . dataToBinaryData $ datumExample1 @era), + RefScript (SJust $ alwaysAlt 3 pf) + ] + +initUTxO :: PostShelley era => Proof era -> UTxO era +initUTxO pf = + UTxO $ + SplitMap.fromList $ + [ (mkGenesisTxIn 1, inlineDatumOutput pf), + (mkGenesisTxIn 2, referenceScriptOutput pf) + ] + ++ map (\i -> (mkGenesisTxIn i, somePlainOutput pf)) [3 .. 8] + ++ map (\i -> (mkGenesisTxIn i, collateralOutput pf)) [11 .. 18] + +defaultPPs :: [PParamsField era] +defaultPPs = + [ Costmdls $ Map.fromList [(PlutusV1, freeCostModel), (PlutusV2, freeCostModel)], + MaxValSize 1000000000, + MaxTxExUnits $ ExUnits 1000000 1000000, + MaxBlockExUnits $ ExUnits 1000000 1000000, + ProtocolVersion $ ProtVer 7 0, + CollateralPercentage 100 + ] + +pp :: Proof era -> Core.PParams era +pp pf = newPParams pf defaultPPs + +-- ========================================================================= +-- Example 1: Spend a EUTxO with an inline datum +-- ========================================================================= + +redeemerExample1 :: Data era +redeemerExample1 = Data (Plutus.I 42) + +validatingRedeemersEx1 :: Era era => Redeemers era +validatingRedeemersEx1 = + Redeemers $ + Map.singleton (RdmrPtr Tag.Spend 0) (redeemerExample1, ExUnits 5000 5000) + +outEx1 :: Scriptic era => Proof era -> Core.TxOut era +outEx1 pf = newTxOut pf [Address (plainAddr pf), Amount (inject $ Coin 4995)] + +inlineDatumTxBody :: Scriptic era => Proof era -> Core.TxBody era +inlineDatumTxBody pf = + newTxBody + pf + [ Inputs' [mkGenesisTxIn 1], + RefInputs' [mkGenesisTxIn 2], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], + Txfee (Coin 5), + WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV2] validatingRedeemersEx1 mempty) + ] + +inlineDatumTx :: + forall era. + ( Scriptic era, + GoodCrypto (Crypto era) + ) => + Proof era -> + Core.Tx era +inlineDatumTx pf = + newTx + pf + [ Body (inlineDatumTxBody pf), + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (inlineDatumTxBody pf)) (someKeys pf)], + ScriptWits' [alwaysAlt 3 pf], + RdmrWits validatingRedeemersEx1 + ] + ] + +utxoEx1 :: forall era. PostShelley era => Proof era -> UTxO era +utxoEx1 pf = expectedUTxO (initUTxO pf) (ExpectSuccess (inlineDatumTxBody pf) (outEx1 pf)) 1 + +utxoStEx1 :: + forall era. + (Default (State (EraRule "PPUP" era)), PostShelley era) => + Proof era -> + UTxOState era +utxoStEx1 pf = smartUTxOState (utxoEx1 pf) (Coin 0) (Coin 5) def + +-- ========================================================================= +-- Example 2: Use a reference script +-- ========================================================================= + +outEx2 :: Scriptic era => Proof era -> Core.TxOut era +outEx2 pf = newTxOut pf [Address (plainAddr pf), Amount (inject $ Coin 4995)] + +referenceScriptTxBody :: Scriptic era => Proof era -> Core.TxBody era +referenceScriptTxBody pf = + newTxBody + pf + [ Inputs' [mkGenesisTxIn 1], + RefInputs' [mkGenesisTxIn 2], + Collateral' [mkGenesisTxIn 11], + Outputs' [outEx1 pf], + Txfee (Coin 5), + WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV2] validatingRedeemersEx1 mempty) + ] + +referenceScriptTx :: + forall era. + ( Scriptic era, + GoodCrypto (Crypto era) + ) => + Proof era -> + Core.Tx era +referenceScriptTx pf = + newTx + pf + [ Body (referenceScriptTxBody pf), + WitnessesI + [ AddrWits' [makeWitnessVKey (hashAnnotated (referenceScriptTxBody pf)) (someKeys pf)], + RdmrWits validatingRedeemersEx1 + ] + ] + +utxoEx2 :: forall era. PostShelley era => Proof era -> UTxO era +utxoEx2 pf = expectedUTxO (initUTxO pf) (ExpectSuccess (referenceScriptTxBody pf) (outEx2 pf)) 1 + +utxoStEx2 :: + forall era. + (Default (State (EraRule "PPUP" era)), PostShelley era) => + Proof era -> + UTxOState era +utxoStEx2 pf = smartUTxOState (utxoEx2 pf) (Coin 0) (Coin 5) def + +testU :: + forall era. + ( GoodCrypto (Crypto era), + Default (State (EraRule "PPUP" era)), + PostShelley era + ) => + Proof era -> + Core.Tx era -> + Either [(PredicateFailure (Core.EraRule "UTXOW" era))] (State (Core.EraRule "UTXOW" era)) -> + Assertion +testU pf tx expect = testUTXOW (UTXOW pf) (initUTxO pf) (pp pf) tx expect + +genericBabbageFeatures :: + forall era. + ( State (EraRule "UTXOW" era) ~ UTxOState era, + GoodCrypto (Crypto era), + Default (State (EraRule "PPUP" era)), + PostShelley era + ) => + Proof era -> + TestTree +genericBabbageFeatures pf = + testGroup + (show pf ++ " UTXOW examples") + [ testGroup + "valid transactions" + [ testCase "inline datum" $ + testU + pf + (trustMeP pf True $ inlineDatumTx pf) + (Right . utxoStEx1 $ pf), + testCase "reference script" $ + testU + pf + (trustMeP pf True $ referenceScriptTx pf) + (Right . utxoStEx2 $ pf) + ] + ] + +babbageFeatures :: TestTree +babbageFeatures = + testGroup + "Babbage Features" + [ genericBabbageFeatures (Babbage Mock) + ] diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs index f99462ede33..449ea2c5916 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs @@ -293,9 +293,9 @@ initialUtxoSt :: ( Default (State (EraRule "PPUP" era)), PostShelley era ) => - Proof era -> + UTxO era -> UTxOState era -initialUtxoSt pf = smartUTxOState (initUTxO pf) (Coin 0) (Coin 0) def +initialUtxoSt utxo = smartUTxOState utxo (Coin 0) (Coin 0) def -- | This is a helper type for the expectedUTxO function. -- ExpectSuccess indicates that we created a valid transaction @@ -316,18 +316,27 @@ data Expect era = ExpectSuccess (Core.TxBody era) (Core.TxOut era) | ExpectFailu expectedUTxO :: forall era. (HasCallStack, PostShelley era) => - Proof era -> + UTxO era -> Expect era -> Integer -> UTxO era -expectedUTxO pf ex idx = UTxO utxo +expectedUTxO initUtxo ex idx = UTxO utxo where utxo = case ex of ExpectSuccess txb newOut -> SplitMap.insert (TxIn (txid txb) minBound) newOut (filteredUTxO (mkTxIxPartial idx)) ExpectFailure -> filteredUTxO (mkTxIxPartial (10 + idx)) filteredUTxO :: TxIx -> SplitMap.SplitMap (TxIn (Crypto era)) (Core.TxOut era) - filteredUTxO x = SplitMap.filterWithKey (\(TxIn _ i) _ -> i /= x) $ unUTxO (initUTxO pf) + filteredUTxO x = SplitMap.filterWithKey (\(TxIn _ i) _ -> i /= x) $ unUTxO initUtxo + +expectedUTxO' :: + forall era. + (HasCallStack, PostShelley era) => + Proof era -> + Expect era -> + Integer -> + UTxO era +expectedUTxO' pf ex idx = expectedUTxO (initUTxO pf) ex idx keyBy :: Ord k => (a -> k) -> [a] -> Map k a keyBy f xs = Map.fromList $ (\x -> (f x, x)) <$> xs @@ -440,7 +449,7 @@ validatingTx pf = ] utxoEx1 :: forall era. PostShelley era => Proof era -> UTxO era -utxoEx1 pf = expectedUTxO pf (ExpectSuccess (validatingBody pf) (outEx1 pf)) 1 +utxoEx1 pf = expectedUTxO' pf (ExpectSuccess (validatingBody pf) (outEx1 pf)) 1 utxoStEx1 :: forall era. @@ -514,7 +523,7 @@ notValidatingTx pf = ] utxoEx2 :: PostShelley era => Proof era -> UTxO era -utxoEx2 pf = expectedUTxO pf ExpectFailure 2 +utxoEx2 pf = expectedUTxO' pf ExpectFailure 2 utxoStEx2 :: (Default (State (EraRule "PPUP" era)), PostShelley era) => @@ -571,7 +580,7 @@ validatingTxWithCert pf = ] utxoEx3 :: PostShelley era => Proof era -> UTxO era -utxoEx3 pf = expectedUTxO pf (ExpectSuccess (validatingBodyWithCert pf) (outEx3 pf)) 3 +utxoEx3 pf = expectedUTxO' pf (ExpectSuccess (validatingBodyWithCert pf) (outEx3 pf)) 3 utxoStEx3 :: (Default (State (EraRule "PPUP" era)), PostShelley era) => @@ -628,7 +637,7 @@ notValidatingTxWithCert pf = ] utxoEx4 :: PostShelley era => Proof era -> UTxO era -utxoEx4 pf = expectedUTxO pf ExpectFailure 4 +utxoEx4 pf = expectedUTxO' pf ExpectFailure 4 utxoStEx4 :: (Default (State (EraRule "PPUP" era)), PostShelley era) => @@ -687,7 +696,7 @@ validatingTxWithWithdrawal pf = ] utxoEx5 :: PostShelley era => Proof era -> UTxO era -utxoEx5 pf = expectedUTxO pf (ExpectSuccess (validatingBodyWithWithdrawal pf) (outEx5 pf)) 5 +utxoEx5 pf = expectedUTxO' pf (ExpectSuccess (validatingBodyWithWithdrawal pf) (outEx5 pf)) 5 utxoStEx5 :: (Default (State (EraRule "PPUP" era)), PostShelley era) => @@ -746,7 +755,7 @@ notValidatingTxWithWithdrawal pf = ] utxoEx6 :: PostShelley era => Proof era -> UTxO era -utxoEx6 pf = expectedUTxO pf ExpectFailure 6 +utxoEx6 pf = expectedUTxO' pf ExpectFailure 6 utxoStEx6 :: (Default (State (EraRule "PPUP" era)), PostShelley era) => @@ -804,7 +813,7 @@ validatingTxWithMint pf = ] utxoEx7 :: forall era. (HasTokens era, PostShelley era) => Proof era -> UTxO era -utxoEx7 pf = expectedUTxO pf (ExpectSuccess (validatingBodyWithMint pf) (outEx7 pf)) 7 +utxoEx7 pf = expectedUTxO' pf (ExpectSuccess (validatingBodyWithMint pf) (outEx7 pf)) 7 utxoStEx7 :: forall era. @@ -863,7 +872,7 @@ notValidatingTxWithMint pf = ] utxoEx8 :: PostShelley era => Proof era -> UTxO era -utxoEx8 pf = expectedUTxO pf ExpectFailure 8 +utxoEx8 pf = expectedUTxO' pf ExpectFailure 8 utxoStEx8 :: (Default (State (EraRule "PPUP" era)), PostShelley era) => @@ -1012,7 +1021,7 @@ okSupplimentaryDatumTx pf = ] utxoEx10 :: forall era. PostShelley era => Proof era -> UTxO era -utxoEx10 pf = expectedUTxO pf (ExpectSuccess (okSupplimentaryDatumTxBody pf) (outEx10 pf)) 3 +utxoEx10 pf = expectedUTxO' pf (ExpectSuccess (okSupplimentaryDatumTxBody pf) (outEx10 pf)) 3 utxoStEx10 :: forall era. @@ -1066,7 +1075,7 @@ multipleEqualCertsTx pf = ] utxoEx11 :: PostShelley era => Proof era -> UTxO era -utxoEx11 pf = expectedUTxO pf (ExpectSuccess (multipleEqualCertsBody pf) (outEx3 pf)) 3 +utxoEx11 pf = expectedUTxO' pf (ExpectSuccess (multipleEqualCertsBody pf) (outEx3 pf)) 3 utxoStEx11 :: (Default (State (EraRule "PPUP" era)), PostShelley era) => @@ -1111,7 +1120,7 @@ nonScriptOutWithDatumTx pf = ] utxoEx12 :: PostShelley era => Proof era -> UTxO era -utxoEx12 pf = expectedUTxO pf (ExpectSuccess (nonScriptOutWithDatumTxBody pf) (outEx12 pf)) 103 +utxoEx12 pf = expectedUTxO' pf (ExpectSuccess (nonScriptOutWithDatumTxBody pf) (outEx12 pf)) 103 utxoStEx12 :: ( Default (State (EraRule "PPUP" era)), @@ -1703,9 +1712,10 @@ initialBBodyState :: PostShelley era ) => Proof era -> + UTxO era -> BbodyState era -initialBBodyState pf = - BbodyState (LedgerState (initialUtxoSt pf) (dpstate pf)) (BlocksMade mempty) +initialBBodyState pf utxo = + BbodyState (LedgerState (initialUtxoSt utxo) (dpstate pf)) (BlocksMade mempty) coldKeys :: CC.Crypto c => KeyPair 'BlockIssuer c coldKeys = KeyPair vk sk @@ -1867,13 +1877,14 @@ testUTXOWwith :: ) => WitRule "UTXOW" era -> (Result era -> Result era -> Assertion) -> + UTxO era -> Core.PParams era -> Core.Tx era -> Result era -> Assertion -testUTXOWwith wit@(UTXOW proof) cont pparams tx expected = +testUTXOWwith wit@(UTXOW proof) cont utxo pparams tx expected = let env = utxoEnv pparams - state = initialUtxoSt proof + state = initialUtxoSt utxo in case proof of Alonzo _ -> runSTS wit (TRC (env, state, tx)) (cont expected) Babbage _ -> runSTS wit (TRC (env, state, tx)) (cont expected) @@ -1955,6 +1966,7 @@ testUTXOWsubset, PostShelley era ) => WitRule "UTXOW" era -> + UTxO era -> Core.PParams era -> Core.Tx era -> Either [(PredicateFailure (Core.EraRule "UTXOW" era))] (State (Core.EraRule "UTXOW" era)) -> @@ -1966,14 +1978,26 @@ testUTXOW wit@(UTXOW (Babbage _)) = testUTXOWwith wit genericCont testUTXOW (UTXOW other) = error ("Cannot use testUTXOW in era " ++ show other) -- | Use a subset test on the expected and computed [PredicateFailure] -testUTXOWsubset wit@(UTXOW (Alonzo _)) = testUTXOWwith wit subsetCont -testUTXOWsubset wit@(UTXOW (Babbage _)) = testUTXOWwith wit subsetCont -testUTXOWsubset (UTXOW other) = error ("Cannot use testUTXOW in era " ++ show other) +testUTXOWsubset wit@(UTXOW (Alonzo _)) utxo = testUTXOWwith wit subsetCont utxo +testUTXOWsubset wit@(UTXOW (Babbage _)) utxo = testUTXOWwith wit subsetCont utxo +testUTXOWsubset (UTXOW other) _ = error ("Cannot use testUTXOW in era " ++ show other) + +testU :: + forall era. + ( GoodCrypto (Crypto era), + Default (State (EraRule "PPUP" era)), + PostShelley era + ) => + Proof era -> + Core.Tx era -> + Either [(PredicateFailure (Core.EraRule "UTXOW" era))] (State (Core.EraRule "UTXOW" era)) -> + Assertion +testU pf tx expect = testUTXOW (UTXOW pf) (initUTxO pf) (pp pf) tx expect -- | Use a test where any two (ValidationTagMismatch x y) failures match regardless of 'x' and 'y' -specialCase wit@(UTXOW proof) pparam tx expected = +specialCase wit@(UTXOW proof) utxo pparam tx expected = let env = utxoEnv pparam - state = initialUtxoSt proof + state = initialUtxoSt utxo in case proof of Alonzo _ -> runSTS wit (TRC (env, state, tx)) (specialCont proof expected) Babbage _ -> runSTS wit (TRC (env, state, tx)) (specialCont proof expected) @@ -2031,100 +2055,85 @@ alonzoUTXOWexamplesB pf = [ testGroup "valid transactions" [ testCase "validating SPEND script" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ validatingTx pf) (Right . utxoStEx1 $ pf), testCase "not validating SPEND script" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf False $ notValidatingTx pf) (Right . utxoStEx2 $ pf), testCase "validating CERT script" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ validatingTxWithCert pf) (Right . utxoStEx3 $ pf), testCase "not validating CERT script" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf False $ notValidatingTxWithCert pf) (Right . utxoStEx4 $ pf), testCase "validating WITHDRAWAL script" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ validatingTxWithWithdrawal pf) (Right . utxoStEx5 $ pf), testCase "not validating WITHDRAWAL script" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf False $ notValidatingTxWithWithdrawal pf) (Right . utxoStEx6 $ pf), testCase "validating MINT script" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ validatingTxWithMint pf) (Right . utxoStEx7 $ pf), testCase "not validating MINT script" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf False $ notValidatingTxWithMint pf) (Right . utxoStEx8 $ pf), testCase "validating scripts everywhere" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ validatingTxManyScripts pf) (Right . utxoStEx9 $ pf), testCase "acceptable supplimentary datum" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ okSupplimentaryDatumTx pf) (Right . utxoStEx10 $ pf), testCase "multiple identical certificates" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ multipleEqualCertsTx pf) (Right . utxoStEx11 $ pf), testCase "non-script output with datum" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ nonScriptOutWithDatumTx pf) (Right . utxoStEx12 $ pf) ], testGroup "invalid transactions" [ testCase "wrong network ID" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ incorrectNetworkIDTx pf) ( Left [ fromUtxo @era (WrongNetworkInTxBody Testnet Mainnet) ] ), testCase "missing required key witness" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ missingRequiredWitnessTx pf) ( Left [(fromPredFail @era . MissingRequiredSigners . Set.singleton) extraneousKeyHash] ), testCase "missing redeemer" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ missingRedeemerTx pf) ( Left [ fromUtxos @era . CollectErrors $ @@ -2135,9 +2144,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "wrong wpp hash" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ wrongWppHashTx pf) ( Left [ fromPredFail @era $ @@ -2159,9 +2167,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "missing 1-phase script witness" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ missing1phaseScriptWitnessTx pf) ( Left [ fromUtxos @era . CollectErrors $ @@ -2173,9 +2180,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "missing 2-phase script witness" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ missing2phaseScriptWitnessTx pf) ( Left [ fromUtxos @era . CollectErrors $ @@ -2194,9 +2200,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "redeemer with incorrect label" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ wrongRedeemerLabelTx pf) ( Left [ fromUtxos @era (CollectErrors [NoRedeemer (Spending (mkGenesisTxIn 1))]), @@ -2210,9 +2215,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "missing datum" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ missingDatumTx pf) ( Left [ fromPredFail @era $ @@ -2222,9 +2226,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "phase 1 script failure" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ phase1FailureTx pf) ( Left [ fromUtxow @era $ @@ -2237,15 +2240,15 @@ alonzoUTXOWexamplesB pf = ] ), testCase "valid transaction marked as invalid" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf False $ validatingTx pf) ( Left [fromUtxos @era (ValidationTagMismatch (IsValid False) PassedUnexpectedly)] ), testCase "invalid transaction marked as valid" $ specialCase (UTXOW pf) + (initUTxO pf) (pp pf) (trustMeP pf True $ notValidatingTx pf) ( Left @@ -2257,9 +2260,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "too many execution units for tx" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ tooManyExUnitsTx pf) ( Left [ fromUtxo @era $ @@ -2269,9 +2271,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "missing signature for collateral input" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ missingCollateralSig pf) ( Left [ fromUtxow @era @@ -2289,14 +2290,14 @@ alonzoUTXOWexamplesB pf = testCase "insufficient collateral" $ testUTXOW (UTXOW pf) + (initUTxO pf) (newPParams pf $ defaultPPs ++ [CollateralPercentage 150]) (trustMeP pf True $ validatingTx pf) ( Left [fromUtxo @era (InsufficientCollateral (Coin 5) (Coin 8))] ), testCase "two-phase UTxO with no datum hash" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ plutusOutputWithNoDataTx pf) ( Left [ fromPredFail @era $ UnspendableUTxONoDatumHash . Set.singleton $ mkGenesisTxIn 101 @@ -2305,6 +2306,7 @@ alonzoUTXOWexamplesB pf = testCase "unacceptable supplimentary datum" $ testUTXOWsubset (UTXOW pf) -- Special rules apply here, use (expected `isSubset` computed) + (initUTxO pf) (pp pf) (trustMeP pf True $ notOkSupplimentaryDatumTx pf) ( Left @@ -2315,9 +2317,8 @@ alonzoUTXOWexamplesB pf = ] ), testCase "unacceptable extra redeemer" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ extraRedeemersTx pf) ( Left [ fromPredFail @era $ @@ -2326,18 +2327,16 @@ alonzoUTXOWexamplesB pf = ] ), testCase "multiple equal plutus-locked certs" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ multipleEqualCertsTxInvalid pf) ( Left [ fromPredFail @era $ ExtraRedeemers [RdmrPtr Tag.Cert 1] ] ), testCase "no cost model" $ - testUTXOW - (UTXOW pf) - (pp pf) + testU + pf (trustMeP pf True $ noCostModelTx pf) ( Left [fromUtxos @era (CollectErrors [NoCostModel PlutusV2])] ) @@ -2400,11 +2399,15 @@ alonzoBBODYexamplesP proof = testGroup (show proof ++ " BBODY examples") [ testCase "eight plutus scripts cases" $ - testBBODY (BBODY proof) (initialBBodyState proof) (testAlonzoBlock proof) (Right (example1BBodyState proof)), + testBBODY + (BBODY proof) + (initialBBodyState proof (initUTxO proof)) + (testAlonzoBlock proof) + (Right (example1BBodyState proof)), testCase "block with bad pool md hash in tx" $ testBBODY (BBODY proof) - (initialBBodyState proof) + (initialBBodyState proof (initUTxO proof)) (testAlonzoBadPMDHBlock proof) (Left [makeTooBig proof]) ] diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs index 823db9d20e3..d41e061d1f8 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs @@ -167,7 +167,7 @@ ppUtxowPredicateFail (NonOutputSupplimentaryDatums s1 s2) = ] ppUtxowPredicateFail (PPViewHashesDontMatch h1 h2) = ppRecord - "NonOutputSupplimentaryDatums" + "PPViewHashesDontMatch" [ ("PPHash in the TxBody", ppStrictMaybe ppSafeHash h1), ("PPHash Computed from the current Protocol Parameters", ppStrictMaybe ppSafeHash h2) ] diff --git a/libs/cardano-ledger-test/test/Tests.hs b/libs/cardano-ledger-test/test/Tests.hs index 9882a8d1c76..8e501d8409a 100644 --- a/libs/cardano-ledger-test/test/Tests.hs +++ b/libs/cardano-ledger-test/test/Tests.hs @@ -10,6 +10,7 @@ module Main where import qualified Test.Cardano.Ledger.Alonzo.Tools as Tools import Test.Cardano.Ledger.BaseTypes (baseTypesTests) +import Test.Cardano.Ledger.Examples.BabbageFeatures (babbageFeatures) import Test.Cardano.Ledger.Examples.TwoPhaseValidation ( allTrees, alonzoAPITests, @@ -38,6 +39,7 @@ mainTests = testGroup "STS Tests" [ allTrees, + babbageFeatures, alonzoAPITests, collectOrderingAlonzo, alonzoProperties,