From 37ed1255aec371830092990e1465ff72fdf66340 Mon Sep 17 00:00:00 2001 From: Nicolas B Date: Wed, 28 Sep 2022 07:56:47 +0200 Subject: [PATCH] Add inline datum supports for mustPayToPubKey and mustPayToOtherScript (#721) * Incremental change for datum * Work but no inlining * First working inline datum with V2 * Add tests for inline datum * add smart constructors for inline datum * fix PAB * fixing tx-constraints * clean up tests * Address some of Konstantinos' comments * Separate test group for plutus v2 * Refactor tests in MustPayToPubKeyAddress to ease version handling * Code clean up * Code clean up * Fix unused imports * Add a way to switch to cardano constraints in MustPayToOtherAddress tests * more clean up * PR feedbacks * Remove dead code * Add refactoring for MustPayToOtherScript tests * typo * clean test suites * Clean up imports --- .../src/Plutus/Contract/StateMachine.hs | 8 +- .../Test/ContractModel/DoubleSatisfaction.hs | 4 +- .../src/Wallet/Emulator/MultiAgent.hs | 7 +- plutus-contract/src/Wallet/Emulator/Wallet.hs | 16 +- plutus-contract/test/Spec/Balancing.hs | 6 +- plutus-contract/test/Spec/Emulator.hs | 7 +- .../Spec/TxConstraints/MustIncludeDatum.hs | 8 +- .../TxConstraints/MustPayToOtherScript.hs | 274 ++++++++++----- .../TxConstraints/MustPayToPubKeyAddress.hs | 313 ++++++++++++------ .../src/Ledger/Constraints.hs | 4 + .../src/Ledger/Constraints/OffChain.hs | 126 +++---- .../src/Ledger/Constraints/OnChain/V1.hs | 7 +- .../src/Ledger/Constraints/OnChain/V2.hs | 18 +- .../src/Ledger/Constraints/TxConstraints.hs | 81 ++++- plutus-ledger-constraints/test/Spec.hs | 7 +- plutus-ledger/src/Ledger/Tx.hs | 30 +- .../src/Ledger/Tx/CardanoAPI/Internal.hs | 41 ++- plutus-ledger/src/Ledger/Tx/Internal.hs | 10 +- plutus-pab/src/Plutus/PAB/Arbitrary.hs | 10 +- .../Plutus/Script/Utils/V2/Typed/Scripts.hs | 87 ++++- .../src/Ledger/Tx/Constraints/OffChain.hs | 16 +- plutus-use-cases/test/Spec/future.pir | 33 +- plutus-use-cases/test/Spec/renderGuess.txt | 8 +- 23 files changed, 783 insertions(+), 338 deletions(-) diff --git a/plutus-contract/src/Plutus/Contract/StateMachine.hs b/plutus-contract/src/Plutus/Contract/StateMachine.hs index 9f638254d9..d79d0d082a 100644 --- a/plutus-contract/src/Plutus/Contract/StateMachine.hs +++ b/plutus-contract/src/Plutus/Contract/StateMachine.hs @@ -90,8 +90,8 @@ import Plutus.Contract.StateMachine.OnChain qualified as SM import Plutus.Contract.StateMachine.ThreadToken (ThreadToken (ThreadToken), curPolicy, ttOutRef) import Plutus.Contract.Wallet (getUnspentOutput) import Plutus.Script.Utils.V1.Scripts (scriptCurrencySymbol) -import Plutus.Script.Utils.V1.Typed.Scripts qualified as Typed -import Plutus.V1.Ledger.Tx qualified as V1 +import Plutus.Script.Utils.V2.Typed.Scripts qualified as Typed +import Plutus.V2.Ledger.Tx qualified as V2 import PlutusTx qualified import PlutusTx.Monoid (inv) @@ -199,7 +199,7 @@ threadTokenChooser :: -> [OnChainState state input] -> Either SMContractError (OnChainState state input) threadTokenChooser val states = - let hasToken OnChainState{ocsTxOutRef} = val `Value.leq` (V1.txOutValue $ Typed.tyTxOutTxOut $ Typed.tyTxOutRefOut ocsTxOutRef) in + let hasToken OnChainState{ocsTxOutRef} = val `Value.leq` (V2.txOutValue $ Typed.tyTxOutTxOut $ Typed.tyTxOutRefOut ocsTxOutRef) in case filter hasToken states of [x] -> Right x xs -> @@ -531,7 +531,7 @@ mkStep client@StateMachineClient{scInstance} input = do oldState = State { stateData = getStateData onChainState -- Hide the thread token value from the client code - , stateValue = V1.txOutValue (Typed.tyTxOutTxOut $ Typed.tyTxOutRefOut ocsTxOutRef) <> inv (SM.threadTokenValueOrZero scInstance) + , stateValue = V2.txOutValue (Typed.tyTxOutTxOut $ Typed.tyTxOutRefOut ocsTxOutRef) <> inv (SM.threadTokenValueOrZero scInstance) } inputConstraints = [ScriptInputConstraint{icRedeemer=input, icTxOutRef = Typed.tyTxOutRefRef ocsTxOutRef }] diff --git a/plutus-contract/src/Plutus/Contract/Test/ContractModel/DoubleSatisfaction.hs b/plutus-contract/src/Plutus/Contract/Test/ContractModel/DoubleSatisfaction.hs index faf7f6e150..224d6561b7 100644 --- a/plutus-contract/src/Plutus/Contract/Test/ContractModel/DoubleSatisfaction.hs +++ b/plutus-contract/src/Plutus/Contract/Test/ContractModel/DoubleSatisfaction.hs @@ -343,13 +343,13 @@ doubleSatisfactionCounterexamples dsc = do datum = Datum . mkB $ "" datumEmpty = Datum . mkB $ "" redeemerEmpty = Redeemer . mkB $ "" - withDatumOut = out & outDatumHash .~ toCardanoTxOutDatumInTx (Just datum) + withDatumOut = out & outDatumHash .~ toCardanoTxOutDatumInTx datum -- Creating TxOut is ugly at the moment because we don't use Cardano addresses, values and datum in the -- emulator yet newFakeTxScriptOut = TxOut $ C.TxOut scriptCardanoAddress (C.TxOutValue C.MultiAssetInBabbageEra $ adaToCardanoValue $ Ada.fromValue $ txOutValue out) - (toCardanoTxOutDatumInline $ Just datumEmpty) + (toCardanoTxOutDatumInline datumEmpty) C.ReferenceScriptNone newFakeTxOutRef = TxOutRef { txOutRefId = TxId "very sha 256 hash I promise" , txOutRefIdx = 1 diff --git a/plutus-contract/src/Wallet/Emulator/MultiAgent.hs b/plutus-contract/src/Wallet/Emulator/MultiAgent.hs index 2bb7d35fcd..7e324a2fb6 100644 --- a/plutus-contract/src/Wallet/Emulator/MultiAgent.hs +++ b/plutus-contract/src/Wallet/Emulator/MultiAgent.hs @@ -39,12 +39,13 @@ import Ledger hiding (to, value) import Ledger.Ada qualified as Ada import Ledger.AddressMap qualified as AM import Ledger.Index qualified as Index -import Ledger.Tx.CardanoAPI (toCardanoTxOut, toCardanoTxOutDatumHash) +import Ledger.Tx.CardanoAPI (toCardanoTxOut, toCardanoTxOutDatum) import Ledger.Value qualified as Value import Plutus.ChainIndex.Emulator qualified as ChainIndex import Plutus.Contract.Error (AssertionError (GenericAssertion)) import Plutus.Trace.Emulator.Types (ContractInstanceLog, EmulatedWalletEffects, EmulatedWalletEffects', UserThreadMsg) import Plutus.Trace.Scheduler qualified as Scheduler +import Plutus.V2.Ledger.Tx qualified as V2 import Wallet.API qualified as WAPI import Wallet.Emulator.Chain qualified as Chain import Wallet.Emulator.LogMessages (RequestHandlerLogMsg, TxBalanceMsg) @@ -292,7 +293,7 @@ we create 10 Ada-only outputs per wallet here. -- creates the initial distribution of funds to public key addresses. emulatorStateInitialDist :: NetworkId -> Map PaymentPubKeyHash Value -> Either ToCardanoError EmulatorState emulatorStateInitialDist networkId mp = do - outs <- traverse (toCardanoTxOut networkId toCardanoTxOutDatumHash) $ Map.toList mp >>= mkOutputs + outs <- traverse (toCardanoTxOut networkId toCardanoTxOutDatum) $ Map.toList mp >>= mkOutputs pure $ emulatorStatePool $ pure $ EmulatorTx $ Tx { txInputs = mempty @@ -319,7 +320,7 @@ emulatorStateInitialDist networkId mp = do -- Make sure we don't make the outputs too small count = min 10 $ ada `div` minAdaTxOut remainder = [ vl <> Ada.toValue (-ada) | not (Value.isAdaOnlyValue vl) ] - mkOutput key vl = pubKeyHashTxOut vl (unPaymentPubKeyHash key) + mkOutput key vl = V2.pubKeyHashTxOut vl (unPaymentPubKeyHash key) type MultiAgentEffs = '[ State EmulatorState diff --git a/plutus-contract/src/Wallet/Emulator/Wallet.hs b/plutus-contract/src/Wallet/Emulator/Wallet.hs index cee48191f8..0af6c36ca8 100644 --- a/plutus-contract/src/Wallet/Emulator/Wallet.hs +++ b/plutus-contract/src/Wallet/Emulator/Wallet.hs @@ -57,11 +57,11 @@ import Ledger.Constraints.OffChain (UnbalancedTx) import Ledger.Constraints.OffChain qualified as U import Ledger.Credential (Credential (PubKeyCredential, ScriptCredential)) import Ledger.Fee (estimateTransactionFee, makeAutoBalancedTransaction) -import Ledger.Index (UtxoIndex (UtxoIndex, getIndex)) +import Ledger.Index.Internal (UtxoIndex (UtxoIndex, getIndex)) import Ledger.Params (Params (Params, pNetworkId, pProtocolParams, pSlotConfig)) import Ledger.Tx (CardanoTx, ChainIndexTxOut, SomeCardanoApiTx, Tx (txFee, txMint), TxOut (TxOut)) import Ledger.Tx qualified as Tx -import Ledger.Tx.CardanoAPI (makeTransactionBody, toCardanoTxOut, toCardanoTxOutDatumHash) +import Ledger.Tx.CardanoAPI.Internal (makeTransactionBody, toCardanoTxOut, toCardanoTxOutDatum) import Ledger.Validation (addSignature, fromPlutusIndex, fromPlutusTx, getRequiredSigners) import Ledger.Value qualified as Value import Plutus.ChainIndex (PageQuery) @@ -71,18 +71,18 @@ import Plutus.ChainIndex.Emulator (ChainIndexEmulatorState, ChainIndexQueryEffec import Plutus.Contract.Checkpoint (CheckpointLogMsg) import Plutus.Contract.Wallet (finalize) import Plutus.V1.Ledger.Api (PubKeyHash, TxOutRef, ValidatorHash, Value) -import Plutus.V1.Ledger.Tx qualified as V1 import PlutusTx.Prelude qualified as PlutusTx import Prettyprinter (Pretty (pretty)) import Servant.API (FromHttpApiData (parseUrlPiece), ToHttpApiData (toUrlPiece)) -import Wallet.API (WalletAPIError) import Wallet.Effects qualified as WAPI (getClientParams) -import Wallet.Error qualified as WAPI (WalletAPIError (InsufficientFunds, PaymentPrivateKeyNotFound, ToCardanoError, ValidationError), - throwOtherError) +import Wallet.Emulator.Error qualified as WAPI (WalletAPIError (InsufficientFunds, PaymentPrivateKeyNotFound, ToCardanoError, ValidationError), + throwOtherError) +import Wallet.Error (WalletAPIError) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Ledger qualified +import Plutus.V2.Ledger.Tx qualified as PV2 import Wallet.Effects (NodeClientEffect, WalletEffect (BalanceTx, OwnAddresses, SubmitTxn, TotalFunds, WalletAddSignature, YieldUnbalancedTx), publishTx) @@ -323,7 +323,7 @@ handleBalance utx' = do let utx = finalize pSlotConfig utx' requiredSigners = Set.toList (U.unBalancedTxRequiredSignatories utx) eitherTx = U.unBalancedTxTx utx - plUtxo = traverse (toCardanoTxOut pNetworkId toCardanoTxOutDatumHash . Tx.toTxOut) utxo + plUtxo = traverse (toCardanoTxOut pNetworkId toCardanoTxOutDatum . Tx.toTxOut) utxo mappedUtxo <- either (throwError . WAPI.ToCardanoError) (pure . fmap TxOut) plUtxo cUtxoIndex <- handleError eitherTx $ fromPlutusIndex $ UtxoIndex $ U.unBalancedTxUtxoIndex utx <> mappedUtxo case eitherTx of @@ -500,7 +500,7 @@ calculateTxChanges params addr utxos (neg, pos) = do txOut <- either (throwError . WAPI.ToCardanoError) (pure . TxOut) - $ toCardanoTxOut (pNetworkId params) toCardanoTxOutDatumHash $ V1.TxOut addr pos Nothing + $ toCardanoTxOut (pNetworkId params) toCardanoTxOutDatum $ PV2.TxOut addr pos PV2.NoOutputDatum Nothing (missing, extraTxOut) <- either (throwError . WAPI.ToCardanoError) pure $ U.adjustTxOut params txOut diff --git a/plutus-contract/test/Spec/Balancing.hs b/plutus-contract/test/Spec/Balancing.hs index 9c1660db43..26186a3b7e 100644 --- a/plutus-contract/test/Spec/Balancing.hs +++ b/plutus-contract/test/Spec/Balancing.hs @@ -11,10 +11,10 @@ import Data.Map qualified as Map import Data.Void (Void) import Test.Tasty (TestTree, testGroup) +import Ledger (unitDatum, unitRedeemer) import Ledger qualified import Ledger.Ada qualified as Ada import Ledger.Constraints qualified as L.Constraints -import Ledger.Scripts (unitDatum, unitRedeemer) import Ledger.Test import Ledger.Tx.Constraints qualified as Tx.Constraints import Ledger.Value qualified as Value @@ -90,10 +90,10 @@ balanceTxnMinAda2 = wallet2Contract :: Contract () EmptySchema ContractError () wallet2Contract = do utxos <- utxosAt someAddress - let txOutRef = case (Map.keys utxos) of + let txOutRef = case Map.keys utxos of (x:_) -> x [] -> error $ "there's no utxo at the address " <> show someAddress - lookups = L.Constraints.unspentOutputs utxos + lookups = L.Constraints.unspentOutputs utxos <> L.Constraints.plutusV1OtherScript someValidator <> L.Constraints.plutusV1MintingPolicy mps constraints = L.Constraints.mustSpendScriptOutput txOutRef unitRedeemer -- spend utxo1 diff --git a/plutus-contract/test/Spec/Emulator.hs b/plutus-contract/test/Spec/Emulator.hs index fd44fd232d..70c3e83cdc 100644 --- a/plutus-contract/test/Spec/Emulator.hs +++ b/plutus-contract/test/Spec/Emulator.hs @@ -35,14 +35,15 @@ import Ledger.Generators (Mockchain (Mockchain), TxInputWitnessed (TxInputWitnes import Ledger.Generators qualified as Gen import Ledger.Index qualified as Index import Ledger.Params (Params (Params, pNetworkId)) -import Ledger.Tx.CardanoAPI (toCardanoTxOut, toCardanoTxOutDatumHash) +import Ledger.Tx.CardanoAPI (toCardanoTxOut, toCardanoTxOutDatum) import Ledger.Value qualified as Value import Plutus.Contract.Test hiding (not) -import Plutus.Script.Utils.V1.Tx (scriptTxOut) +import Plutus.Script.Utils.V1.Address (mkValidatorAddress) import Plutus.Script.Utils.V1.Typed.Scripts (mkUntypedValidator) import Plutus.Trace (EmulatorTrace, PrintEffect (PrintLn)) import Plutus.Trace qualified as Trace import Plutus.V1.Ledger.Contexts (ScriptContext) +import Plutus.V2.Ledger.Api qualified as PV2 import PlutusTx qualified import PlutusTx.Numeric qualified as P import PlutusTx.Prelude qualified as PlutusTx @@ -217,7 +218,7 @@ invalidScript = property $ do index <- forAll $ Gen.int (Range.linear 0 ((length $ getCardanoTxOutputs txn1) - 1)) let emulatorTx = onCardanoTx id (\_ -> error "Unexpected Cardano.Api.Tx") txn1 let setOutputs o = either (const Hedgehog.failure) (pure . TxOut) $ - toCardanoTxOut pNetworkId toCardanoTxOutDatumHash $ scriptTxOut failValidator (txOutValue o) unitDatum + toCardanoTxOut pNetworkId toCardanoTxOutDatum $ PV2.TxOut (mkValidatorAddress failValidator) (txOutValue o) (PV2.OutputDatum unitDatum) Nothing outs <- traverse setOutputs $ emulatorTx ^. outputs let scriptTxn = EmulatorTx $ emulatorTx diff --git a/plutus-contract/test/Spec/TxConstraints/MustIncludeDatum.hs b/plutus-contract/test/Spec/TxConstraints/MustIncludeDatum.hs index 97b3c5de24..548b720aa1 100644 --- a/plutus-contract/test/Spec/TxConstraints/MustIncludeDatum.hs +++ b/plutus-contract/test/Spec/TxConstraints/MustIncludeDatum.hs @@ -13,12 +13,10 @@ import Test.Tasty (TestTree, testGroup) import Ledger qualified import Ledger.Ada qualified as Ada -import Ledger.Constraints.OffChain qualified as Constraints (plutusV1MintingPolicy, typedValidatorLookups, - unspentOutputs) +import Ledger.Constraints qualified as Constraints (collectFromTheScript, mustIncludeDatum, mustMintValueWithRedeemer, + mustPayToOtherScript, mustPayToTheScript, mustPayWithDatumToPubKey, + plutusV1MintingPolicy, typedValidatorLookups, unspentOutputs) import Ledger.Constraints.OnChain.V1 qualified as Constraints (checkScriptContext) -import Ledger.Constraints.TxConstraints qualified as Constraints (collectFromTheScript, mustIncludeDatum, - mustMintValueWithRedeemer, mustPayToOtherScript, - mustPayToTheScript, mustPayWithDatumToPubKey) import Ledger.Tx qualified as Tx import Ledger.Typed.Scripts qualified as Scripts import Plutus.Contract as Con diff --git a/plutus-contract/test/Spec/TxConstraints/MustPayToOtherScript.hs b/plutus-contract/test/Spec/TxConstraints/MustPayToOtherScript.hs index 900510a907..34242d10c4 100644 --- a/plutus-contract/test/Spec/TxConstraints/MustPayToOtherScript.hs +++ b/plutus-contract/test/Spec/TxConstraints/MustPayToOtherScript.hs @@ -2,36 +2,41 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Spec.TxConstraints.MustPayToOtherScript(tests) where +import Control.Lens ((&), (??), (^.)) import Control.Monad (void) import Test.Tasty (TestTree, testGroup) -import Control.Lens ((&)) import Ledger qualified import Ledger.Ada qualified as Ada -import Ledger.Constraints.OffChain qualified as Constraints (plutusV1MintingPolicy, plutusV1OtherScript, unspentOutputs) +import Ledger.Constraints qualified as Constraints (ScriptLookups, TxConstraints, mustMintValueWithRedeemer, + mustPayToOtherScript, mustPayToOtherScriptAddress, + mustPayToOtherScriptInlineDatum, + mustSpendScriptOutputWithMatchingDatumAndValue, + plutusV1MintingPolicy, plutusV1OtherScript, plutusV2MintingPolicy, + unspentOutputs) import Ledger.Constraints.OnChain.V1 qualified as Constraints (checkScriptContext) -import Ledger.Constraints.TxConstraints qualified as Constraints (mustMintValueWithRedeemer, mustPayToOtherScript, - mustPayToOtherScriptAddress, - mustSpendScriptOutputWithMatchingDatumAndValue) +import Ledger.Constraints.OnChain.V2 qualified as V2.Constraints import Ledger.Generators (someTokenValue) -import Ledger.Scripts (ScriptError (EvaluationError)) -import Ledger.Test (asRedeemer, someValidator, someValidatorHash) +import Ledger.Scripts (Redeemer, ScriptError (EvaluationError)) +import Ledger.Test (asDatum, asRedeemer, someValidator, someValidatorHash) import Ledger.Tx qualified as Tx +import Ledger.Tx.Constraints qualified as Tx.Constraints import Ledger.Typed.Scripts qualified as Scripts import Plutus.Contract as Con import Plutus.Contract.Test (assertContractError, assertFailedTransaction, assertValidatedTransactionCount, - changeInitialWalletValue, checkPredicateOptions, defaultCheckOptions, w1) + changeInitialWalletValue, checkPredicateOptions, defaultCheckOptions, emulatorConfig, w1) import Plutus.Script.Utils.V1.Generators (alwaysSucceedValidatorHash) import Plutus.Script.Utils.V1.Scripts qualified as PSU.V1 +import Plutus.Script.Utils.V2.Scripts qualified as PSU.V2 +import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2.Scripts import Plutus.Trace qualified as Trace -import Plutus.V1.Ledger.Api (CurrencySymbol (CurrencySymbol), Datum (Datum), ToData (toBuiltinData), - UnsafeFromData (unsafeFromBuiltinData)) import Plutus.V1.Ledger.Value qualified as Value import PlutusTx qualified import PlutusTx.Prelude qualified as P @@ -41,21 +46,49 @@ import Wallet (WalletAPIError (InsufficientFunds)) tests :: TestTree tests = testGroup "MustPayToOtherScript" - [ successfulUseOfMustPayToOtherScriptWithMintedToken - , successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyToken - --, successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyAda -- FAILING when onchain checks for only ada value and token is present -- PLT-885 - , successfulUseOfMustPayToOtherScriptWithScriptsExactTokenBalance - , successfulUseOfMustPayToOtherScriptWhenOnchainExpectsLowerAdaValue - , contractErrorWhenAttemptingToSpendMoreThanAdaBalance - , contractErrorWhenAttemptingToSpendMoreThanTokenBalance - , phase2ErrorWhenExpectingMoreThanValue - ] - -someDatum :: Datum -someDatum = Datum $ PlutusTx.dataToBuiltinData $ PlutusTx.toData ("datum" :: P.BuiltinByteString) - -otherDatum :: Datum -otherDatum = Datum $ PlutusTx.dataToBuiltinData $ PlutusTx.toData ("other datum" :: P.BuiltinByteString) + [ testGroup "ledger constraints" $ [v1Tests, v2Tests] ?? ledgerSubmitTx + --, testGroup "cardano constraints" $ [v1Tests, v2Tests] ?? cardanoSubmitTx + ] + +v1Tests :: SubmitTx -> TestTree +v1Tests sub = testGroup "Plutus V1" $ + [ v1FeaturesTests + , v2FeaturesNotAvailableTests + ] ?? sub ?? languageContextV1 + +v2Tests :: SubmitTx -> TestTree +v2Tests sub = testGroup "Plutus V2" $ + [ v1FeaturesTests + , v2FeaturesTests + ] ?? sub ?? languageContextV2 + +v1FeaturesTests :: SubmitTx -> LanguageContext -> TestTree +v1FeaturesTests sub t = testGroup "Plutus V1 features" $ + [ successfulUseOfMustPayToOtherScriptWithMintedToken + , successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyToken + --, successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyAda -- FAILING when onchain checks for only ada value and token is present -- PLT-885 + , successfulUseOfMustPayToOtherScriptWithScriptsExactTokenBalance + , successfulUseOfMustPayToOtherScriptWhenOnchainExpectsLowerAdaValue + , contractErrorWhenAttemptingToSpendMoreThanAdaBalance + , contractErrorWhenAttemptingToSpendMoreThanTokenBalance + , phase2ErrorWhenExpectingMoreThanValue + ] ?? sub ?? t + +v2FeaturesTests :: SubmitTx -> LanguageContext -> TestTree +v2FeaturesTests sub t = testGroup "Plutus V2 features" $ + [ successfulUseOfMustPayToOtherScriptWithMintedTokenV2 + ] ?? sub ?? t + +v2FeaturesNotAvailableTests :: SubmitTx -> LanguageContext -> TestTree +v2FeaturesNotAvailableTests sub t = testGroup "Plutus V2 features" $ + [ phase1FailureWhenPayToOtherScriptV1ScriptUseInlineDatum + ] ?? sub ?? t + +someDatum :: Ledger.Datum +someDatum = asDatum @P.BuiltinByteString "datum" + +otherDatum :: Ledger.Datum +otherDatum = asDatum @P.BuiltinByteString "other datum" utxoValue :: Value.Value utxoValue = Ada.lovelaceValueOf 10_000_000 @@ -66,11 +99,11 @@ adaAmount = 5_000_000 adaValue :: Value.Value adaValue = Ada.lovelaceValueOf adaAmount -tknValue :: Value.Value -tknValue = Value.singleton mustPayToOtherScriptPolicyCurrencySymbol "mint-me" 1 +tknValue :: LanguageContext -> Value.Value +tknValue tc = Value.singleton (mustPayToOtherScriptPolicyCurrencySymbol tc) "mint-me" 1 -adaAndTokenValue :: Value.Value -adaAndTokenValue = adaValue <> tknValue +adaAndTokenValue :: LanguageContext -> Value.Value +adaAndTokenValue = (adaValue <>) . tknValue otherTokenValue :: Value.Value otherTokenValue = someTokenValue "someToken" 1 @@ -81,30 +114,52 @@ trace contract = do void $ Trace.waitNSlots 1 -- | Contract to a single transaction with mustSpendScriptOutputs offchain constraint and mint with policy using matching onchain constraint -mustPayToOtherScriptContract :: Value.Value -> Ledger.Redeemer -> Contract () Empty ContractError () -mustPayToOtherScriptContract offChainValue onChainConstraint = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToOtherScriptPolicy +mustPayToOtherScriptContract :: SubmitTx -> LanguageContext -> Value.Value -> Ledger.Redeemer -> Contract () Empty ContractError () +mustPayToOtherScriptContract submitTxFromConstraints lc offChainValue onChainConstraint = do + let lookups1 = mintingPolicy lc $ mustPayToOtherScriptPolicy lc tx1 = Constraints.mustPayToOtherScript someValidatorHash someDatum offChainValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue lc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 -- | Valid scenario using offchain and onchain constraint mustPayToOtherScript with exact token value being minted -successfulUseOfMustPayToOtherScriptWithMintedToken :: TestTree -successfulUseOfMustPayToOtherScriptWithMintedToken = - let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum adaAndTokenValue - contract = mustPayToOtherScriptContract adaAndTokenValue onChainConstraint +successfulUseOfMustPayToOtherScriptWithMintedToken :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToOtherScriptWithMintedToken submitTxFromConstraints lc = + let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum (adaAndTokenValue lc) + contract = mustPayToOtherScriptContract submitTxFromConstraints lc (adaAndTokenValue lc) onChainConstraint in checkPredicateOptions defaultCheckOptions "Successful use of offchain and onchain mustPayToOtherScript constraint with wallet's exact ada balance" (assertValidatedTransactionCount 1) (void $ trace contract) +-- | Contract to a single transaction with mustSpendScriptOutputs offchain constraint and mint with policy using +-- matching onchain constraint, using Plutus V2 script and inline datum +mustPayToOtherScriptInlineContractV2 :: SubmitTx -> LanguageContext -> Value.Value -> Redeemer -> Contract () Empty ContractError () +mustPayToOtherScriptInlineContractV2 submitTxFromConstraints lc offChainValue onChainConstraint = do + let lookups1 = mintingPolicy lc $ mustPayToOtherScriptPolicy lc + tx1 = Constraints.mustPayToOtherScriptInlineDatum someValidatorHash someDatum offChainValue + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue lc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 + +-- | Valid scenario using offchain and onchain constraint mustPayToOtherScript with exact token value being minted +-- using inline datum +successfulUseOfMustPayToOtherScriptWithMintedTokenV2 :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToOtherScriptWithMintedTokenV2 submitTxFromConstraints lc = + let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum (adaAndTokenValue lc) + contract = mustPayToOtherScriptInlineContractV2 submitTxFromConstraints lc (adaAndTokenValue lc) onChainConstraint + + in checkPredicateOptions defaultCheckOptions + "Successful use of offchain and onchain mustPayToOtherScript constraint with wallet's exact ada balance with inline datum" + (assertValidatedTransactionCount 1) + (void $ trace contract) + -- | Valid scenario using mustPayToOtherScript offchain constraint to include ada and token whilst onchain constraint checks for token value only -successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyToken :: TestTree -successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyToken = - let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum tknValue - contract = mustPayToOtherScriptContract adaAndTokenValue onChainConstraint +successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyToken :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyToken submitTxFromConstraints lc = + let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum (tknValue lc) + contract = mustPayToOtherScriptContract submitTxFromConstraints lc (adaAndTokenValue lc) onChainConstraint in checkPredicateOptions defaultCheckOptions "Successful use of mustPayToOtherScript offchain constraint to include ada and token whilst onchain constraint checks for token value only" @@ -113,10 +168,10 @@ successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnly -- | Valid scenario using mustPayToOtherScript offchain constraint to include ada and token whilst onchain constraint checks for ada value only -- FAILING when onchain checks for only ada value and token is present -- PLT-885 -successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyAda :: TestTree -successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyAda = +successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyAda :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnlyAda submitTxFromConstraints lc = let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum adaValue - contract = mustPayToOtherScriptContract adaAndTokenValue onChainConstraint + contract = mustPayToOtherScriptContract submitTxFromConstraints lc (adaAndTokenValue lc) onChainConstraint in checkPredicateOptions defaultCheckOptions "Successful use of mustPayToOtherScript offchain constraint to include ada and token whilst onchain constraint checks for ada value only" @@ -124,8 +179,8 @@ successfulUseOfMustPayToOtherScriptWhenOffchainIncludesTokenAndOnchainChecksOnly (void $ trace contract) -- | Valid scenario using offchain and onchain constraint mustPayToOtherScript in combination with mustSpendScriptOutputWithMatchingDatumAndValue to spend script's exact token balance -successfulUseOfMustPayToOtherScriptWithScriptsExactTokenBalance :: TestTree -successfulUseOfMustPayToOtherScriptWithScriptsExactTokenBalance = +successfulUseOfMustPayToOtherScriptWithScriptsExactTokenBalance :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToOtherScriptWithScriptsExactTokenBalance submitTxFromConstraints lc = let otherValidatorHash = alwaysSucceedValidatorHash adaAndOtherTokenValue = adaValue <> otherTokenValue onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum otherTokenValue @@ -133,41 +188,49 @@ successfulUseOfMustPayToOtherScriptWithScriptsExactTokenBalance = contract = do let lookups1 = Constraints.plutusV1OtherScript someValidator tx1 = Constraints.mustPayToOtherScript someValidatorHash someDatum adaAndOtherTokenValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 scriptUtxos <- utxosAt $ Ledger.scriptHashAddress someValidatorHash let lookups2 = Constraints.plutusV1OtherScript someValidator <> Constraints.unspentOutputs scriptUtxos - <> Constraints.plutusV1MintingPolicy mustPayToOtherScriptPolicy + <> mintingPolicy lc (mustPayToOtherScriptPolicy lc) tx2 = Constraints.mustPayToOtherScript otherValidatorHash someDatum adaAndOtherTokenValue <> Constraints.mustSpendScriptOutputWithMatchingDatumAndValue someValidatorHash (\d -> d == someDatum) (\v -> v == adaAndOtherTokenValue) (asRedeemer ()) - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx2 <- submitTxConstraintsWith @UnitTest lookups2 tx2 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue lc) + ledgerTx2 <- submitTxFromConstraints lookups2 tx2 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx2 - in checkPredicateOptions options "Successful use of offchain and onchain mustPayToOtherScript constraint in combination with mustSpendScriptOutputWithMatchingDatumAndValue to spend script's exact token balance" (assertValidatedTransactionCount 2) (void $ trace contract) -- | Valid scenario where onchain mustPayToOtherScript constraint expects less ada than the actual value -successfulUseOfMustPayToOtherScriptWhenOnchainExpectsLowerAdaValue :: TestTree -successfulUseOfMustPayToOtherScriptWhenOnchainExpectsLowerAdaValue = +successfulUseOfMustPayToOtherScriptWhenOnchainExpectsLowerAdaValue :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToOtherScriptWhenOnchainExpectsLowerAdaValue submitTxFromConstraints lc = let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum (Ada.lovelaceValueOf $ adaAmount - 1) - contract = mustPayToOtherScriptContract adaValue onChainConstraint + contract = mustPayToOtherScriptContract submitTxFromConstraints lc adaValue onChainConstraint in checkPredicateOptions defaultCheckOptions "Successful use of mustPayToOtherScript onchain constraint when it expects less ada than the actual value" (assertValidatedTransactionCount 1) (void $ trace contract) +-- | Invalid contract that tries to use inline datum in a V1 script +mustPayToOtherScriptInlineContract :: SubmitTx -> LanguageContext -> Value.Value -> Redeemer -> Contract () Empty ContractError () +mustPayToOtherScriptInlineContract submitTxFromConstraints lc offChainValue onChainConstraint = do + let lookups1 = mintingPolicy lc $ mustPayToOtherScriptPolicy lc + tx1 = Constraints.mustPayToOtherScriptInlineDatum someValidatorHash someDatum offChainValue + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue lc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 + -- | Contract error when ada amount to send to other script is greater than wallet balance -contractErrorWhenAttemptingToSpendMoreThanAdaBalance :: TestTree -contractErrorWhenAttemptingToSpendMoreThanAdaBalance = +contractErrorWhenAttemptingToSpendMoreThanAdaBalance :: SubmitTx -> LanguageContext -> TestTree +contractErrorWhenAttemptingToSpendMoreThanAdaBalance submitTxFromConstraints lc = let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum adaValue walletAdaBalance = Value.scale 10 utxoValue -- with fees this exceeds wallet balance - contract = mustPayToOtherScriptContract walletAdaBalance onChainConstraint + contract = mustPayToOtherScriptContract submitTxFromConstraints lc walletAdaBalance onChainConstraint in checkPredicateOptions defaultCheckOptions "Contract error when ada amount to send to other script is greater than wallet balance" @@ -175,49 +238,104 @@ contractErrorWhenAttemptingToSpendMoreThanAdaBalance = (void $ trace contract) -- | Contract error when token amount to send to other script is greater than wallet balance -contractErrorWhenAttemptingToSpendMoreThanTokenBalance :: TestTree -contractErrorWhenAttemptingToSpendMoreThanTokenBalance = +contractErrorWhenAttemptingToSpendMoreThanTokenBalance :: SubmitTx -> LanguageContext -> TestTree +contractErrorWhenAttemptingToSpendMoreThanTokenBalance submitTxFromConstraints lc = let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum otherTokenValue - contract = mustPayToOtherScriptContract otherTokenValue onChainConstraint + contract = mustPayToOtherScriptContract submitTxFromConstraints lc otherTokenValue onChainConstraint in checkPredicateOptions defaultCheckOptions "Contract error when token amount to send to other script is greater than wallet balance" (assertContractError contract (Trace.walletInstanceTag w1) (\case WalletContractError (InsufficientFunds _) -> True; _ -> False) "failed to throw error") (void $ trace contract) +-- | Phase-1 failure when mustPayToOtherScript in a V1 script use inline datum +phase1FailureWhenPayToOtherScriptV1ScriptUseInlineDatum :: SubmitTx -> LanguageContext -> TestTree +phase1FailureWhenPayToOtherScriptV1ScriptUseInlineDatum submitTxFromConstraints lc = + let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum (adaAndTokenValue lc) + contract = mustPayToOtherScriptInlineContract submitTxFromConstraints lc (adaAndTokenValue lc) onChainConstraint + + in checkPredicateOptions defaultCheckOptions + "Phase-1 failure when mustPayToOtherScript in a V1 script use inline datum" + (assertFailedTransaction (\_ err _ -> case err of {Ledger.CardanoLedgerValidationError _ -> True; _ -> False })) + (void $ trace contract) + + + -- | Phase-2 validation failure when onchain mustSpendScriptOutput constraint expects more than actual ada value -phase2ErrorWhenExpectingMoreThanValue :: TestTree -phase2ErrorWhenExpectingMoreThanValue = +phase2ErrorWhenExpectingMoreThanValue :: SubmitTx -> LanguageContext -> TestTree +phase2ErrorWhenExpectingMoreThanValue submitTxFromConstraints lc = let onChainConstraint = asRedeemer $ MustPayToOtherScript someValidatorHash someDatum otherTokenValue - contract = mustPayToOtherScriptContract adaValue onChainConstraint + contract = mustPayToOtherScriptContract submitTxFromConstraints lc adaValue onChainConstraint in checkPredicateOptions defaultCheckOptions "Phase-2 validation failure when when token amount sent to other script is lower than actual value" (assertFailedTransaction (\_ err _ -> case err of {Ledger.ScriptFailure (EvaluationError ("Lb":_) _) -> True; _ -> False })) (void $ trace contract) + data UnitTest instance Scripts.ValidatorTypes UnitTest -{-# INLINEABLE mkMustPayToOtherScriptPolicy #-} -mkMustPayToOtherScriptPolicy :: ConstraintParams -> Ledger.ScriptContext -> Bool -mkMustPayToOtherScriptPolicy t = case t of - MustPayToOtherScript vh d v -> Constraints.checkScriptContext @() @() (Constraints.mustPayToOtherScript vh d v) - MustPayToOtherScriptAddress vh svh d v -> Constraints.checkScriptContext @() @() (Constraints.mustPayToOtherScriptAddress vh svh d v) +mkMustPayToOtherScriptPolicy :: (Constraints.TxConstraints () () -> sc -> Bool) -> ConstraintParams -> sc -> Bool +mkMustPayToOtherScriptPolicy checkScriptContext t = case t of + MustPayToOtherScript vh d v -> checkScriptContext (Constraints.mustPayToOtherScript vh d v) + MustPayToOtherScriptAddress vh svh d v -> checkScriptContext (Constraints.mustPayToOtherScriptAddress vh svh d v) -mustPayToOtherScriptPolicy :: Scripts.MintingPolicy -mustPayToOtherScriptPolicy = Ledger.mkMintingPolicyScript $$(PlutusTx.compile [||wrap||]) +mustPayToOtherScriptPolicyV1 :: Ledger.MintingPolicy +mustPayToOtherScriptPolicyV1 = Ledger.mkMintingPolicyScript $$(PlutusTx.compile [||wrap||]) where - wrap = Scripts.mkUntypedMintingPolicy mkMustPayToOtherScriptPolicy + checkedMkMustPayToOtherScriptPolicy = mkMustPayToOtherScriptPolicy Constraints.checkScriptContext + wrap = Scripts.mkUntypedMintingPolicy checkedMkMustPayToOtherScriptPolicy + +mustPayToOtherScriptPolicyV2 :: Ledger.MintingPolicy +mustPayToOtherScriptPolicyV2 = Ledger.mkMintingPolicyScript $$(PlutusTx.compile [||wrap||]) + where + checkedMkMustPayToOtherScriptPolicy = mkMustPayToOtherScriptPolicy V2.Constraints.checkScriptContext + wrap = V2.Scripts.mkUntypedMintingPolicy checkedMkMustPayToOtherScriptPolicy + +data LanguageContext + = LanguageContext + { mustPayToOtherScriptPolicy :: Ledger.MintingPolicy + , mintingPolicy :: forall a. Ledger.MintingPolicy -> Constraints.ScriptLookups a + , mintingPolicyHash :: Ledger.MintingPolicy -> Ledger.MintingPolicyHash + } + +languageContextV1 :: LanguageContext +languageContextV1 = LanguageContext + mustPayToOtherScriptPolicyV1 + Constraints.plutusV1MintingPolicy + PSU.V1.mintingPolicyHash + + +languageContextV2 :: LanguageContext +languageContextV2 = LanguageContext + mustPayToOtherScriptPolicyV2 + Constraints.plutusV2MintingPolicy + PSU.V2.mintingPolicyHash + + +type SubmitTx + = Constraints.ScriptLookups UnitTest + -> Constraints.TxConstraints (Scripts.RedeemerType UnitTest) (Scripts.DatumType UnitTest) + -> Contract () Empty ContractError Tx.CardanoTx + +cardanoSubmitTx :: SubmitTx +cardanoSubmitTx lookups tx = let + p = defaultCheckOptions ^. emulatorConfig . Trace.params + in submitUnbalancedTx $ either (error . show) id $ Tx.Constraints.mkTx @UnitTest p lookups tx + +ledgerSubmitTx :: SubmitTx +ledgerSubmitTx = submitTxConstraintsWith + -mustPayToOtherScriptPolicyHash :: Ledger.MintingPolicyHash -mustPayToOtherScriptPolicyHash = PSU.V1.mintingPolicyHash mustPayToOtherScriptPolicy +mustPayToOtherScriptPolicyHash :: LanguageContext -> Ledger.MintingPolicyHash +mustPayToOtherScriptPolicyHash lc = mintingPolicyHash lc $ mustPayToOtherScriptPolicy lc -mustPayToOtherScriptPolicyCurrencySymbol :: CurrencySymbol -mustPayToOtherScriptPolicyCurrencySymbol = CurrencySymbol $ unsafeFromBuiltinData $ toBuiltinData mustPayToOtherScriptPolicyHash +mustPayToOtherScriptPolicyCurrencySymbol :: LanguageContext -> Ledger.CurrencySymbol +mustPayToOtherScriptPolicyCurrencySymbol = Value.mpsSymbol . mustPayToOtherScriptPolicyHash -data ConstraintParams = MustPayToOtherScript PSU.V1.ValidatorHash Datum Value.Value - | MustPayToOtherScriptAddress PSU.V1.ValidatorHash PSU.V1.StakeValidatorHash Datum Value.Value +data ConstraintParams = MustPayToOtherScript PSU.V1.ValidatorHash Ledger.Datum Value.Value + | MustPayToOtherScriptAddress PSU.V1.ValidatorHash PSU.V1.StakeValidatorHash Ledger.Datum Value.Value deriving (Show) PlutusTx.unstableMakeIsData ''ConstraintParams diff --git a/plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs b/plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs index e6bdb98abd..3a5ea5c18b 100644 --- a/plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs +++ b/plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs @@ -1,31 +1,37 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} module Spec.TxConstraints.MustPayToPubKeyAddress(tests) where +import Control.Lens ((??), (^.)) import Control.Monad (void) import Test.Tasty (TestTree, testGroup) import Ledger qualified import Ledger.Ada qualified as Ada -import Ledger.Constraints.OffChain qualified as Constraints (plutusV1MintingPolicy) +import Ledger.Constraints qualified as Constraints (ScriptLookups, TxConstraints, mustMintValueWithRedeemer, + mustPayToPubKey, mustPayToPubKeyAddress, mustPayWithDatumToPubKey, + mustPayWithDatumToPubKeyAddress, mustPayWithInlineDatumToPubKey, + plutusV1MintingPolicy, plutusV2MintingPolicy) import Ledger.Constraints.OnChain.V1 qualified as Constraints (checkScriptContext) -import Ledger.Constraints.TxConstraints qualified as Constraints (mustMintValueWithRedeemer, mustPayToPubKey, - mustPayToPubKeyAddress, mustPayWithDatumToPubKey, - mustPayWithDatumToPubKeyAddress) +import Ledger.Constraints.OnChain.V2 qualified as V2.Constraints import Ledger.Scripts (ScriptError (EvaluationError)) import Ledger.Test (asDatum, asRedeemer) import Ledger.Tx qualified as Tx +import Ledger.Tx.Constraints qualified as Tx.Constraints import Ledger.Typed.Scripts qualified as Scripts import Plutus.Contract as Con -import Plutus.Contract.Test (assertFailedTransaction, assertValidatedTransactionCount, checkPredicateOptions, - defaultCheckOptions, mockWalletPaymentPubKeyHash, w1, w2) +import Plutus.Contract.Test (assertFailedTransaction, assertValidatedTransactionCount, checkPredicate, + defaultCheckOptions, emulatorConfig, mockWalletPaymentPubKeyHash, w1, w2) import Plutus.Script.Utils.V1.Scripts qualified as PSU.V1 +import Plutus.Script.Utils.V2.Scripts qualified as PSU.V2 +import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2.Scripts import Plutus.Trace qualified as Trace import Plutus.V1.Ledger.Value qualified as Value import PlutusTx qualified @@ -33,20 +39,47 @@ import PlutusTx.Prelude qualified as P -- Constraint's functions should soon be changed to use Address instead of PaymentPubKeyHash and StakeKeyHash tests :: TestTree -tests = - testGroup "MustPayToPubKeyAddress" - [ successfulUseOfMustPayToPubKeyWithMintedTokenValue - , successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyToken - , successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyAda - , successfulUseOfMustPayToPubKeyExpectingALowerAdaValue - , successfulUseOfMustPayToPubKeyAddress - , successfulUseOfMustPayWithDatumToPubKey - , successfulUseOfMustPayWithDatumToPubKeyAddress - , phase2FailureWhenUsingUnexpectedPaymentPubKeyHash - --, phase2FailureWhenUsingUnexpectedStakePubKeyHash -- onchain check not implemented - , phase2FailureWhenUsingUnexpectedDatum - , phase2FailureWhenUsingUnexpectedValue - ] +tests = testGroup "MustPayToPubKeyAddress" + [ testGroup "ledger constraints" $ [v1Tests, v2Tests] ?? ledgerSubmitTx + --, testGroup "cardano constraints" $ [v1Tests, v2Tests] ?? cardanoSubmitTx + ] + +v1Tests :: SubmitTx -> TestTree +v1Tests sub = testGroup "Plutus V1" $ + [ v1FeaturesTests + , v2FeaturesNotAvailableTests + ] ?? sub ?? languageContextV1 + +v2Tests :: SubmitTx -> TestTree +v2Tests sub = testGroup "Plutus V2" $ + [ v1FeaturesTests + , v2FeaturesTests + ] ?? sub ?? languageContextV2 + +v1FeaturesTests :: SubmitTx -> LanguageContext -> TestTree +v1FeaturesTests sub t = testGroup "Plutus V1 features" $ + [ successfulUseOfMustPayToPubKeyWithMintedTokenValue + , successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyToken + , successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyAda + , successfulUseOfMustPayToPubKeyExpectingALowerAdaValue + , successfulUseOfMustPayToPubKeyAddress + , successfulUseOfMustPayWithDatumToPubKey + , successfulUseOfMustPayWithDatumToPubKeyAddress + , phase2FailureWhenUsingUnexpectedPaymentPubKeyHash + --, phase2FailureWhenUsingUnexpectedStakePubKeyHash -- onchain check not implemented + , phase2FailureWhenUsingUnexpectedDatum + , phase2FailureWhenUsingUnexpectedValue + ] ?? sub ?? t + +v2FeaturesTests :: SubmitTx -> LanguageContext -> TestTree +v2FeaturesTests sub t = testGroup "Plutus V2 features" $ + [ successfulUseOfMustPayWithInlineDatumToPubKeyV2 + ] ?? sub ?? t + +v2FeaturesNotAvailableTests :: SubmitTx -> LanguageContext -> TestTree +v2FeaturesNotAvailableTests sub t = testGroup "Plutus V2 features" $ + [ phase1FailureWhenUsingInlineDatumWithV1 + ] ?? sub ?? t someDatum :: Ledger.Datum someDatum = asDatum @P.BuiltinByteString "datum" @@ -60,8 +93,8 @@ adaAmount = 5_000_000 adaValue :: Value.Value adaValue = Ada.lovelaceValueOf adaAmount -tknValue :: Value.Value -tknValue = Value.singleton mustPayToPubKeyAddressPolicyCurrencySymbol "mint-me" 1 +tknValue :: LanguageContext -> Value.Value +tknValue tc = Value.singleton (mustPayToPubKeyAddressPolicyCurrencySymbol tc) "mint-me" 1 w1PaymentPubKeyHash :: Ledger.PaymentPubKeyHash w1PaymentPubKeyHash = mockWalletPaymentPubKeyHash w1 @@ -81,189 +114,267 @@ trace contract = do void $ Trace.waitNSlots 1 -- | Valid scenario using offchain and onchain constraint mustPayToPubKey with exact token value being minted -successfulUseOfMustPayToPubKeyWithMintedTokenValue :: TestTree -successfulUseOfMustPayToPubKeyWithMintedTokenValue = - let adaAndTokenValue = adaValue <> tknValue +successfulUseOfMustPayToPubKeyWithMintedTokenValue :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToPubKeyWithMintedTokenValue submitTxFromConstraints tc = + let adaAndTokenValue = adaValue <> tknValue tc onChainConstraint = asRedeemer $ MustPayToPubKey w2PaymentPubKeyHash adaAndTokenValue contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc (mustPayToPubKeyAddressPolicy tc) tx1 = Constraints.mustPayToPubKey w2PaymentPubKeyHash adaAndTokenValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Successful use of offchain and onchain mustPayToPubKey constraint for native token value" (assertValidatedTransactionCount 1) (void $ trace contract) -- | Valid scenario using mustPayToPubKey offchain constraint to include ada and token whilst onchain constraint checks for token value only -successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyToken :: TestTree -successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyToken = - let adaAndTokenValue = adaValue <> tknValue - onChainConstraint = asRedeemer $ MustPayToPubKey w2PaymentPubKeyHash tknValue +successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyToken :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyToken submitTxFromConstraints tc = + let adaAndTokenValue = adaValue <> tknValue tc + onChainConstraint = asRedeemer $ MustPayToPubKey w2PaymentPubKeyHash (tknValue tc) contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc (mustPayToPubKeyAddressPolicy tc) tx1 = Constraints.mustPayToPubKey w2PaymentPubKeyHash adaAndTokenValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Successful use of mustPayToPubKey offchain constraint to include ada and token whilst onchain constraint checks for token value only" (assertValidatedTransactionCount 1) (void $ trace contract) -- | Valid scenario using mustPayToPubKey offchain constraint to include ada and token whilst onchain constraint checks for ada value only -successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyAda :: TestTree -successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyAda = - let adaAndTokenValue = adaValue <> tknValue +successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyAda :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToPubKeyWhenOffchainIncludesTokenAndOnchainChecksOnlyAda submitTxFromConstraints tc = + let adaAndTokenValue = adaValue <> tknValue tc onChainConstraint = asRedeemer $ MustPayToPubKey w2PaymentPubKeyHash adaValue contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc tx1 = Constraints.mustPayToPubKey w2PaymentPubKeyHash adaAndTokenValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Successful use of mustPayToPubKey offchain constraint to include ada and token whilst onchain constraint checks for ada value only" (assertValidatedTransactionCount 1) (void $ trace contract) -- | Valid scenario where the onchain mustPayToPubKey constraint expects less ada than the actual value -successfulUseOfMustPayToPubKeyExpectingALowerAdaValue :: TestTree -successfulUseOfMustPayToPubKeyExpectingALowerAdaValue = +successfulUseOfMustPayToPubKeyExpectingALowerAdaValue :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToPubKeyExpectingALowerAdaValue submitTxFromConstraints tc = let onChainConstraint = asRedeemer $ MustPayToPubKey w2PaymentPubKeyHash (Ada.lovelaceValueOf $ adaAmount - 1) contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc tx1 = Constraints.mustPayToPubKey w2PaymentPubKeyHash adaValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Successful use of onchain mustPayToPubKey constraint when it expects less ada than the actual value" (assertValidatedTransactionCount 1) (void $ trace contract) -- | Valid scenario using offchain and onchain constraint mustPayToPubKeyAddress with ada-only value -successfulUseOfMustPayToPubKeyAddress :: TestTree -successfulUseOfMustPayToPubKeyAddress = +successfulUseOfMustPayToPubKeyAddress :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayToPubKeyAddress submitTxFromConstraints tc = let onChainConstraint = asRedeemer $ MustPayToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash adaValue contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc tx1 = Constraints.mustPayToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash adaValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Successful use of offchain and onchain mustPayToPubKeyAddress constraint for ada-only value" (assertValidatedTransactionCount 1) (void $ trace contract) -- | Valid scenario using offchain and onchain constraint mustPayWithDatumToPubKey with bytestring datum and ada value -successfulUseOfMustPayWithDatumToPubKey :: TestTree -successfulUseOfMustPayWithDatumToPubKey = +successfulUseOfMustPayWithDatumToPubKey :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayWithDatumToPubKey submitTxFromConstraints tc = let onChainConstraint = asRedeemer $ MustPayWithDatumToPubKey w2PaymentPubKeyHash someDatum adaValue contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc tx1 = Constraints.mustPayWithDatumToPubKey w2PaymentPubKeyHash someDatum adaValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Successful use of offchain and onchain mustPayWithDatumToPubKey constraint with bytestring datum and ada value" (assertValidatedTransactionCount 1) (void $ trace contract) -- | Valid scenario using offchain and onchain constraint mustPayWithDatumToPubKeyAddress with bytestring datum and ada value -successfulUseOfMustPayWithDatumToPubKeyAddress :: TestTree -successfulUseOfMustPayWithDatumToPubKeyAddress = +successfulUseOfMustPayWithDatumToPubKeyAddress :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayWithDatumToPubKeyAddress submitTxFromConstraints tc = let onChainConstraint = asRedeemer $ MustPayWithDatumToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc tx1 = Constraints.mustPayWithDatumToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Successful use of offchain and onchain mustPayWithDatumToPubKeyAddress constraint with bytestring datum and ada value" (assertValidatedTransactionCount 1) (void $ trace contract) -- | Phase-2 failure when onchain mustPayWithDatumToPubKeyAddress constraint cannot verify the PaymentPubkeyHash" -phase2FailureWhenUsingUnexpectedPaymentPubKeyHash :: TestTree -phase2FailureWhenUsingUnexpectedPaymentPubKeyHash = +phase2FailureWhenUsingUnexpectedPaymentPubKeyHash :: SubmitTx -> LanguageContext -> TestTree +phase2FailureWhenUsingUnexpectedPaymentPubKeyHash submitTxFromConstraints tc = let onChainConstraint = asRedeemer $ MustPayWithDatumToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc tx1 = Constraints.mustPayWithDatumToPubKeyAddress w1PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Phase-2 validation failure occurs when onchain mustPayWithDatumToPubKeyAddress constraint sees an unexpected PaymentPubkeyHash" (assertFailedTransaction (\_ err _ -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False })) (void $ trace contract) -- | Phase-2 failure when onchain mustPayWithDatumToPubKeyAddress constraint cannot verify the Datum" -phase2FailureWhenUsingUnexpectedDatum :: TestTree -phase2FailureWhenUsingUnexpectedDatum = +phase2FailureWhenUsingUnexpectedDatum :: SubmitTx -> LanguageContext -> TestTree +phase2FailureWhenUsingUnexpectedDatum submitTxFromConstraints tc = let onChainConstraint = asRedeemer $ MustPayWithDatumToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash otherDatum adaValue contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc tx1 = Constraints.mustPayWithDatumToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Phase-2 validation failure occurs when onchain mustPayWithDatumToPubKeyAddress constraint sees an unexpected Datum" (assertFailedTransaction (\_ err _ -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False })) (void $ trace contract) -- | Phase-2 failure when onchain mustPayWithDatumToPubKeyAddress constraint cannot verify the Value" -phase2FailureWhenUsingUnexpectedValue :: TestTree -phase2FailureWhenUsingUnexpectedValue = +phase2FailureWhenUsingUnexpectedValue :: SubmitTx -> LanguageContext -> TestTree +phase2FailureWhenUsingUnexpectedValue submitTxFromConstraints tc = let onChainConstraint = asRedeemer $ MustPayWithDatumToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum (Ada.lovelaceValueOf $ adaAmount + 1) contract = do - let lookups1 = Constraints.plutusV1MintingPolicy mustPayToPubKeyAddressPolicy + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc tx1 = Constraints.mustPayWithDatumToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue - <> Constraints.mustMintValueWithRedeemer onChainConstraint tknValue - ledgerTx1 <- submitTxConstraintsWith @UnitTest lookups1 tx1 + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 - in checkPredicateOptions defaultCheckOptions + in checkPredicate "Phase-2 validation failure occurs when onchain mustPayWithDatumToPubKeyAddress constraint sees an unexpected Value" (assertFailedTransaction (\_ err _ -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False })) (void $ trace contract) + + +-- | Valid scenario using offchain and onchain constraint mustPayWithDatumToPubKey with inline bytestring datum and ada value +successfulUseOfMustPayWithInlineDatumToPubKeyV2 :: SubmitTx -> LanguageContext -> TestTree +successfulUseOfMustPayWithInlineDatumToPubKeyV2 submitTxFromConstraints tc = + let onChainConstraint = asRedeemer $ MustPayWithDatumToPubKey w2PaymentPubKeyHash someDatum adaValue + contract = do + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc + tx1 = Constraints.mustPayWithDatumToPubKey w2PaymentPubKeyHash someDatum adaValue + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 + + in checkPredicate + "Successful use of offchain and onchain mustPayWithDatumToPubKey constraint with inline bytestring datum and ada value" + (assertValidatedTransactionCount 1) + (void $ trace contract) + +-- | Phase-1 failure when mustPayToPubKeyAddress in a V1 script use inline datum +phase1FailureWhenUsingInlineDatumWithV1 :: SubmitTx -> LanguageContext -> TestTree +phase1FailureWhenUsingInlineDatumWithV1 submitTxFromConstraints tc = + let onChainConstraint = asRedeemer $ MustPayWithDatumToPubKey w2PaymentPubKeyHash someDatum adaValue + contract = do + let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc + tx1 = Constraints.mustPayWithInlineDatumToPubKey w2PaymentPubKeyHash someDatum adaValue + <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc) + ledgerTx1 <- submitTxFromConstraints lookups1 tx1 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 + + in checkPredicate + "Phase-1 failure when mustPayToPubKeyAddress in a V1 script use inline datum" + (assertFailedTransaction (\_ err _ -> case err of {Ledger.CardanoLedgerValidationError _ -> True; _ -> False })) + (void $ trace contract) + + data UnitTest instance Scripts.ValidatorTypes UnitTest -{-# INLINEABLE mkMustPayToPubKeyAddressPolicy #-} -mkMustPayToPubKeyAddressPolicy :: ConstraintParams -> Ledger.ScriptContext -> Bool -mkMustPayToPubKeyAddressPolicy t = case t of - MustPayToPubKey ppkh v -> Constraints.checkScriptContext @() @() (Constraints.mustPayToPubKey ppkh v) - MustPayToPubKeyAddress ppkh spkh v -> Constraints.checkScriptContext @() @() (Constraints.mustPayToPubKeyAddress ppkh spkh v) - MustPayWithDatumToPubKey ppkh d v -> Constraints.checkScriptContext @() @() (Constraints.mustPayWithDatumToPubKey ppkh d v) - MustPayWithDatumToPubKeyAddress ppkh spkh d v -> Constraints.checkScriptContext @() @() (Constraints.mustPayWithDatumToPubKeyAddress ppkh spkh d v) -mustPayToPubKeyAddressPolicy :: Scripts.MintingPolicy -mustPayToPubKeyAddressPolicy = Ledger.mkMintingPolicyScript $$(PlutusTx.compile [||wrap||]) +data LanguageContext + = LanguageContext + { mustPayToPubKeyAddressPolicy :: Ledger.MintingPolicy + , mintingPolicy :: forall a. Ledger.MintingPolicy -> Constraints.ScriptLookups a + , mintingPolicyHash :: Ledger.MintingPolicy -> Ledger.MintingPolicyHash + } + +mustPayToPubKeyAddressPolicyV1 :: Ledger.MintingPolicy +mustPayToPubKeyAddressPolicyV1 = Ledger.mkMintingPolicyScript $$(PlutusTx.compile [||wrap||]) + where + checkedMkMustPayToPubKeyAddressPolicy = mkMustPayToPubKeyAddressPolicy Constraints.checkScriptContext + wrap = Scripts.mkUntypedMintingPolicy checkedMkMustPayToPubKeyAddressPolicy + +mustPayToPubKeyAddressPolicyV2 :: Ledger.MintingPolicy +mustPayToPubKeyAddressPolicyV2 = Ledger.mkMintingPolicyScript $$(PlutusTx.compile [||wrap||]) where - wrap = Scripts.mkUntypedMintingPolicy mkMustPayToPubKeyAddressPolicy + checkedMkMustPayToPubKeyAddressPolicy = mkMustPayToPubKeyAddressPolicy V2.Constraints.checkScriptContext + wrap = V2.Scripts.mkUntypedMintingPolicy checkedMkMustPayToPubKeyAddressPolicy + +languageContextV1 :: LanguageContext +languageContextV1 = LanguageContext + mustPayToPubKeyAddressPolicyV1 + Constraints.plutusV1MintingPolicy + PSU.V1.mintingPolicyHash + + +languageContextV2 :: LanguageContext +languageContextV2 = LanguageContext + mustPayToPubKeyAddressPolicyV2 + Constraints.plutusV2MintingPolicy + PSU.V2.mintingPolicyHash + + +mkMustPayToPubKeyAddressPolicy :: (Constraints.TxConstraints () () -> sc -> Bool) -> ConstraintParams -> sc -> Bool +mkMustPayToPubKeyAddressPolicy checkScriptContext = \case + MustPayToPubKey ppkh v -> checkScriptContext (Constraints.mustPayToPubKey ppkh v) + MustPayToPubKeyAddress ppkh spkh v -> checkScriptContext (Constraints.mustPayToPubKeyAddress ppkh spkh v) + MustPayWithDatumToPubKey ppkh d v -> checkScriptContext (Constraints.mustPayWithDatumToPubKey ppkh d v) + MustPayWithDatumToPubKeyAddress ppkh spkh d v -> checkScriptContext (Constraints.mustPayWithDatumToPubKeyAddress ppkh spkh d v) + +mustPayToPubKeyAddressPolicyHash :: LanguageContext -> Ledger.MintingPolicyHash +mustPayToPubKeyAddressPolicyHash tc = mintingPolicyHash tc $ mustPayToPubKeyAddressPolicy tc + +mustPayToPubKeyAddressPolicyCurrencySymbol :: LanguageContext -> Ledger.CurrencySymbol +mustPayToPubKeyAddressPolicyCurrencySymbol = Value.mpsSymbol . mustPayToPubKeyAddressPolicyHash + +type SubmitTx + = Constraints.ScriptLookups UnitTest + -> Constraints.TxConstraints (Scripts.RedeemerType UnitTest) (Scripts.DatumType UnitTest) + -> Contract () Empty ContractError Tx.CardanoTx + +cardanoSubmitTx :: SubmitTx +cardanoSubmitTx lookups tx = let + p = defaultCheckOptions ^. emulatorConfig . Trace.params + in submitUnbalancedTx $ either (error . show) id $ Tx.Constraints.mkTx @UnitTest p lookups tx + +ledgerSubmitTx :: SubmitTx +ledgerSubmitTx = submitTxConstraintsWith -mustPayToPubKeyAddressPolicyHash :: Ledger.MintingPolicyHash -mustPayToPubKeyAddressPolicyHash = PSU.V1.mintingPolicyHash mustPayToPubKeyAddressPolicy -mustPayToPubKeyAddressPolicyCurrencySymbol :: Ledger.CurrencySymbol -mustPayToPubKeyAddressPolicyCurrencySymbol = Value.mpsSymbol mustPayToPubKeyAddressPolicyHash data ConstraintParams = MustPayToPubKey Ledger.PaymentPubKeyHash Value.Value | MustPayToPubKeyAddress Ledger.PaymentPubKeyHash Ledger.StakePubKeyHash Value.Value diff --git a/plutus-ledger-constraints/src/Ledger/Constraints.hs b/plutus-ledger-constraints/src/Ledger/Constraints.hs index a23f03cdf3..b801794723 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints.hs @@ -11,6 +11,8 @@ module Ledger.Constraints( , TC.mustPayToPubKeyAddress , TC.mustPayWithDatumToPubKey , TC.mustPayWithDatumToPubKeyAddress + , TC.mustPayWithInlineDatumToPubKey + , TC.mustPayWithInlineDatumToPubKeyAddress , TC.mustPayToAddressWithReferenceScript , TC.mustPayToAddressWithReferenceValidator , TC.mustPayToAddressWithReferenceMintingPolicy @@ -30,7 +32,9 @@ module Ledger.Constraints( , TC.mustProduceAtLeast , TC.mustIncludeDatum , TC.mustPayToOtherScript + , TC.mustPayToOtherScriptInlineDatum , TC.mustPayToOtherScriptAddress + , TC.mustPayToOtherScriptAddressInlineDatum , TC.mustHashDatum , TC.mustSatisfyAnyOf -- * Defining off-chain only constraints diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs index 1d4ecef11f..5538405877 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs @@ -69,7 +69,7 @@ module Ledger.Constraints.OffChain( , resolveScriptTxOut ) where -import Control.Lens (_2, _Just, alaf, at, makeLensesFor, view, (%=), (&), (.~), (<&>), (<>=), (?=), (^?)) +import Control.Lens (_2, _Just, alaf, at, makeLensesFor, view, (%=), (&), (.~), (<&>), (<>=), (?=), (^.), (^?)) import Control.Monad (forM_) import Control.Monad.Except (MonadError (catchError, throwError), runExcept, unless) import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT), asks) @@ -87,17 +87,20 @@ import Data.Set qualified as Set import GHC.Generics (Generic) import Prettyprinter (Pretty (pretty), colon, hang, vsep, (<+>)) -import Ledger (outValue) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Ledger (Redeemer (Redeemer), outValue) import Ledger.Ada qualified as Ada import Ledger.Address (PaymentPubKey (PaymentPubKey), PaymentPubKeyHash (PaymentPubKeyHash), StakePubKeyHash, pubKeyHashAddress) import Ledger.Address qualified as Address -import Ledger.Constraints.TxConstraints (ScriptInputConstraint (ScriptInputConstraint, icRedeemer, icTxOutRef), +import Ledger.Constraints.TxConstraints (OutDatum (Hashed, Inline), + ScriptInputConstraint (ScriptInputConstraint, icRedeemer, icTxOutRef), ScriptOutputConstraint (ScriptOutputConstraint, ocDatum, ocReferenceScriptHash, ocValue), TxConstraint (MustBeSignedBy, MustHashDatum, MustIncludeDatum, MustMintValue, MustPayToOtherScript, MustPayToPubKeyAddress, MustProduceAtLeast, MustReferenceOutput, MustSatisfyAnyOf, MustSpendAtLeast, MustSpendPubKeyOutput, MustSpendScriptOutput, MustUseOutputAsCollateral, MustValidateIn), TxConstraintFun (MustSpendScriptOutputWithMatchingDatumAndValue), TxConstraintFuns (TxConstraintFuns), - TxConstraints (TxConstraints, txConstraintFuns, txConstraints, txOwnInputs, txOwnOutputs)) + TxConstraints (TxConstraints, txConstraintFuns, txConstraints, txOwnInputs, txOwnOutputs), + getOutDatum) import Ledger.Crypto (pubKeyHash) import Ledger.Index (minAdaTxOut) import Ledger.Orphans () @@ -106,18 +109,17 @@ import Ledger.Tx (ChainIndexTxOut, Language (PlutusV1, PlutusV2), TxOut (TxOut), outDatumHash, txOutValue) import Ledger.Tx qualified as Tx import Ledger.Tx.CardanoAPI qualified as C -import Ledger.Typed.Scripts (Any, ConnectionError (UnknownRef), TypedValidator, +import Ledger.Typed.Scripts (Any, ConnectionError (UnknownRef), TypedValidator (tvValidator, tvValidatorHash), ValidatorTypes (DatumType, RedeemerType)) -import Ledger.Typed.Scripts qualified as Typed import Ledger.Validation (evaluateMinLovelaceOutput, fromPlutusTxOut) import Plutus.Script.Utils.Scripts qualified as P -import Plutus.Script.Utils.V1.Tx (scriptAddressTxOut) +import Plutus.Script.Utils.V2.Typed.Scripts qualified as Typed import Plutus.V1.Ledger.Api (Datum (Datum), DatumHash, POSIXTimeRange, Validator (getValidator), Value, getMintingPolicy) import Plutus.V1.Ledger.Scripts (MintingPolicy (MintingPolicy), MintingPolicyHash (MintingPolicyHash), Script, ScriptHash (ScriptHash), Validator (Validator), ValidatorHash (ValidatorHash)) -import Plutus.V1.Ledger.Tx qualified as PV1 import Plutus.V1.Ledger.Value qualified as Value +import Plutus.V2.Ledger.Tx qualified as PV2 import PlutusTx (FromData, ToData (toBuiltinData)) import PlutusTx.Lattice (BoundedMeetSemiLattice (top), JoinSemiLattice ((\/)), MeetSemiLattice ((/\))) import PlutusTx.Numeric qualified as N @@ -179,7 +181,7 @@ instance Monoid (ScriptLookups a) where -- @ typedValidatorLookups :: TypedValidator a -> ScriptLookups a typedValidatorLookups inst = - let (ValidatorHash vh, v) = (Typed.tvValidatorHash inst, Typed.tvValidator inst) + let (ValidatorHash vh, v) = (tvValidatorHash inst, tvValidator inst) (MintingPolicyHash mph, mp) = (Typed.forwardingMintingPolicyHash inst, Typed.vForwardingMintingPolicy inst) in mempty { slOtherScripts = @@ -497,11 +499,12 @@ addMissingValueSpent = do -- Step 4 of the process described in [Balance of value spent] pkh <- asks slOwnPaymentPubKeyHash >>= maybe (throwError OwnPubKeyMissing) pure skh <- asks slOwnStakePubKeyHash - let pv1TxOut = PV1.TxOut { PV1.txOutAddress=pubKeyHashAddress pkh skh - , PV1.txOutValue=missing - , PV1.txOutDatumHash=Nothing + let pv2TxOut = PV2.TxOut { PV2.txOutAddress=pubKeyHashAddress pkh skh + , PV2.txOutValue=missing + , PV2.txOutDatum=PV2.NoOutputDatum + , PV2.txOutReferenceScript= Nothing } - txOut <- toCardanoTxOutWithHashedDatum pv1TxOut + txOut <- toCardanoTxOutWithOutputDatum pv2TxOut unbalancedTx . tx . Tx.outputs %= (txOut:) updateUtxoIndex @@ -512,7 +515,7 @@ updateUtxoIndex => m () updateUtxoIndex = do ScriptLookups{slTxOutputs} <- ask - slUtxos <- traverse (toCardanoTxOutWithHashedDatum . Tx.toTxOut) slTxOutputs + slUtxos <- traverse (toCardanoTxOutWithOutputDatum . Tx.toTxOut) slTxOutputs unbalancedTx . utxoIndex <>= slUtxos -- | Add a typed input, checking the type of the output it spends. Return the value @@ -539,14 +542,15 @@ addOwnInput ScriptInputConstraint{icRedeemer, icTxOutRef} = do datum <- ciTxOut ^? Tx.ciTxOutScriptDatum . _2 . _Just pure (Tx.toTxOut ciTxOut, datum) Typed.typeScriptTxOutRef inst icTxOutRef txOut datum - let txIn = Typed.makeTypedScriptTxIn inst icRedeemer typedOutRef - vl = PV1.txOutValue $ Typed.tyTxOutTxOut $ Typed.tyTxOutRefOut typedOutRef + let vl = PV2.txOutValue $ Typed.tyTxOutTxOut $ Typed.tyTxOutRefOut typedOutRef valueSpentInputs <>= provided vl - case Typed.tyTxInTxIn txIn of - -- this is what makeTypedScriptTxIn makes - Tx.TxIn outRef (Just (Tx.ConsumeScriptAddress validator rs dt)) -> do - unbalancedTx . tx %= Tx.addScriptTxInput outRef validator rs dt - _ -> error "Impossible txIn in addOwnInput." + case typedOutRef of + Typed.TypedScriptTxOutRef{Typed.tyTxOutRefRef, Typed.tyTxOutRefOut} -> do + unbalancedTx . tx %= Tx.addScriptTxInput + tyTxOutRefRef + (Typed.vValidatorScript inst) + (Redeemer $ toBuiltinData icRedeemer) + (Datum $ toBuiltinData $ Typed.tyTxOutData tyTxOutRefOut) @@ -562,7 +566,7 @@ addOwnOutput ScriptOutputConstraint{ocDatum, ocValue, ocReferenceScriptHash} = d ScriptLookups{slTypedValidator} <- ask inst <- maybe (throwError TypedValidatorMissing) pure slTypedValidator let dsV = Datum (toBuiltinData ocDatum) - pure $ MustPayToOtherScript (Typed.tvValidatorHash inst) Nothing dsV ocReferenceScriptHash ocValue + pure $ MustPayToOtherScript (tvValidatorHash inst) Nothing (Hashed dsV) ocReferenceScriptHash ocValue data MkTxError = TypeCheckFailed Typed.ConnectionError @@ -654,6 +658,7 @@ processConstraint => TxConstraint -> m () processConstraint = \case + MustIncludeDatum dv -> let theHash = P.datumHash dv in unbalancedTx . tx . Tx.datumWitnesses . at theHash ?= dv @@ -663,6 +668,7 @@ processConstraint = \case unbalancedTx . requiredSignatories <>= Set.singleton pk MustSpendAtLeast vl -> valueSpentInputs <>= required vl MustProduceAtLeast vl -> valueSpentOutputs <>= required vl + MustSpendPubKeyOutput txo -> do txout <- lookupTxOutRef txo case txout of @@ -671,9 +677,10 @@ processConstraint = \case unbalancedTx . tx . Tx.inputs %= (Tx.pubKeyTxInput txo :) valueSpentInputs <>= provided _ciTxOutValue _ -> throwError (TxOutRefWrongType txo) + MustSpendScriptOutput txo red -> do txout <- lookupTxOutRef txo - mscriptTXO <- resolveScriptTxOut txout + mscriptTXO <- runMaybeT $ resolveScriptTxOut txout case mscriptTXO of Just ((_, validator), (_, datum), value) -> do unbalancedTx . tx %= Tx.addScriptTxInput txo validator red datum @@ -694,33 +701,42 @@ processConstraint = \case if i < 0 then valueSpentInputs <>= provided (value (negate i)) else valueSpentOutputs <>= provided (value i) - unbalancedTx . tx . Tx.mintScripts %= Map.insert mpsHash red unbalancedTx . tx . Tx.scriptWitnesses %= Map.insert (ScriptHash mpsHashBytes) (fmap getMintingPolicy mintingPolicyScript) unbalancedTx . tx . Tx.mint <>= value i + MustPayToPubKeyAddress pk skhM mdv _refScript vl -> do -- TODO: implement adding reference script -- if datum is presented, add it to 'datumWitnesses' forM_ mdv $ \dv -> do - unbalancedTx . tx . Tx.datumWitnesses . at (P.datumHash dv) ?= dv - let pv1TxOut = PV1.TxOut { PV1.txOutAddress=pubKeyHashAddress pk skhM - , PV1.txOutValue=vl - , PV1.txOutDatumHash=Nothing + let d = getOutDatum dv + unbalancedTx . tx . Tx.datumWitnesses . at (P.datumHash d) ?= d + let pv2TxOut = PV2.TxOut { PV2.txOutAddress=pubKeyHashAddress pk skhM + , PV2.txOutValue=vl + , PV2.txOutDatum=PV2.NoOutputDatum + , PV2.txOutReferenceScript=Nothing } - let txInDatum = C.toCardanoTxOutDatumInTx mdv - txOut <- toCardanoTxOutWithHashedDatum pv1TxOut <&> outDatumHash .~ txInDatum - unbalancedTx . tx . Tx.outputs %= (txOut :) + let txInDatum = case mdv of + Nothing -> C.toCardanoTxOutNoDatum + Just (Hashed d) -> C.toCardanoTxOutDatumInTx d + Just (Inline d) -> C.toCardanoTxOutDatumInline d + txOut <- toCardanoTxOutWithOutputDatum pv2TxOut <&> outDatumHash .~ txInDatum + unbalancedTx . tx . Tx.outputs <>= [txOut] valueSpentOutputs <>= provided vl + MustPayToOtherScript vlh svhM dv _refScript vl -> do -- TODO: implement adding reference script let addr = Address.scriptValidatorHashAddress vlh svhM - theHash = P.datumHash dv - pv1script = scriptAddressTxOut addr vl dv - unbalancedTx . tx . Tx.datumWitnesses . at theHash ?= dv - - let txInDatum = C.toCardanoTxOutDatumInTx (Just dv) - txScript <- toCardanoTxOutWithHashedDatum pv1script <&> outDatumHash .~ txInDatum - unbalancedTx . tx . Tx.outputs %= (txScript :) + d = getOutDatum dv + theHash = P.datumHash d + pv2script = PV2.TxOut addr vl PV2.NoOutputDatum Nothing + unbalancedTx . tx . Tx.datumWitnesses . at theHash ?= d + + let txInDatum = case dv of + Hashed _ -> C.toCardanoTxOutDatumInTx d + Inline _ -> C.toCardanoTxOutDatumInline d + txScript <- toCardanoTxOutWithOutputDatum pv2script <&> outDatumHash .~ txInDatum + unbalancedTx . tx . Tx.outputs <>= [txScript] valueSpentOutputs <>= provided vl MustHashDatum dvh dv -> do unless (P.datumHash dv == dvh) @@ -731,7 +747,7 @@ processConstraint = \case let tryNext [] = throwError CannotSatisfyAny tryNext (hs:qs) = do - traverse_ processConstraint hs `catchError` \_ -> put s >> tryNext qs + traverse_ processConstraint hs `catchError` const (put s >> tryNext qs) tryNext xs processConstraintFun @@ -751,7 +767,7 @@ processConstraintFun = \case validatorHash == vh && datumPred datum && valuePred value matches Nothing = False opts <- filter (matches . snd) - <$> traverse (\(ref, txo) -> (ref,) <$> resolveScriptTxOut txo) + <$> traverse (traverse $ runMaybeT . resolveScriptTxOut) (Map.toList slTxOutputs) case opts of [] -> throwError $ NoMatchingOutputFound vh @@ -764,30 +780,26 @@ resolveScriptTxOut :: ( MonadReader (ScriptLookups a) m , MonadError MkTxError m ) - => ChainIndexTxOut -> m (Maybe ((ValidatorHash, Versioned Validator), (DatumHash, Datum), Value)) -resolveScriptTxOut - Tx.ScriptChainIndexTxOut - { Tx._ciTxOutValidator = (vh, v) - , Tx._ciTxOutScriptDatum = (dh, d) - , Tx._ciTxOutValue - } = do + => ChainIndexTxOut -> MaybeT m ((ValidatorHash, Versioned Validator), (DatumHash, Datum), Value) +resolveScriptTxOut ci = do -- first check in the 'ChainIndexTxOut' for the validator, then -- look for it in the 'slOtherScripts' map. + (vh, v) <- hoistMaybe $ ci ^? Tx.ciTxOutValidator validator <- maybe (lookupValidator vh) pure v - - -- first check in the 'ChainIndexTxOut' for the datum, then - -- look for it in the 'slOtherData' map. + (dh, d) <- hoistMaybe $ ci ^? Tx.ciTxOutScriptDatum dataValue <- maybe (lookupDatum dh) pure d + let _ciTxOutValue = ci ^. Tx.ciTxOutValue + pure ((vh, validator), (dh, dataValue), _ciTxOutValue) - pure $ Just ((vh, validator), (dh, dataValue), _ciTxOutValue) -resolveScriptTxOut _ = pure Nothing - -toCardanoTxOutWithHashedDatum +toCardanoTxOutWithOutputDatum :: ( MonadState ConstraintProcessingState m, MonadError MkTxError m) - => PV1.TxOut -> m TxOut -toCardanoTxOutWithHashedDatum txout = do + => PV2.TxOut -> m TxOut +toCardanoTxOutWithOutputDatum txout = do networkId <- gets $ pNetworkId . cpsParams - let cardanoTxOut = TxOut <$> C.toCardanoTxOut networkId C.toCardanoTxOutDatumHash txout + let cardanoTxOut = TxOut <$> C.toCardanoTxOut networkId C.toCardanoTxOutDatum txout case cardanoTxOut of Left err -> throwError $ TxOutCardanoError err Right cTxOut -> pure cTxOut + +hoistMaybe :: Applicative m => Maybe a -> MaybeT m a +hoistMaybe = MaybeT . pure diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs index 8d234b7066..89e7d9215d 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs @@ -27,7 +27,8 @@ import Ledger.Constraints.TxConstraints (ScriptInputConstraint (ScriptInputConst TxConstraint (MustBeSignedBy, MustHashDatum, MustIncludeDatum, MustMintValue, MustPayToOtherScript, MustPayToPubKeyAddress, MustProduceAtLeast, MustReferenceOutput, MustSatisfyAnyOf, MustSpendAtLeast, MustSpendPubKeyOutput, MustSpendScriptOutput, MustUseOutputAsCollateral, MustValidateIn), TxConstraintFun (MustSpendScriptOutputWithMatchingDatumAndValue), TxConstraintFuns (TxConstraintFuns), - TxConstraints (TxConstraints, txConstraintFuns, txConstraints, txOwnInputs, txOwnOutputs)) + TxConstraints (TxConstraints, txConstraintFuns, txConstraints, txOwnInputs, txOwnOutputs), + getOutDatum) import Ledger.Credential (Credential (ScriptCredential)) import Ledger.Value qualified as Value import Plutus.V1.Ledger.Address qualified as Address @@ -113,11 +114,11 @@ checkTxConstraint ctx@ScriptContext{scriptContextTxInfo} = \case in traceIfFalse "La" -- "MustPayToPubKey" $ vl `leq` V.valuePaidTo scriptContextTxInfo pk - && maybe True (\dv -> any (checkOutput dv) outs) mdv + && maybe True (\dv -> any (checkOutput $ getOutDatum dv) outs) mdv && isNothing refScript MustPayToOtherScript vlh _ dv refScript vl -> let outs = V.txInfoOutputs scriptContextTxInfo - hsh = V.findDatumHash dv scriptContextTxInfo + hsh = V.findDatumHash (getOutDatum dv) scriptContextTxInfo addr = Address.scriptHashAddress vlh checkOutput TxOut{txOutAddress, txOutValue, txOutDatumHash=Just svh} = Ada.fromValue txOutValue >= Ada.fromValue vl diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V2.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V2.hs index 1162c99281..6e4dca7532 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V2.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V2.hs @@ -23,7 +23,8 @@ import Ledger.Constraints.TxConstraints (ScriptInputConstraint (ScriptInputConst TxConstraint (MustBeSignedBy, MustHashDatum, MustIncludeDatum, MustMintValue, MustPayToOtherScript, MustPayToPubKeyAddress, MustProduceAtLeast, MustReferenceOutput, MustSatisfyAnyOf, MustSpendAtLeast, MustSpendPubKeyOutput, MustSpendScriptOutput, MustUseOutputAsCollateral, MustValidateIn), TxConstraintFun (MustSpendScriptOutputWithMatchingDatumAndValue), TxConstraintFuns (TxConstraintFuns), - TxConstraints (TxConstraints, txConstraintFuns, txConstraints, txOwnInputs, txOwnOutputs)) + TxConstraints (TxConstraints, txConstraintFuns, txConstraints, txOwnInputs, txOwnOutputs), + getOutDatum) import Ledger.Credential (Credential (ScriptCredential)) import Ledger.Value qualified as Value import Plutus.Script.Utils.V2.Contexts qualified as PV2 hiding (findTxInByTxOutRef) @@ -116,16 +117,17 @@ checkTxConstraint ctx@ScriptContext{scriptContextTxInfo} = \case MustPayToPubKeyAddress (PaymentPubKeyHash pk) _skh mdv _refScript vl -> let outs = PV2.txInfoOutputs scriptContextTxInfo hsh dv = PV2.findDatumHash dv scriptContextTxInfo - checkOutput (Just dv) TxOut{txOutDatum=OutputDatumHash dh} = hsh dv == Just dh - checkOutput (Just dv) TxOut{txOutDatum=OutputDatum d} = dv == d - -- return 'True' by default meaning we fail only when the provided datum is not found - checkOutput _ _ = True + checkOutput dv TxOut{txOutDatum=OutputDatumHash dh} = hsh dv == Just dh + checkOutput dv TxOut{txOutDatum=OutputDatum d} = dv == d + checkOutput _ _ = False in traceIfFalse "La" -- "MustPayToPubKey" - $ vl `leq` PV2.valuePaidTo scriptContextTxInfo pk && any (checkOutput mdv) outs + $ vl `leq` PV2.valuePaidTo scriptContextTxInfo pk + && maybe True (\dv -> any (checkOutput $ getOutDatum dv) outs) mdv MustPayToOtherScript vlh _skh dv _refScript vl -> let outs = PV2.txInfoOutputs scriptContextTxInfo - hsh = PV2.findDatumHash dv scriptContextTxInfo + -- We only chek the datum, we do not distinguish how it is paased + hsh = PV2.findDatumHash (getOutDatum dv) scriptContextTxInfo addr = Address (ScriptCredential vlh) Nothing checkOutput TxOut{txOutAddress, txOutValue, txOutDatum=OutputDatumHash dh} = Ada.fromValue txOutValue >= Ada.fromValue vl @@ -137,7 +139,7 @@ checkTxConstraint ctx@ScriptContext{scriptContextTxInfo} = \case Ada.fromValue txOutValue >= Ada.fromValue vl && Ada.fromValue txOutValue <= Ada.fromValue vl + Ledger.maxMinAdaTxOut && Value.noAdaValue txOutValue == Value.noAdaValue vl - && dv == id + && getOutDatum dv == id && txOutAddress == addr checkOutput _ = False in diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs b/plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs index fba29a288e..a362381a58 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs @@ -52,6 +52,26 @@ import Data.Maybe (fromMaybe) import Prelude qualified as Haskell import Prettyprinter.Render.String (renderShowS) +-- | How tx outs datum are embedded in a a Tx +-- +-- We do not use 'TxOutDatum' from cardano-node to provide easier to handel type (we don't type witnesses) +-- and to have a distinction at the type leve between constraints +-- that require a Datum and constraints (like 'MustPayToOtherScript') with an optional datum +-- (like 'MustPayToPubKeyAddress'). +data OutDatum = Inline Datum | Hashed Datum + deriving stock (Haskell.Show, Generic, Haskell.Eq) + deriving anyclass (ToJSON, FromJSON) + +{-# INLINABLE getOutDatum #-} +getOutDatum :: OutDatum -> Datum +getOutDatum (Hashed d) = d +getOutDatum (Inline d) = d + +instance Pretty OutDatum where + pretty = \case + Inline d -> "inline datum" <+> pretty d + Hashed d -> "hashed datum" <+> pretty d + -- | Constraints on transactions that want to spend script outputs data TxConstraint = MustHashDatum DatumHash Datum @@ -80,9 +100,9 @@ data TxConstraint = -- ^ The transaction must reference (not spend) the given unspent transaction output. | MustMintValue MintingPolicyHash Redeemer TokenName Integer -- ^ The transaction must mint the given token and amount. - | MustPayToPubKeyAddress PaymentPubKeyHash (Maybe StakePubKeyHash) (Maybe Datum) (Maybe ScriptHash) Value + | MustPayToPubKeyAddress PaymentPubKeyHash (Maybe StakePubKeyHash) (Maybe OutDatum) (Maybe ScriptHash) Value -- ^ The transaction must create a transaction output with a public key address. - | MustPayToOtherScript ValidatorHash (Maybe StakeValidatorHash) Datum (Maybe ScriptHash) Value + | MustPayToOtherScript ValidatorHash (Maybe StakeValidatorHash) OutDatum (Maybe ScriptHash) Value -- ^ The transaction must create a transaction output with a script address. | MustSatisfyAnyOf [[TxConstraint]] -- ^ The transaction must satisfy constraints given as an alternative of conjuctions (DNF), @@ -341,7 +361,19 @@ mustPayWithDatumToPubKey -> Value -> TxConstraints i o mustPayWithDatumToPubKey pk datum vl = - singleton (MustPayToPubKeyAddress pk Nothing (Just datum) Nothing vl) + singleton (MustPayToPubKeyAddress pk Nothing (Just $ Hashed datum) Nothing vl) + +{-# INLINABLE mustPayWithInlineDatumToPubKey #-} +-- | @mustPayWithInlineDatumToPubKey pkh d v@ is the same as +-- 'mustPayWithDatumToPubKeyAddress', but with an inline datum and without the staking key hash. +mustPayWithInlineDatumToPubKey + :: forall i o + . PaymentPubKeyHash + -> Datum + -> Value + -> TxConstraints i o +mustPayWithInlineDatumToPubKey pk datum vl = + singleton (MustPayToPubKeyAddress pk Nothing (Just $ Inline datum) Nothing vl) {-# INLINABLE mustPayWithDatumToPubKeyAddress #-} -- | @mustPayWithDatumToPubKeyAddress pkh skh d v@ locks a transaction output @@ -362,7 +394,20 @@ mustPayWithDatumToPubKeyAddress -> Value -> TxConstraints i o mustPayWithDatumToPubKeyAddress pkh skh datum vl = - singleton (MustPayToPubKeyAddress pkh (Just skh) (Just datum) Nothing vl) + singleton (MustPayToPubKeyAddress pkh (Just skh) (Just $ Hashed datum) Nothing vl) + +{-# INLINABLE mustPayWithInlineDatumToPubKeyAddress #-} +-- | @mustPayWithInlineInlineDatumToPubKeyAddress pkh d v@ is the same as +-- 'mustPayWithInlineDatumToPubKeyAddress', but the datum is inline in the Tx. +mustPayWithInlineDatumToPubKeyAddress + :: forall i o + . PaymentPubKeyHash + -> StakePubKeyHash + -> Datum + -> Value + -> TxConstraints i o +mustPayWithInlineDatumToPubKeyAddress pkh skh datum vl = + singleton (MustPayToPubKeyAddress pkh (Just skh) (Just $ Inline datum) Nothing vl) {-# INLINABLE mustPayToAddressWithReferenceValidator #-} -- | @mustPayToAddressWithReferenceValidator@ is a helper that calls @mustPayToAddressWithReferenceScript@. @@ -370,7 +415,7 @@ mustPayToAddressWithReferenceValidator :: forall i o . Address -> ValidatorHash - -> Maybe Datum + -> Maybe OutDatum -> Value -> TxConstraints i o mustPayToAddressWithReferenceValidator addr (ValidatorHash vh) = mustPayToAddressWithReferenceScript addr (ScriptHash vh) @@ -381,7 +426,7 @@ mustPayToAddressWithReferenceMintingPolicy :: forall i o . Address -> MintingPolicyHash - -> Maybe Datum + -> Maybe OutDatum -> Value -> TxConstraints i o mustPayToAddressWithReferenceMintingPolicy addr (MintingPolicyHash vh) = mustPayToAddressWithReferenceScript addr (ScriptHash vh) @@ -401,7 +446,7 @@ mustPayToAddressWithReferenceScript :: forall i o . Address -> ScriptHash - -> Maybe Datum + -> Maybe OutDatum -> Value -> TxConstraints i o mustPayToAddressWithReferenceScript @@ -412,10 +457,10 @@ mustPayToAddressWithReferenceScript singleton (MustPayToPubKeyAddress (PaymentPubKeyHash pkh) Nothing datum (Just scriptHash) value) mustPayToAddressWithReferenceScript (Address (ScriptCredential vh) (Just (StakingHash (ScriptCredential (ValidatorHash sh))))) scriptHash datum value = - singleton (MustPayToOtherScript vh (Just (StakeValidatorHash sh)) (fromMaybe unitDatum datum) (Just scriptHash) value) + singleton (MustPayToOtherScript vh (Just (StakeValidatorHash sh)) (fromMaybe (Inline unitDatum) datum) (Just scriptHash) value) mustPayToAddressWithReferenceScript (Address (ScriptCredential vh) Nothing) scriptHash datum value = - singleton (MustPayToOtherScript vh Nothing (fromMaybe unitDatum datum) (Just scriptHash) value) + singleton (MustPayToOtherScript vh Nothing (fromMaybe (Inline unitDatum) datum) (Just scriptHash) value) mustPayToAddressWithReferenceScript addr _ _ _ = Haskell.error $ "Ledger.Constraints.TxConstraints.mustPayToAddressWithReferenceScript: unsupported address " Haskell.++ Haskell.show addr @@ -424,7 +469,21 @@ mustPayToAddressWithReferenceScript -- 'mustPayToOtherScriptAddress', but without the staking key hash. mustPayToOtherScript :: forall i o. ValidatorHash -> Datum -> Value -> TxConstraints i o mustPayToOtherScript vh dv vl = - singleton (MustPayToOtherScript vh Nothing dv Nothing vl) + singleton (MustPayToOtherScript vh Nothing (Hashed dv) Nothing vl) + +{-# INLINABLE mustPayToOtherScriptInlineDatum #-} +-- | @mustPayToOtherScript vh d v@ is the same as +-- 'mustPayToOtherScriptAddress', but with an inline datum and without the staking key hash. +mustPayToOtherScriptInlineDatum :: forall i o. ValidatorHash -> Datum -> Value -> TxConstraints i o +mustPayToOtherScriptInlineDatum vh dv vl = + singleton (MustPayToOtherScript vh Nothing (Inline dv) Nothing vl) + +{-# INLINABLE mustPayToOtherScriptAddressInlineDatum #-} +-- | @mustPayToOtherScriptAddressInlineDatum vh d v@ is the same as +-- 'mustPayToOtherScriptAddress', but with an inline datum. +mustPayToOtherScriptAddressInlineDatum :: forall i o. ValidatorHash -> StakeValidatorHash -> Datum -> Value -> TxConstraints i o +mustPayToOtherScriptAddressInlineDatum vh svh dv vl = + singleton (MustPayToOtherScript vh (Just svh) (Inline dv) Nothing vl) {-# INLINABLE mustPayToOtherScriptAddress #-} -- | @mustPayToOtherScriptAddress vh svh d v@ locks the value @v@ with the given script @@ -439,7 +498,7 @@ mustPayToOtherScript vh dv vl = -- @vh@, @svh@, @d@ and @v@ is part of the transaction's outputs. mustPayToOtherScriptAddress :: forall i o. ValidatorHash -> StakeValidatorHash -> Datum -> Value -> TxConstraints i o mustPayToOtherScriptAddress vh svh dv vl = - singleton (MustPayToOtherScript vh (Just svh) dv Nothing vl) + singleton (MustPayToOtherScript vh (Just svh) (Hashed dv) Nothing vl) {-# INLINABLE mustMintValue #-} -- | Same as 'mustMintValueWithRedeemer', but sets the redeemer to the unit diff --git a/plutus-ledger-constraints/test/Spec.hs b/plutus-ledger-constraints/test/Spec.hs index ff44c05d0d..111cc3189e 100644 --- a/plutus-ledger-constraints/test/Spec.hs +++ b/plutus-ledger-constraints/test/Spec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -21,6 +22,7 @@ import Hedgehog qualified import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Language.Haskell.TH.Syntax +import Ledger (datumHash) import Ledger qualified (ChainIndexTxOut (ScriptChainIndexTxOut), inputs, paymentPubKeyHash, scriptTxInputs, toTxOut, txInputRef, unitDatum, unitRedeemer) import Ledger.Ada qualified as Ada @@ -36,13 +38,14 @@ import Ledger.Index qualified as Ledger import Ledger.Params (Params (pNetworkId)) import Ledger.Scripts (WitCtx (WitCtxStake), examplePlutusScriptAlwaysSucceedsHash) import Ledger.Tx (Tx (txCollateral, txOutputs), TxOut (TxOut), txOutAddress) -import Ledger.Tx.CardanoAPI (toCardanoTxOut, toCardanoTxOutDatumHash) +import Ledger.Tx.CardanoAPI (toCardanoTxOut, toCardanoTxOutDatum, toCardanoTxOutDatumHash, toCardanoTxOutNoDatum) import Ledger.Value (CurrencySymbol, Value (Value)) import Ledger.Value qualified as Value import Plutus.Script.Utils.V2.Generators qualified as Gen import Plutus.Script.Utils.V2.Scripts qualified as Ledger import Plutus.Script.Utils.V2.Typed.Scripts qualified as Scripts import Plutus.V2.Ledger.Api qualified as Ledger +import Plutus.V2.Ledger.Api qualified as PV2 import PlutusTx qualified import PlutusTx.AssocMap qualified as AMap import PlutusTx.Builtins.Internal (BuiltinByteString (..)) @@ -185,7 +188,7 @@ testScriptInputs lookups txc = property $ do let valM = do Ledger.checkValidInputs (toListOf (Ledger.inputs . Ledger.scriptTxInputs)) tx pure Nothing - txOuts = traverse (toCardanoTxOut (pNetworkId params) toCardanoTxOutDatumHash) + txOuts = traverse (toCardanoTxOut (pNetworkId params) toCardanoTxOutDatum) $ Ledger.toTxOut <$> Constraints.slTxOutputs lookups case txOuts of Left err -> do diff --git a/plutus-ledger/src/Ledger/Tx.hs b/plutus-ledger/src/Ledger/Tx.hs index 54337cfb53..b0e090ebd6 100644 --- a/plutus-ledger/src/Ledger/Tx.hs +++ b/plutus-ledger/src/Ledger/Tx.hs @@ -86,9 +86,11 @@ import Ledger.Slot (SlotRange) import Ledger.Tx.CardanoAPI (SomeCardanoApiTx (SomeTx), ToCardanoError (..)) import Ledger.Tx.CardanoAPI qualified as CardanoAPI import Ledger.Validation qualified -import Plutus.Script.Utils.Scripts (datumHash) +import Plutus.Script.Utils.Scripts (datumHash, scriptHash) import Plutus.V1.Ledger.Api qualified as V1 import Plutus.V1.Ledger.Tx qualified as V1.Tx hiding (TxIn (..), TxInType (..)) +import Plutus.V2.Ledger.Api qualified as V2 +import Plutus.V2.Ledger.Tx qualified as V2.Tx hiding (TxIn (..), TxInType (..)) import Prettyprinter (Pretty (pretty), braces, colon, hang, nest, viaShow, vsep, (<+>)) -- for re-export import Control.DeepSeq (NFData) @@ -112,9 +114,9 @@ data ChainIndexTxOut = -- public key hash. _ciTxOutAddress :: Address, -- | Value of the transaction output. - _ciTxOutValue :: V1.Value, - -- | Optional datum attached to the transaction output. - _ciTxOutPublicKeyDatum :: Maybe (V1.DatumHash, Maybe V1.Datum), + _ciTxOutValue :: V2.Value, + -- | Optional datum (inline datum or datum in transaction body) attached to the transaction output. + _ciTxOutPublicKeyDatum :: Maybe (V2.DatumHash, Maybe V2.Datum), -- | Optional reference script attached to the transaction output. _ciTxOutReferenceScript :: Maybe (Versioned V1.Script) } @@ -124,10 +126,10 @@ data ChainIndexTxOut = _ciTxOutAddress :: Address, -- | Value of the transaction output. _ciTxOutValue :: V1.Value, - -- | Datum attached to the transaction output, either in full or as a + -- | Datum attached to the transaction output, either in full (inline datum or datum in transaction body) or as a -- hash reference. A transaction output protected by a Plutus script -- is guardateed to have an associated datum. - _ciTxOutScriptDatum :: (V1.DatumHash, Maybe V1.Datum), + _ciTxOutScriptDatum :: (V2.DatumHash, Maybe V2.Datum), -- | Optional reference script attached to the transaction output. -- The reference script is, in genereal, unrelated to the validator -- script althought it could also be the same. @@ -147,12 +149,16 @@ makePrisms ''ChainIndexTxOut -- Note that 'ChainIndexTxOut' supports features such inline datums and -- reference scripts which are not supported by V1 TxOut. Converting from -- 'ChainIndexTxOut' to 'TxOut' and back is therefore lossy. -toTxOut :: ChainIndexTxOut -> V1.Tx.TxOut -toTxOut (PublicKeyChainIndexTxOut addr v datum _referenceScript) = - V1.Tx.TxOut addr v (fst <$> datum) -toTxOut (ScriptChainIndexTxOut addr v (dh, _) _referenceScript _validator) = - V1.Tx.TxOut addr v (Just dh) --- +toTxOut :: ChainIndexTxOut -> V2.Tx.TxOut +toTxOut (PublicKeyChainIndexTxOut addr v datum referenceScript) = + V2.Tx.TxOut addr v (toPlutusOutDatum datum) (scriptHash <$> referenceScript) +toTxOut (ScriptChainIndexTxOut addr v datum referenceScript _validator) = + V2.Tx.TxOut addr v (toPlutusOutDatum $ Just datum) (scriptHash <$> referenceScript) + +toPlutusOutDatum :: Maybe (V2.DatumHash, Maybe V2.Datum) -> V2.Tx.OutputDatum +toPlutusOutDatum Nothing = V2.Tx.NoOutputDatum +toPlutusOutDatum (Just (d, _)) = V2.Tx.OutputDatumHash d + -- | Converts a plutus-ledger-api transaction output to the chain index -- transaction output. fromTxOut :: V1.TxOut -> Maybe ChainIndexTxOut diff --git a/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs b/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs index 828f3a96e4..43831e25db 100644 --- a/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs +++ b/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs @@ -45,9 +45,11 @@ module Ledger.Tx.CardanoAPI.Internal( , makeTransactionBody , toCardanoTxIn , toCardanoTxOut + , toCardanoTxOutDatum , toCardanoTxOutDatumHash , toCardanoTxOutDatumInline , toCardanoTxOutDatumInTx + , toCardanoTxOutNoDatum , toCardanoTxOutValue , toCardanoAddressInEra , toCardanoValue @@ -414,14 +416,14 @@ fromCardanoTxOut (C.TxOut addr value datumHash _) = toCardanoTxOut :: C.NetworkId - -> (Maybe P.DatumHash -> Either ToCardanoError (C.TxOutDatum ctx C.BabbageEra)) - -> PV1.TxOut + -> (PV2.OutputDatum -> Either ToCardanoError (C.TxOutDatum ctx C.BabbageEra)) + -> PV2.TxOut -> Either ToCardanoError (C.TxOut ctx C.BabbageEra) -toCardanoTxOut networkId fromHash (PV1.TxOut addr value datumHash) = +toCardanoTxOut networkId fromHash (PV2.TxOut addr value datum _rs) = C.TxOut <$> toCardanoAddressInEra networkId addr <*> toCardanoTxOutValue value - <*> fromHash datumHash - <*> pure C.ReferenceScriptNone + <*> fromHash datum + <*> pure C.ReferenceScriptNone -- fixme fromCardanoAddressInEra :: C.AddressInEra era -> P.Address fromCardanoAddressInEra (C.AddressInEra C.ByronAddressInAnyEra address) = fromCardanoAddress address @@ -513,22 +515,27 @@ fromCardanoTxOutDatumHash (C.TxOutDatumInline _ d) = Just $ P.DatumHash $ Plutus fromCardanoTxOutDatum :: C.TxOutDatum C.CtxTx era -> PV2.OutputDatum fromCardanoTxOutDatum C.TxOutDatumNone = PV2.NoOutputDatum fromCardanoTxOutDatum (C.TxOutDatumHash _ h) = PV2.OutputDatumHash $ PV2.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes h) -fromCardanoTxOutDatum (C.TxOutDatumInTx _ d) = PV2.OutputDatum $ PV2.Datum $ fromCardanoScriptData d +fromCardanoTxOutDatum (C.TxOutDatumInTx _ d) = PV2.OutputDatumHash $ PV2.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes (C.hashScriptData d)) fromCardanoTxOutDatum (C.TxOutDatumInline _ d) = PV2.OutputDatum $ PV2.Datum $ fromCardanoScriptData d -toCardanoTxOutDatumInTx :: Maybe PV2.Datum -> C.TxOutDatum C.CtxTx C.BabbageEra -toCardanoTxOutDatumInTx Nothing = C.TxOutDatumNone -toCardanoTxOutDatumInTx (Just d) = - C.TxOutDatumInTx C.ScriptDataInBabbageEra . C.fromPlutusData . PV2.builtinDataToData . PV2.getDatum $ d +toCardanoTxOutNoDatum :: C.TxOutDatum C.CtxTx C.BabbageEra +toCardanoTxOutNoDatum = C.TxOutDatumNone -toCardanoTxOutDatumInline :: Maybe PV2.Datum -> C.TxOutDatum C.CtxTx C.BabbageEra -toCardanoTxOutDatumInline Nothing = C.TxOutDatumNone -toCardanoTxOutDatumInline (Just d) = - C.TxOutDatumInline C.ReferenceTxInsScriptsInlineDatumsInBabbageEra . C.fromPlutusData . PV2.builtinDataToData . PV2.getDatum $ d +toCardanoTxOutDatumInTx :: PV2.Datum -> C.TxOutDatum C.CtxTx C.BabbageEra +toCardanoTxOutDatumInTx = + C.TxOutDatumInTx C.ScriptDataInBabbageEra . C.fromPlutusData . PV2.builtinDataToData . PV2.getDatum -toCardanoTxOutDatumHash :: Maybe P.DatumHash -> Either ToCardanoError (C.TxOutDatum ctx C.BabbageEra) -toCardanoTxOutDatumHash Nothing = pure C.TxOutDatumNone -toCardanoTxOutDatumHash (Just datumHash) = C.TxOutDatumHash C.ScriptDataInBabbageEra <$> toCardanoScriptDataHash datumHash +toCardanoTxOutDatumInline :: PV2.Datum -> C.TxOutDatum C.CtxTx C.BabbageEra +toCardanoTxOutDatumInline = + C.TxOutDatumInline C.ReferenceTxInsScriptsInlineDatumsInBabbageEra . C.fromPlutusData . PV2.builtinDataToData . PV2.getDatum + +toCardanoTxOutDatumHash :: P.DatumHash -> Either ToCardanoError (C.TxOutDatum ctx C.BabbageEra) +toCardanoTxOutDatumHash datumHash = C.TxOutDatumHash C.ScriptDataInBabbageEra <$> toCardanoScriptDataHash datumHash + +toCardanoTxOutDatum :: PV2.OutputDatum -> Either ToCardanoError (C.TxOutDatum C.CtxTx C.BabbageEra) +toCardanoTxOutDatum PV2.NoOutputDatum = pure toCardanoTxOutNoDatum +toCardanoTxOutDatum (PV2.OutputDatum d) = pure $ toCardanoTxOutDatumInline d +toCardanoTxOutDatum (PV2.OutputDatumHash dh) = toCardanoTxOutDatumHash dh toCardanoScriptDataHash :: P.DatumHash -> Either ToCardanoError (C.Hash C.ScriptData) toCardanoScriptDataHash (P.DatumHash bs) = tag "toCardanoTxOutDatumHash" (deserialiseFromRawBytes (C.AsHash C.AsScriptData) (PlutusTx.fromBuiltin bs)) diff --git a/plutus-ledger/src/Ledger/Tx/Internal.hs b/plutus-ledger/src/Ledger/Tx/Internal.hs index 54a9b00709..b690596544 100644 --- a/plutus-ledger/src/Ledger/Tx/Internal.hs +++ b/plutus-ledger/src/Ledger/Tx/Internal.hs @@ -40,7 +40,7 @@ import Ledger.Contexts.Orphans () import Ledger.Crypto import Ledger.DCert.Orphans () import Ledger.Slot -import Ledger.Tx.CardanoAPI.Internal (fromCardanoAddressInEra, fromCardanoTxOutDatumHash, fromCardanoTxOutValue, +import Ledger.Tx.CardanoAPI.Internal (fromCardanoAddressInEra, fromCardanoTxOutDatum, fromCardanoTxOutValue, fromCardanoValue) import Ledger.Tx.CardanoAPITemp qualified as C import Ledger.Tx.Orphans () @@ -53,6 +53,7 @@ import Plutus.V1.Ledger.Scripts import Plutus.V1.Ledger.Tx hiding (TxIn (..), TxInType (..), TxOut (..), inRef, inScripts, inType, pubKeyTxIn, pubKeyTxIns, scriptTxIn, scriptTxIns) import Plutus.V1.Ledger.Value as V +import Plutus.V2.Ledger.Api qualified as PV2 import PlutusTx.Lattice import PlutusTx.Prelude (BuiltinByteString) import PlutusTx.Prelude qualified as PlutusTx @@ -227,9 +228,10 @@ instance Pretty TxOut where hang 2 $ vsep ["-" <+> pretty (fromCardanoTxOutValue v) <+> "addressed to" , pretty (fromCardanoAddressInEra addr) - , "with" <+> case fromCardanoTxOutDatumHash d of - Nothing -> "no datum" - Just dh -> "datum hash" <+> pretty dh + , "with" <+> case fromCardanoTxOutDatum d of + PV2.NoOutputDatum -> "no datum" + PV2.OutputDatum dv -> "inline datum" <+> viaShow dv + PV2.OutputDatumHash dh -> "datum hash" <+> pretty dh , "and with" <+> case rs of C.ReferenceScript _ (C.ScriptInAnyLang _ s) -> "reference script hash" <+> viaShow (C.hashScript s) diff --git a/plutus-pab/src/Plutus/PAB/Arbitrary.hs b/plutus-pab/src/Plutus/PAB/Arbitrary.hs index 4b10c07f47..c60833ecd8 100644 --- a/plutus-pab/src/Plutus/PAB/Arbitrary.hs +++ b/plutus-pab/src/Plutus/PAB/Arbitrary.hs @@ -23,13 +23,14 @@ import Ledger.Params (testnet) import Ledger.Slot (Slot) import Ledger.Tx (Certificate, RedeemerPtr, ScriptTag, Tx, TxId, TxIn, TxInType, TxInput, TxInputType, TxOutRef, Withdrawal) -import Ledger.Tx.CardanoAPI (ToCardanoError, toCardanoTxOut, toCardanoTxOutDatumHash) +import Ledger.Tx.CardanoAPI (ToCardanoError, toCardanoTxOut, toCardanoTxOutDatum) import Plutus.Contract.Effects (ActiveEndpoint (..), PABReq (..), PABResp (..)) import Plutus.Contract.StateMachine (ThreadToken) import Plutus.Script.Utils.V1.Address (mkValidatorAddress) import Plutus.Script.Utils.V1.Typed.Scripts (ConnectionError, WrongOutTypeError) import Plutus.V1.Ledger.Api (Address (..), LedgerBytes, PubKeyHash, ValidatorHash (ValidatorHash)) import Plutus.V1.Ledger.Bytes qualified as LedgerBytes +import Plutus.V2.Ledger.Api qualified as PV2 import PlutusTx qualified import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Prelude qualified as PlutusTx @@ -114,8 +115,13 @@ instance Arbitrary TxInput where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary PV2.OutputDatum where + arbitrary = genericArbitrary + shrink = genericShrink + + instance Arbitrary TxOut where - arbitrary = fmap (fmap TxOut . toCardanoTxOut testnet toCardanoTxOutDatumHash) genericArbitrary `suchThatMap` rightToMaybe + arbitrary = fmap (fmap TxOut . toCardanoTxOut testnet toCardanoTxOutDatum) genericArbitrary `suchThatMap` rightToMaybe shrink = pure instance Arbitrary TxOutRef where diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V2/Typed/Scripts.hs b/plutus-script-utils/src/Plutus/Script/Utils/V2/Typed/Scripts.hs index 84e2a52e64..5eaf589001 100644 --- a/plutus-script-utils/src/Plutus/Script/Utils/V2/Typed/Scripts.hs +++ b/plutus-script-utils/src/Plutus/Script/Utils/V2/Typed/Scripts.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-missing-import-lists #-} module Plutus.Script.Utils.V2.Typed.Scripts @@ -7,11 +11,92 @@ module Plutus.Script.Utils.V2.Typed.Scripts , Validator , MintingPolicy , StakeValidator + , TypedScriptTxOut (..) + , TypedScriptTxOutRef (..) + , typeScriptTxOut + , typeScriptTxOutRef + , ConnectionError (..) ) where +import Control.Monad.Except (MonadError (throwError)) +import Plutus.Script.Utils.Scripts (datumHash) +import Plutus.Script.Utils.V1.Typed.Scripts.Validators (ConnectionError (..)) +import Plutus.Script.Utils.V1.Typed.Scripts.Validators qualified as V1 import Plutus.Script.Utils.V2.Typed.Scripts.MonetaryPolicies hiding (forwardToValidator) import Plutus.Script.Utils.V2.Typed.Scripts.StakeValidators hiding (forwardToValidator) import Plutus.Script.Utils.V2.Typed.Scripts.Validators -import Plutus.V2.Ledger.Api (MintingPolicy, StakeValidator, Validator) +import Plutus.V2.Ledger.Api (Credential (PubKeyCredential, ScriptCredential), Datum, FromData, MintingPolicy, + OutputDatum (OutputDatum, OutputDatumHash), StakeValidator, ToData (..), + TxOut (txOutAddress, txOutDatum), TxOutRef, Validator, addressCredential) + +-- +-- | A 'TxOut' tagged by a phantom type: and the connection type of the output. +data TypedScriptTxOut a = (FromData (DatumType a), ToData (DatumType a)) => + TypedScriptTxOut + { tyTxOutTxOut :: TxOut, + tyTxOutData :: DatumType a + } + +instance Eq (DatumType a) => Eq (TypedScriptTxOut a) where + l == r = + tyTxOutTxOut l == tyTxOutTxOut r + && tyTxOutData l == tyTxOutData r + + +-- | A 'TxOutRef' tagged by a phantom type: and the connection type of the output. +data TypedScriptTxOutRef a = TypedScriptTxOutRef + { tyTxOutRefRef :: TxOutRef, + tyTxOutRefOut :: TypedScriptTxOut a + } + +instance Eq (DatumType a) => Eq (TypedScriptTxOutRef a) where + l == r = + tyTxOutRefRef l == tyTxOutRefRef r + && tyTxOutRefOut l == tyTxOutRefOut r + + +-- | Create a 'TypedScriptTxOut' from an existing 'TxOut' by checking the types of its parts. +typeScriptTxOut :: + forall out m. + ( FromData (DatumType out), + ToData (DatumType out), + MonadError ConnectionError m + ) => + TypedValidator out -> + TxOutRef -> + TxOut -> + Datum -> + m (TypedScriptTxOut out) +typeScriptTxOut tv txOutRef txOut datum = do + case addressCredential (txOutAddress txOut) of + PubKeyCredential _ -> + throwError $ V1.WrongOutType V1.ExpectedScriptGotPubkey + ScriptCredential _vh -> + case txOutDatum txOut of + OutputDatum d | datumHash datum == datumHash d -> do + V1.checkValidatorAddress tv (txOutAddress txOut) + dsVal <- V1.checkDatum tv datum + pure $ TypedScriptTxOut @out txOut dsVal + OutputDatumHash dh | datumHash datum == dh -> do + V1.checkValidatorAddress tv (txOutAddress txOut) + dsVal <- V1.checkDatum tv datum + pure $ TypedScriptTxOut @out txOut dsVal + _ -> throwError $ V1.NoDatum txOutRef (datumHash datum) + +-- | Create a 'TypedScriptTxOut' from an existing 'TxOut' by checking the types of its parts. +typeScriptTxOutRef :: + forall out m. + ( FromData (DatumType out), + ToData (DatumType out), + MonadError ConnectionError m + ) => + TypedValidator out -> + TxOutRef -> + TxOut -> + Datum -> + m (TypedScriptTxOutRef out) +typeScriptTxOutRef tv txOutRef txOut datum = do + tyOut <- typeScriptTxOut tv txOutRef txOut datum + pure $ TypedScriptTxOutRef txOutRef tyOut diff --git a/plutus-tx-constraints/src/Ledger/Tx/Constraints/OffChain.hs b/plutus-tx-constraints/src/Ledger/Tx/Constraints/OffChain.hs index eb00325edf..c437ee8caf 100644 --- a/plutus-tx-constraints/src/Ledger/Tx/Constraints/OffChain.hs +++ b/plutus-tx-constraints/src/Ledger/Tx/Constraints/OffChain.hs @@ -57,6 +57,7 @@ import Control.Lens (Lens', Traversal', coerced, iso, makeLensesFor, use, (.=), import Control.Monad.Except (Except, MonadError, mapExcept, runExcept, throwError, withExcept) import Control.Monad.Reader (ReaderT (runReaderT), mapReaderT) import Control.Monad.State (MonadState, StateT, execStateT, gets, mapStateT) +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) import Data.Aeson (FromJSON, ToJSON) import Data.Bifunctor (first) import Data.Either (partitionEithers) @@ -67,7 +68,7 @@ import Ledger.Address (pubKeyHashAddress, scriptValidatorHashAddress) import Ledger.Constraints qualified as P import Ledger.Constraints.OffChain (UnbalancedTx (..), cpsUnbalancedTx, unBalancedTxTx, unbalancedTx) import Ledger.Constraints.OffChain qualified as P -import Ledger.Constraints.TxConstraints (ScriptOutputConstraint, TxConstraint, +import Ledger.Constraints.TxConstraints (OutDatum (Hashed, Inline), ScriptOutputConstraint, TxConstraint, TxConstraints (TxConstraints, txConstraints, txOwnOutputs)) import Ledger.Interval () import Ledger.Orphans () @@ -247,7 +248,7 @@ processConstraint = \case P.MustSpendScriptOutput txo redeemer -> do txout <- lookupTxOutRef txo - mscriptTXO <- mapReaderT (mapStateT (mapExcept (first LedgerMkTxError))) $ P.resolveScriptTxOut txout + mscriptTXO <- mapReaderT (mapStateT (mapExcept (first LedgerMkTxError))) $ runMaybeT $ P.resolveScriptTxOut txout case mscriptTXO of Just ((_, Tx.Versioned validator lang), (_, datum), _) -> do txIn <- throwLeft ToCardanoError $ C.toCardanoTxIn txo @@ -282,10 +283,14 @@ processConstraint = \case P.MustPayToPubKeyAddress pk mskh md refScriptHashM vl -> do networkId <- use (P.paramsL . networkIdL) refScript <- lookupScriptAsReferenceScript refScriptHashM + let txInDatum = case md of + Nothing -> C.toCardanoTxOutNoDatum + Just (Hashed d) -> C.toCardanoTxOutDatumInTx d + Just (Inline d) -> C.toCardanoTxOutDatumInline d out <- throwLeft ToCardanoError $ C.TxOut <$> C.toCardanoAddressInEra networkId (pubKeyHashAddress pk mskh) <*> C.toCardanoTxOutValue vl - <*> pure (maybe C.TxOutDatumNone (C.TxOutDatumInTx C.ScriptDataInBabbageEra . C.toCardanoScriptData . getDatum) md) + <*> pure txInDatum <*> pure refScript unbalancedTx . tx . txOuts <>= [ out ] @@ -293,10 +298,13 @@ processConstraint = \case P.MustPayToOtherScript vlh svhM dv refScriptHashM vl -> do networkId <- use (P.paramsL . networkIdL) refScript <- lookupScriptAsReferenceScript refScriptHashM + let txInDatum = case dv of + Hashed d -> C.toCardanoTxOutDatumInTx d + Inline d -> C.toCardanoTxOutDatumInline d out <- throwLeft ToCardanoError $ C.TxOut <$> C.toCardanoAddressInEra networkId (scriptValidatorHashAddress vlh svhM) <*> C.toCardanoTxOutValue vl - <*> pure (C.TxOutDatumInTx C.ScriptDataInBabbageEra (C.toCardanoScriptData (getDatum dv))) + <*> pure txInDatum <*> pure refScript unbalancedTx . tx . txOuts <>= [ out ] diff --git a/plutus-use-cases/test/Spec/future.pir b/plutus-use-cases/test/Spec/future.pir index 3d6b78ec30..1f789f60a9 100644 --- a/plutus-use-cases/test/Spec/future.pir +++ b/plutus-use-cases/test/Spec/future.pir @@ -120,6 +120,15 @@ (vardecl Just (fun a [ Maybe a ])) (vardecl Nothing [ Maybe a ]) ) ) + (datatypebind + (datatype + (tyvardecl OutDatum (type)) + + OutDatum_match + (vardecl Hashed (fun (con data) OutDatum)) + (vardecl Inline (fun (con data) OutDatum)) + ) + ) (typebind (tyvardecl TxOutRef (type)) (all a (type) (fun a a))) (let (rec) @@ -151,7 +160,7 @@ (fun [ Maybe (con bytestring) ] (fun - (con data) + OutDatum (fun [ Maybe (con bytestring) ] (fun @@ -190,7 +199,7 @@ (fun [ Maybe (con bytestring) ] (fun - [ Maybe (con data) ] + [ Maybe OutDatum ] (fun [ Maybe (con bytestring) ] (fun @@ -8426,7 +8435,10 @@ ) } ] - unitDatum + [ + Hashed + unitDatum + ] ] { Nothing @@ -8483,7 +8495,10 @@ ) } ] - unitDatum + [ + Hashed + unitDatum + ] ] { Nothing @@ -11177,7 +11192,10 @@ ) } ] - unitDatum + [ + Hashed + unitDatum + ] ] { Nothing @@ -11328,7 +11346,10 @@ ) } ] - unitDatum + [ + Hashed + unitDatum + ] ] { Nothing diff --git a/plutus-use-cases/test/Spec/renderGuess.txt b/plutus-use-cases/test/Spec/renderGuess.txt index 0ea35c1751..e1487a339b 100644 --- a/plutus-use-cases/test/Spec/renderGuess.txt +++ b/plutus-use-cases/test/Spec/renderGuess.txt @@ -551,11 +551,11 @@ Balances Carried Forward: Ada: Lovelace: 100000000 ==== Slot #1, Tx #0 ==== -TxId: 5568796b424a4afb1246eaa957edf9f4ae89ac2f35b11ee74ea5d6f2f58a9563 +TxId: 582535db1b8cfcae53505f6bfcf43400ad131aa533df613f496637db55bef42c Fee: Ada: Lovelace: 184333 Mint: - Signatures PubKey: 8d9de88fbf445b7f6c3875a14daba94caee2ffcb... - Signature: 5840aae5611913f8c960b9a98d394d80226068af... + Signature: 58400c87e799e69f3f780333c07d3de54082491d... Inputs: ---- Input 0 ---- Destination: PaymentPubKeyHash: a2c20c77887ace1cd986193e4e75babd8993cfd5... (Wallet 872cb83b5ee40eb23bfdab1772660c822a48d491) @@ -578,7 +578,7 @@ Inputs: Outputs: ---- Output 0 ---- - Destination: Script: a1d01b1cce628897d6a8764844dfa44ca74fb82696825afe1526986d + Destination: Script: f07e706c35a16c0f3843a07c5741334c90daaffad6a80f54ddc13d50 Value: Ada: Lovelace: 8000000 @@ -629,6 +629,6 @@ Balances Carried Forward: Value: Ada: Lovelace: 100000000 - Script: a1d01b1cce628897d6a8764844dfa44ca74fb82696825afe1526986d + Script: f07e706c35a16c0f3843a07c5741334c90daaffad6a80f54ddc13d50 Value: Ada: Lovelace: 8000000 \ No newline at end of file