PLT-448: must spend script output with reference

playground-common/src/Playground/Contract.hs

@@ -45,6 +45,7 @@ module Playground.Contract
     , ownFirstPaymentPubKeyHash
     , ownPaymentPubKeyHashes
     , ownAddresses
+    , ownAddress
     , awaitSlot
     , modifiesUtxoSet
     , utxosAt
@@ -69,7 +70,7 @@ import Playground.Interpreter.Util
 import Playground.Schema (endpointsToSchemas)
 import Playground.TH (ensureKnownCurrencies, mkFunction, mkFunctions, mkKnownCurrencies, mkSchemaDefinitions)
 import Playground.Types (Expression, FunctionSchema, KnownCurrency (KnownCurrency), adaCurrency)
-import Plutus.Contract (AsContractError, Contract, Endpoint, awaitSlot, endpoint, ownAddresses,
+import Plutus.Contract (AsContractError, Contract, Endpoint, awaitSlot, endpoint, ownAddress, ownAddresses,
                         ownFirstPaymentPubKeyHash, ownPaymentPubKeyHash, ownPaymentPubKeyHashes, submitTx, type (.\/),
                         utxosAt, watchAddressUntilSlot)
 import Plutus.Contract.Trace (TraceError (..))

plutus-chain-index-core/src/Plutus/ChainIndex/Tx.hs

@@ -48,7 +48,7 @@ import Ledger (OnChainTx (..), ScriptTag (Cert, Mint, Reward), SomeCardanoApiTx
                txMintingRedeemers, txRewardingRedeemers)
 import Ledger.Address (Address)
 import Ledger.Scripts (Redeemer, RedeemerHash)
-import Ledger.Tx (TxInputType (TxConsumeScriptAddress), fillTxInputWitnesses)
+import Ledger.Tx (TxInputType (TxScriptAddress), fillTxInputWitnesses)
 import Plutus.ChainIndex.Types
 import Plutus.Contract.CardanoAPI (fromCardanoTx, fromCardanoTxOut, setValidity)
 import Plutus.Script.Utils.Scripts (redeemerHash)
@@ -138,5 +138,5 @@ calculateRedeemerPointers tx = spends <> rewards <> mints <> certs
         spends = Map.fromList $ mapMaybe (uncurry getRd) $ zip [0..] $ fmap txInputType $ sort $ txInputs tx
 
         getRd n = \case
-            TxConsumeScriptAddress rd _ _ -> Just (RedeemerPtr Spend n, rd)
-            _                             -> Nothing
+            TxScriptAddress rd _ _ -> Just (RedeemerPtr Spend n, rd)
+            _                      -> Nothing

plutus-contract/src/Plutus/Contract.hs

@@ -69,6 +69,7 @@ module Plutus.Contract(
     , Request.ownPaymentPubKeyHashes
     , Request.ownFirstPaymentPubKeyHash
     , Request.ownAddresses
+    , Request.ownAddress
     , Request.ownUtxos
     -- * Contract instance Id
     , Wallet.Types.ContractInstanceId

plutus-contract/src/Plutus/Contract/Request.hs

@@ -83,6 +83,7 @@ module Plutus.Contract.Request(
     , ownPaymentPubKeyHashes
     , ownFirstPaymentPubKeyHash
     , ownAddresses
+    , ownAddress
     , ownUtxos
     -- ** Submitting transactions
     , adjustUnbalancedTx
@@ -823,6 +824,10 @@ ownPaymentPubKeyHash = ownFirstPaymentPubKeyHash
 ownAddresses :: forall w s e. (AsContractError e) => Contract w s e (NonEmpty Address)
 ownAddresses = pabReq OwnAddressesReq E._OwnAddressesResp
 
+-- | Get the first address of the wallet that runs this contract.
+ownAddress :: forall w s e. (AsContractError e) => Contract w s e Address
+ownAddress = NonEmpty.head <$> ownAddresses
+
 ownPaymentPubKeyHashes :: forall w s e. (AsContractError e) => Contract w s e [PaymentPubKeyHash]
 ownPaymentPubKeyHashes = do
     addrs <- ownAddresses

plutus-contract/src/Plutus/Contract/StateMachine.hs

@@ -140,7 +140,7 @@ getStates
     -> [OnChainState s i]
 getStates (SM.StateMachineInstance _ si) refMap =
     flip mapMaybe (Map.toList refMap) $ \(txOutRef, ciTxOut) -> do
-      let txOut = Tx.toTxOut ciTxOut
+      let txOut = Tx.toTxInfoTxOut ciTxOut
       datum <- ciTxOut ^? Tx.ciTxOutScriptDatum . _2 . _Just
       ocsTxOutRef <- either (const Nothing) Just $ Typed.typeScriptTxOutRef si txOutRef txOut datum
       pure OnChainState{ocsTxOutRef}

plutus-contract/src/Wallet/Emulator/Wallet.hs

@@ -323,8 +323,8 @@ handleBalance utx' = do
     let utx = finalize pSlotConfig utx'
         requiredSigners = Set.toList (U.unBalancedTxRequiredSignatories utx)
         eitherTx = U.unBalancedTxTx utx
-        plUtxo = traverse (toCardanoTxOut pNetworkId toCardanoTxOutDatum . Tx.toTxOut) utxo
-    mappedUtxo <- either (throwError . WAPI.ToCardanoError) (pure . fmap TxOut) plUtxo
+        plUtxo = traverse (Tx.toTxOut pNetworkId) utxo
+    mappedUtxo <- either (throwError . WAPI.ToCardanoError) pure plUtxo
     cUtxoIndex <- handleError eitherTx $ fromPlutusIndex $ UtxoIndex $ U.unBalancedTxUtxoIndex utx <> mappedUtxo
     case eitherTx of
         Right _ -> do

plutus-contract/src/Wallet/Rollup/Render.hs

@@ -38,8 +38,8 @@ import Ledger (Address, Blockchain, PaymentPubKey, PaymentPubKeyHash, Tx (Tx), T
 import Ledger.Ada (Ada (Lovelace))
 import Ledger.Ada qualified as Ada
 import Ledger.Crypto (PubKey, PubKeyHash, Signature)
-import Ledger.Scripts (Datum (getDatum), Script, Validator, ValidatorHash (ValidatorHash), unValidatorScript,
-                       unversioned)
+import Ledger.Scripts (Datum (getDatum), Language, Script, Validator, ValidatorHash (ValidatorHash),
+                       Versioned (Versioned), unValidatorScript)
 import Ledger.Value (CurrencySymbol (CurrencySymbol), TokenName (TokenName))
 import Ledger.Value qualified as Value
 import PlutusTx qualified
@@ -82,6 +82,10 @@ newtype RenderPretty a =
 instance Pretty a => Render (RenderPretty a) where
     render (RenderPretty a) = pure $ pretty a
 
+instance (Render a, Render b) => Render (Either a b) where
+    render (Left a)  = render a
+    render (Right b) = render b
+
 instance Render [[AnnotatedTx]] where
     render blockchain =
         vsep . intersperse mempty . fold <$>
@@ -284,9 +288,18 @@ instance Render TxIn where
     render (TxIn txInRef Nothing) = render txInRef
 
 instance Render TxInType where
-    render (ConsumeScriptAddress validator _ _) = render (unversioned validator)
-    render ConsumePublicKeyAddress              = pure mempty
-    render ConsumeSimpleScriptAddress           = pure mempty
+    render (ScriptAddress validator _ _) = render validator
+    render ConsumePublicKeyAddress       = pure mempty
+    render ConsumeSimpleScriptAddress    = pure mempty
+
+instance Render a => Render (Versioned a) where
+    render (Versioned a lang) = do
+        rlang <- render lang
+        ra <- render a
+        pure $ parens rlang <+> ra
+
+instance Render Language where
+    render = pure . viaShow
 
 instance Render TxOutRef where
     render TxOutRef {txOutRefId, txOutRefIdx} =

plutus-contract/test/Spec/Contract/TxConstraints.hs

@@ -24,20 +24,21 @@ import Control.Monad (void)
 import Control.Monad.Freer.Extras.Log (LogLevel (Debug))
 import Data.Default (def)
 import Data.Map qualified as Map
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, isJust)
 import Data.Void (Void)
 import Test.Tasty (TestTree, testGroup)
 
 import Ledger.Ada qualified as Ada
 import Ledger.Constraints qualified as TC
 import Ledger.Constraints.OnChain.V1 qualified as TCV1
 import Ledger.Constraints.OnChain.V2 qualified as TCV2
-import Ledger.Scripts (unitRedeemer)
+import Ledger.Scripts (ScriptHash (ScriptHash), ValidatorHash (ValidatorHash), unitRedeemer)
+import Ledger.Tx qualified as Tx
 import Ledger.Tx.Constraints qualified as Tx.Constraints
 import Plutus.Contract as Con
 import Plutus.Contract.Test (TracePredicate, assertValidatedTransactionCount, assertValidatedTransactionCountOfTotal,
-                             checkPredicate, checkPredicateOptions, defaultCheckOptions, minLogLevel, valueAtAddress,
-                             w1, walletFundsChange, (.&&.))
+                             changeInitialWalletValue, checkPredicate, checkPredicateOptions, defaultCheckOptions,
+                             minLogLevel, valueAtAddress, w1, walletFundsChange, (.&&.))
 import Plutus.Script.Utils.Typed (Any)
 import Plutus.Script.Utils.V1.Address qualified as PV1
 import Plutus.Script.Utils.V1.Typed.Scripts qualified as PV1
@@ -82,6 +83,19 @@ tests = testGroup "contract tx constraints"
             void $ activateContract w1 mustReferenceOutputV2ConTest tag
             void $ Trace.waitNSlots 3
 
+    , checkPredicateOptions
+        (changeInitialWalletValue w1 (const $ Ada.adaValueOf 1000) defaultCheckOptions)
+        "mustSpendScriptOutputWithReference can be used on-chain to unlock funds in a PlutusV2 script"
+        -- TODO: 2nd tx fails because the emulator validation doesn't understand reference scripts,
+        -- Reenable following lines when the emulator validation has been removed
+        -- (walletFundsChange w1 (Ada.adaValueOf 0)
+        -- .&&. valueAtAddress mustReferenceOutputV2ValidatorAddress (== Ada.adaValueOf 0)
+        -- .&&. assertValidatedTransactionCount 2
+        (assertValidatedTransactionCountOfTotal 1 2
+        ) $ do
+            void $ activateContract w1 mustSpendScriptOutputWithReferenceV2ConTest tag
+            void $ Trace.waitNSlots 3
+
     -- Testing package plutus-tx-constraints
 
     , checkPredicate "Tx.Constraints.mustReferenceOutput fails when trying to unlock funds in a PlutusV1 script"
@@ -99,6 +113,16 @@ tests = testGroup "contract tx constraints"
         ) $ do
             void $ activateContract w1 mustReferenceOutputTxV2ConTest tag
             void $ Trace.waitNSlots 3
+
+    , checkPredicateOptions
+        (changeInitialWalletValue w1 (const $ Ada.adaValueOf 1000) defaultCheckOptions)
+        "Tx.Constraints.mustSpendScriptOutputWithReference can be used on-chain to unlock funds in a PlutusV2 script"
+        (walletFundsChange w1 (Ada.adaValueOf 0)
+        .&&. valueAtAddress mustReferenceOutputV2ValidatorAddress (== Ada.adaValueOf 0)
+        .&&. assertValidatedTransactionCount 2
+        ) $ do
+            void $ activateContract w1 mustSpendScriptOutputWithReferenceTxV2ConTest tag
+            void $ Trace.waitNSlots 3
     ]
 
 {-
@@ -242,3 +266,64 @@ mustReferenceOutputTxV2ConTest = do
 get3 :: [a] -> (a, a, a)
 get3 (a:b:c:_) = (a, b, c)
 get3 _         = error "Spec.Contract.TxConstraints.get3: not enough inputs"
+
+mustSpendScriptOutputWithReferenceV2ConTest :: Contract () EmptySchema ContractError ()
+mustSpendScriptOutputWithReferenceV2ConTest = do
+
+    utxos <- ownUtxos
+    myAddr <- Con.ownAddress
+    let ((utxoRef, utxo), (utxoRefForBalance1, _), (utxoRefForBalance2, _)) = get3 $ Map.toList utxos
+        ValidatorHash vh = fromJust $ Addr.toValidatorHash mustReferenceOutputV2ValidatorAddress
+        lookups = TC.unspentOutputs utxos
+               <> TC.plutusV2OtherScript mustReferenceOutputV2Validator
+        tx = TC.mustPayToOtherScript (ValidatorHash vh) (Datum $ PlutusTx.toBuiltinData utxoRef) (Ada.adaValueOf 5)
+          <> TC.mustSpendPubKeyOutput utxoRefForBalance1
+          <> TC.mustPayToAddressWithReferenceScript
+                myAddr
+                (ScriptHash vh)
+                Nothing (Ada.adaValueOf 25)
+    mkTxConstraints @Void lookups tx >>= submitTxConfirmed
+
+    -- Trying to unlock the Ada in the script address
+    scriptUtxos <- utxosAt mustReferenceOutputV2ValidatorAddress
+    utxos' <- ownUtxos
+    let
+        scriptUtxo = fst . head . Map.toList $ scriptUtxos
+        refScriptUtxo = fst . head . filter (isJust . Tx._ciTxOutReferenceScript . snd) . Map.toList $ utxos'
+        lookups = TC.unspentOutputs (Map.singleton utxoRef utxo <> scriptUtxos <> utxos')
+        tx = TC.mustReferenceOutput utxoRef
+          <> TC.mustSpendScriptOutputWithReference scriptUtxo unitRedeemer refScriptUtxo
+          <> TC.mustSpendPubKeyOutput utxoRefForBalance2
+    mkTxConstraints @Any lookups tx >>= submitTxConfirmed
+
+mustSpendScriptOutputWithReferenceTxV2ConTest :: Contract () EmptySchema ContractError ()
+mustSpendScriptOutputWithReferenceTxV2ConTest = do
+    let mkTx lookups constraints = either (error . show) id $ Tx.Constraints.mkTx @Any def lookups constraints
+
+    utxos <- ownUtxos
+    myAddr <- Con.ownAddress
+    let ((utxoRef, utxo), (utxoRefForBalance1, _), (utxoRefForBalance2, _)) = get3 $ Map.toList utxos
+        ValidatorHash vh = fromJust $ Addr.toValidatorHash mustReferenceOutputV2ValidatorAddress
+        lookups = Tx.Constraints.unspentOutputs utxos
+               <> Tx.Constraints.plutusV2OtherScript mustReferenceOutputV2Validator
+        tx = Tx.Constraints.mustPayToOtherScript (ValidatorHash vh) (Datum $ PlutusTx.toBuiltinData utxoRef) (Ada.adaValueOf 5)
+          <> Tx.Constraints.mustSpendPubKeyOutput utxoRefForBalance1
+          <> Tx.Constraints.mustUseOutputAsCollateral utxoRefForBalance1
+          <> Tx.Constraints.mustPayToAddressWithReferenceScript
+                myAddr
+                (ScriptHash vh)
+                Nothing (Ada.adaValueOf 25)
+    submitTxConfirmed $ mkTx lookups tx
+
+    -- Trying to unlock the Ada in the script address
+    scriptUtxos <- utxosAt mustReferenceOutputV2ValidatorAddress
+    utxos' <- ownUtxos
+    let
+        scriptUtxo = fst . head . Map.toList $ scriptUtxos
+        refScriptUtxo = fst . head . filter (isJust . Tx._ciTxOutReferenceScript . snd) . Map.toList $ utxos'
+        lookups = Tx.Constraints.unspentOutputs (Map.singleton utxoRef utxo <> scriptUtxos <> utxos')
+        tx = Tx.Constraints.mustReferenceOutput utxoRef
+          <> Tx.Constraints.mustSpendScriptOutputWithReference scriptUtxo unitRedeemer refScriptUtxo
+          <> Tx.Constraints.mustSpendPubKeyOutput utxoRefForBalance2
+          <> Tx.Constraints.mustUseOutputAsCollateral utxoRefForBalance2
+    submitTxConfirmed $ mkTx lookups tx

plutus-contract/test/Spec/Emulator.hs

@@ -27,9 +27,10 @@ import Hedgehog qualified
 import Hedgehog.Gen qualified as Gen
 import Hedgehog.Range qualified as Range
 import Ledger (CardanoTx (..), Language (PlutusV1), OnChainTx (Valid), PaymentPubKeyHash, ScriptError (EvaluationError),
-               Tx (txMint), TxInType (ConsumeScriptAddress), TxOut (TxOut), ValidationError (ScriptFailure), Validator,
-               Value, Versioned (Versioned), cardanoTxMap, getCardanoTxFee, getCardanoTxOutRefs, getCardanoTxOutputs,
-               mkValidatorScript, onCardanoTx, outputs, txOutValue, unitDatum, unitRedeemer, unspentOutputs)
+               Tx (txMint), TxInType (ScriptAddress), TxOut (TxOut), ValidationError (ScriptFailure), Validator, Value,
+               Versioned (Versioned, unversioned), cardanoTxMap, getCardanoTxFee, getCardanoTxOutRefs,
+               getCardanoTxOutputs, mkValidatorScript, onCardanoTx, outputs, txOutValue, unitDatum, unitRedeemer,
+               unspentOutputs)
 import Ledger.Ada qualified as Ada
 import Ledger.Generators (Mockchain (Mockchain), TxInputWitnessed (TxInputWitnessed))
 import Ledger.Generators qualified as Gen
@@ -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 toCardanoTxOutDatum $ PV2.TxOut (mkValidatorAddress failValidator) (txOutValue o) (PV2.OutputDatum unitDatum) Nothing
+            toCardanoTxOut pNetworkId toCardanoTxOutDatum $ PV2.TxOut
+                (mkValidatorAddress $ unversioned failValidator)
+                (txOutValue o)
+                (PV2.OutputDatum unitDatum)
+                Nothing
     outs <- traverse setOutputs $ emulatorTx ^. outputs
     let scriptTxn = EmulatorTx $
             emulatorTx
@@ -228,7 +233,7 @@ invalidScript = property $ do
     let totalVal = txOutValue (fst outToSpend)
 
     -- try and spend the script output
-    invalidTxn <- forAll $ Gen.genValidTransactionSpending [TxInputWitnessed (snd outToSpend) (ConsumeScriptAddress (Versioned failValidator PlutusV1) unitRedeemer unitDatum)] totalVal
+    invalidTxn <- forAll $ Gen.genValidTransactionSpending [TxInputWitnessed (snd outToSpend) (ScriptAddress (Left failValidator) unitRedeemer unitDatum)] totalVal
     Hedgehog.annotateShow invalidTxn
 
     let options = defaultCheckOptions & emulatorConfig . Trace.initialChainState .~ Right m
@@ -254,8 +259,8 @@ invalidScript = property $ do
 
     checkPredicateInner options (assertChainEvents pred .&&. walletPaidFees wallet1 (getCardanoTxFee scriptTxn)) trace Hedgehog.annotate Hedgehog.assert (const $ pure ())
     where
-        failValidator :: Validator
-        failValidator = mkValidatorScript $$(PlutusTx.compile [|| mkUntypedValidator validator ||])
+        failValidator :: Versioned Validator
+        failValidator = Versioned (mkValidatorScript $$(PlutusTx.compile [|| mkUntypedValidator validator ||])) PlutusV1
         validator :: () -> () -> ScriptContext -> Bool
         validator _ _ _ = PlutusTx.traceError "I always fail everything"
 

plutus-ledger-constraints/src/Ledger/Constraints.hs

@@ -24,6 +24,7 @@ module Ledger.Constraints(
     , TC.mustSpendPubKeyOutput
     , TC.mustSpendOutputFromTheScript
     , TC.mustSpendScriptOutput
+    , TC.mustSpendScriptOutputWithReference
     , TC.mustSpendScriptOutputWithMatchingDatumAndValue
     , TC.mustUseOutputAsCollateral
     , TC.mustReferenceOutput