diff --git a/plutus-contract/src/Plutus/Contract/StateMachine.hs b/plutus-contract/src/Plutus/Contract/StateMachine.hs index 69069565c9..a0f51a203b 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 03a73d4344..51c2c355ef 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) @@ -324,7 +324,7 @@ handleBalance utx' = do requiredSigners = Set.toList (U.unBalancedTxRequiredSignatories utx) eitherTx = U.unBalancedTxTx utx plUtxo = traverse (Tx.toTxOut pNetworkId) utxo - mappedUtxo <- either (throwError . WAPI.ToCardanoError) pure plUtxo + mappedUtxo <- either (throwError . WAPI.ToCardanoError) (pure . fmap TxOut) plUtxo cUtxoIndex <- handleError eitherTx $ fromPlutusIndex $ UtxoIndex $ U.unBalancedTxUtxoIndex utx <> mappedUtxo case eitherTx of Right _ -> do @@ -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 c6c3159907..1de3cd4f0c 100644 --- a/plutus-contract/test/Spec/Emulator.hs +++ b/plutus-contract/test/Spec/Emulator.hs @@ -36,14 +36,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 @@ -218,7 +219,11 @@ 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 (unversioned failValidator) (txOutValue o) unitDatum + toCardanoTxOut pNetworkId toCardanoTxOutDatum $ PV2.TxOut + (mkValidatorAddress $ unversioned 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 f4fa3c24f6..04dff0e90a 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 @@ -31,7 +33,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/OnChain/V1.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs index 75b28a9d81..26826209f1 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 e7a08d8952..f790934ded 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) @@ -117,16 +118,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 @@ -138,7 +140,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 338a20a20c..db330b88b3 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/src/Ledger/Tx.hs b/plutus-ledger/src/Ledger/Tx.hs index a0dcbec255..d49ad49a91 100644 --- a/plutus-ledger/src/Ledger/Tx.hs +++ b/plutus-ledger/src/Ledger/Tx.hs @@ -88,9 +88,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 Ledger.Tx.Internal as Export @@ -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. @@ -161,11 +163,15 @@ toTxOut networkId (ScriptChainIndexTxOut addr v (dh, _) referenceScript _validat -- 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. -toTxInfoTxOut :: ChainIndexTxOut -> V1.Tx.TxOut -toTxInfoTxOut (PublicKeyChainIndexTxOut addr v datum _referenceScript) = - V1.Tx.TxOut addr v (fst <$> datum) -toTxInfoTxOut (ScriptChainIndexTxOut addr v (dh, _) _referenceScript _validator) = - V1.Tx.TxOut addr v (Just dh) +toTxInfoTxOut :: ChainIndexTxOut -> V2.Tx.TxOut +toTxInfoTxOut (PublicKeyChainIndexTxOut addr v datum referenceScript) = + V2.Tx.TxOut addr v (toPlutusOutDatum datum) (scriptHash <$> referenceScript) +toTxInfoTxOut (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 instance Pretty ChainIndexTxOut where pretty PublicKeyChainIndexTxOut {_ciTxOutAddress, _ciTxOutValue} = diff --git a/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs b/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs index a16a9dbd53..81c6511e3b 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 @@ -415,14 +417,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 @@ -514,22 +516,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 61343e5c91..47a2dfc93c 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 @@ -230,9 +231,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-use-cases/test/Spec/future.pir b/plutus-use-cases/test/Spec/future.pir index 36e6653f4d..f5add43dc0 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 @@ -8429,7 +8438,10 @@ ) } ] - unitDatum + [ + Hashed + unitDatum + ] ] { Nothing @@ -8486,7 +8498,10 @@ ) } ] - unitDatum + [ + Hashed + unitDatum + ] ] { Nothing @@ -11180,7 +11195,10 @@ ) } ] - unitDatum + [ + Hashed + unitDatum + ] ] { Nothing @@ -11331,7 +11349,10 @@ ) } ] - unitDatum + [ + Hashed + unitDatum + ] ] { Nothing diff --git a/plutus-use-cases/test/Spec/renderGuess.txt b/plutus-use-cases/test/Spec/renderGuess.txt index fadcfaf905..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: 4d991d5dffc66e9a69e6a32219f488d94d1d0f4edee4364dda65ef74663f573f +TxId: 582535db1b8cfcae53505f6bfcf43400ad131aa533df613f496637db55bef42c Fee: Ada: Lovelace: 184333 Mint: - Signatures PubKey: 8d9de88fbf445b7f6c3875a14daba94caee2ffcb... - Signature: 58407a352730ae1a1f70b79bdf23dbb87c366950... + Signature: 58400c87e799e69f3f780333c07d3de54082491d... Inputs: ---- Input 0 ---- Destination: PaymentPubKeyHash: a2c20c77887ace1cd986193e4e75babd8993cfd5... (Wallet 872cb83b5ee40eb23bfdab1772660c822a48d491) @@ -578,7 +578,7 @@ Inputs: Outputs: ---- Output 0 ---- - Destination: Script: 2bfc754ffd6c45b9a5fdcf0b9d1299939995067fe8198ab2f7340435 + Destination: Script: f07e706c35a16c0f3843a07c5741334c90daaffad6a80f54ddc13d50 Value: Ada: Lovelace: 8000000 @@ -629,6 +629,6 @@ Balances Carried Forward: Value: Ada: Lovelace: 100000000 - Script: 2bfc754ffd6c45b9a5fdcf0b9d1299939995067fe8198ab2f7340435 + Script: f07e706c35a16c0f3843a07c5741334c90daaffad6a80f54ddc13d50 Value: Ada: Lovelace: 8000000 \ No newline at end of file