|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE LambdaCase #-} |
| 3 | +{-# LANGUAGE NumericUnderscores #-} |
| 4 | +{-# LANGUAGE OverloadedStrings #-} |
| 5 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 6 | +{-# LANGUAGE TemplateHaskell #-} |
| 7 | +{-# LANGUAGE TypeApplications #-} |
| 8 | +{-# LANGUAGE TypeFamilies #-} |
| 9 | +module Spec.TxConstraints.MustSpendPubKeyOutput(tests) where |
| 10 | + |
| 11 | +import Control.Monad (void) |
| 12 | +import Test.Tasty (TestTree, testGroup) |
| 13 | + |
| 14 | +import Control.Lens ((^.)) |
| 15 | +import Data.Map qualified as M (elems) |
| 16 | +import Data.Set (Set) |
| 17 | +import Data.Set qualified as S (elemAt, elems) |
| 18 | +import Ledger qualified |
| 19 | +import Ledger.Ada qualified as Ada |
| 20 | +import Ledger.CardanoWallet (paymentPrivateKey) |
| 21 | +import Ledger.Constraints.OffChain qualified as Constraints (MkTxError (TxOutRefNotFound), ownPaymentPubKeyHash, |
| 22 | + plutusV1TypedValidatorLookups, unspentOutputs) |
| 23 | +import Ledger.Constraints.OnChain.V1 qualified as Constraints (checkScriptContext) |
| 24 | +import Ledger.Constraints.TxConstraints qualified as Constraints (collectFromTheScript, mustIncludeDatum, |
| 25 | + mustPayToTheScript, mustSpendPubKeyOutput) |
| 26 | +import Ledger.Tx qualified as Tx |
| 27 | +import Ledger.Typed.Scripts qualified as Scripts |
| 28 | +import Plutus.ChainIndex.Emulator (addressMap, diskState, unCredentialMap) |
| 29 | +import Plutus.Contract as Con |
| 30 | +import Plutus.Contract.Test (assertContractError, assertFailedTransaction, assertValidatedTransactionCount, |
| 31 | + checkPredicate, mockWalletPaymentPubKeyHash, w1, w2, walletFundsChange, (.&&.)) |
| 32 | +import Plutus.Trace qualified as Trace |
| 33 | +import Plutus.V1.Ledger.Api (Datum (Datum), ScriptContext, TxOutRef (TxOutRef, txOutRefIdx), Validator, ValidatorHash) |
| 34 | +import Plutus.V1.Ledger.Scripts (ScriptError (EvaluationError)) |
| 35 | +import PlutusTx qualified |
| 36 | +import PlutusTx.Prelude qualified as P |
| 37 | +import Wallet.Emulator.Wallet (WalletState, chainIndexEmulatorState, signPrivateKeys, walletToMockWallet') |
| 38 | + |
| 39 | +tests :: TestTree |
| 40 | +tests = |
| 41 | + testGroup "MustSpendPubKeyOutput" |
| 42 | + [ mustSpendSingleUtxoFromOwnWallet |
| 43 | + , mustSpendRemainingInitialUtxosFromOwnWallet |
| 44 | + , mustSpendSingleUtxoFromOtherWallet |
| 45 | + , mustSpendAllUtxosFromOtherWallet |
| 46 | + , contractErrorWhenAttemptingToSpendNonExistentOutput |
| 47 | + , phase2FailureWhenTxoIsNotSpent |
| 48 | + ] |
| 49 | + |
| 50 | +nonExistentTxoRef :: TxOutRef |
| 51 | +nonExistentTxoRef = TxOutRef "abcd" 123 |
| 52 | + |
| 53 | +w1PaymentPubKeyHash :: Ledger.PaymentPubKeyHash |
| 54 | +w1PaymentPubKeyHash = mockWalletPaymentPubKeyHash w1 |
| 55 | + |
| 56 | +w2PaymentPubKeyHash :: Ledger.PaymentPubKeyHash |
| 57 | +w2PaymentPubKeyHash = mockWalletPaymentPubKeyHash w2 |
| 58 | + |
| 59 | +initialLovelacePerWallet :: Integer |
| 60 | +initialLovelacePerWallet = 100_000_000 |
| 61 | + |
| 62 | +lovelacePerInitialUtxo :: Integer |
| 63 | +lovelacePerInitialUtxo = initialLovelacePerWallet `div` 10 |
| 64 | + |
| 65 | +-- wallet starts with 10 utxos of 10 ada by default, this amount paid to script spends 1 utxo. |
| 66 | +baseLovelaceLockedByScript :: Integer |
| 67 | +baseLovelaceLockedByScript = lovelacePerInitialUtxo `div` 2 |
| 68 | + |
| 69 | +mustSpendPubKeyOutputContract :: [TxOutRef] -> [TxOutRef] -> Ledger.PaymentPubKeyHash -> Contract () Empty ContractError () |
| 70 | +mustSpendPubKeyOutputContract offChainTxOutRefs onChainTxOutRefs pkh = do |
| 71 | + let lookups1 = Constraints.plutusV1TypedValidatorLookups typedValidator |
| 72 | + tx1 = Constraints.mustPayToTheScript onChainTxOutRefs $ Ada.lovelaceValueOf baseLovelaceLockedByScript |
| 73 | + ledgerTx1 <- submitTxConstraintsWith lookups1 tx1 |
| 74 | + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 |
| 75 | + |
| 76 | + pubKeyUtxos <- utxosAt $ Ledger.pubKeyHashAddress pkh Nothing |
| 77 | + logInfo @String $ "pubKeyUtxos:: " ++ show pubKeyUtxos -- remove |
| 78 | + scriptUtxos <- utxosAt scrAddress |
| 79 | + let lookups2 = Constraints.plutusV1TypedValidatorLookups typedValidator |
| 80 | + <> Constraints.unspentOutputs pubKeyUtxos |
| 81 | + <> Constraints.unspentOutputs scriptUtxos |
| 82 | + <> Constraints.ownPaymentPubKeyHash pkh |
| 83 | + tx2 = |
| 84 | + Constraints.collectFromTheScript scriptUtxos () |
| 85 | + <> Constraints.mustIncludeDatum (Datum $ PlutusTx.toBuiltinData onChainTxOutRefs) |
| 86 | + <> mconcat mustSpendPubKeyOutputs |
| 87 | + ledgerTx2 <- submitTxConstraintsWith @UnitTest lookups2 tx2 |
| 88 | + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx2 |
| 89 | + |
| 90 | + where |
| 91 | + mustSpendPubKeyOutputs = fmap Constraints.mustSpendPubKeyOutput offChainTxOutRefs |
| 92 | + |
| 93 | +txoRefsFromWalletState :: WalletState -> Set TxOutRef |
| 94 | +txoRefsFromWalletState ws = head $ M.elems $ ws ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap |
| 95 | + |
| 96 | +-- needed to workaround bug 695 |
| 97 | +overrideW1TxOutRefs :: [TxOutRef] -> [TxOutRef] |
| 98 | +overrideW1TxOutRefs = overrideTxOutRefIdxes 50 |
| 99 | + |
| 100 | +overrideW2TxOutRefs :: [TxOutRef] -> [TxOutRef] |
| 101 | +overrideW2TxOutRefs = overrideTxOutRefIdxes 20 |
| 102 | + |
| 103 | +overrideTxOutRefIdxes :: Integer -> [TxOutRef] -> [TxOutRef] |
| 104 | +overrideTxOutRefIdxes i = fmap (\r@TxOutRef{txOutRefIdx=idx} -> r{txOutRefIdx= idx + i}) |
| 105 | +-- |
| 106 | + |
| 107 | +{- |
| 108 | +-- Example of bug https://github.com/input-output-hk/plutus-apps/issues/695: fails with TxOutRefNotFound because w1 does not have utxo with index of 5 from WalletState |
| 109 | +bug695 :: TestTree |
| 110 | +bug695 = |
| 111 | + let trace = do |
| 112 | + w1State <- Trace.agentState w1 |
| 113 | + let w1TxoRefs = txoRefsFromWalletState w1State |
| 114 | + w1MiddleTxoRef = [S.elemAt (length w1TxoRefs `div` 2) w1TxoRefs] |
| 115 | + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1MiddleTxoRef w1MiddleTxoRef w1PaymentPubKeyHash |
| 116 | + void $ Trace.waitNSlots 1 |
| 117 | +
|
| 118 | + in checkPredicate "Example of bug 695" |
| 119 | + (assertValidatedTransactionCount 2 .&&. walletFundsChange w1 mempty) |
| 120 | + (void trace) |
| 121 | +-} |
| 122 | + |
| 123 | +{- |
| 124 | +-- Example of bug https://github.com/input-output-hk/plutus-apps/issues/696 |
| 125 | +bug696 :: TestTree |
| 126 | +bug696 = |
| 127 | + let trace = do |
| 128 | + thisChainState <- Trace.chainState |
| 129 | + let traceBlockchain = thisChainState ^. chainNewestFirst |
| 130 | + traceEmulatorState = emulatorState traceBlockchain |
| 131 | + walletStateMap = traceEmulatorState ^. walletStates |
| 132 | + w1State = fromJust $ M.lookup w1 walletStateMap -- Fails here: Maybe.fromJust: Nothing |
| 133 | +
|
| 134 | + w1TxoRefs = txoRefsFromWalletState w1State |
| 135 | + w1MiddleTxoRef = [S.elemAt (length w1TxoRefs `div` 2) w1TxoRefs] |
| 136 | + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1MiddleTxoRef w1MiddleTxoRef w1PaymentPubKeyHash |
| 137 | + void $ Trace.waitNSlots 1 |
| 138 | +
|
| 139 | + in checkPredicate "Example of bug 696" |
| 140 | + (assertValidatedTransactionCount 2 .&&. walletFundsChange w1 mempty) |
| 141 | + (void trace) |
| 142 | +-} |
| 143 | + |
| 144 | +-- | Uses onchain and offchain constraint mustSpendPubKeyOutput to spend a single utxo from own wallet |
| 145 | +mustSpendSingleUtxoFromOwnWallet :: TestTree |
| 146 | +mustSpendSingleUtxoFromOwnWallet = |
| 147 | + let trace = do |
| 148 | + w1State <- Trace.agentState w1 |
| 149 | + let w1TxoRefs = txoRefsFromWalletState w1State |
| 150 | + w1MiddleTxoRef = [S.elemAt (length w1TxoRefs `div` 2) w1TxoRefs] |
| 151 | + overridedW1TxoRefs = overrideW1TxOutRefs w1MiddleTxoRef -- need to override index due to bug 695 |
| 152 | + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW1TxoRefs overridedW1TxoRefs w1PaymentPubKeyHash |
| 153 | + void $ Trace.waitNSlots 1 |
| 154 | + |
| 155 | + in checkPredicate "Successful use of mustSpendPubKeyOutput with a single txOutRef from own wallet" |
| 156 | + (assertValidatedTransactionCount 2 .&&. walletFundsChange w1 mempty) |
| 157 | + (void trace) |
| 158 | + |
| 159 | +-- | Uses onchain and offchain constraint mustSpendPubKeyOutput to spend the remaining utxos that were initially distributed to own wallet |
| 160 | +mustSpendRemainingInitialUtxosFromOwnWallet :: TestTree |
| 161 | +mustSpendRemainingInitialUtxosFromOwnWallet = |
| 162 | + let trace = do |
| 163 | + w1State <- Trace.agentState w1 |
| 164 | + let w1TxoRefs = txoRefsFromWalletState w1State |
| 165 | + w1RemainingTxoRefs = tail $ S.elems w1TxoRefs |
| 166 | + overridedW1TxoRefs = overrideW1TxOutRefs w1RemainingTxoRefs -- need to override index due to bug 695 |
| 167 | + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW1TxoRefs overridedW1TxoRefs w1PaymentPubKeyHash |
| 168 | + void $ Trace.waitNSlots 1 |
| 169 | + |
| 170 | + in checkPredicate "Successful use of mustSpendPubKeyOutput with all remaining initial txOutRefs from own wallet" |
| 171 | + (assertValidatedTransactionCount 2 .&&. walletFundsChange w1 mempty) |
| 172 | + (void trace) |
| 173 | + |
| 174 | +-- | Uses onchain and offchain constraint mustSpendPubKeyOutput to spend a single utxo from other wallet |
| 175 | +mustSpendSingleUtxoFromOtherWallet :: TestTree |
| 176 | +mustSpendSingleUtxoFromOtherWallet = |
| 177 | + let trace = do |
| 178 | + w2State <- Trace.agentState w2 |
| 179 | + let w2TxoRefs = txoRefsFromWalletState w2State |
| 180 | + w2MiddleTxoRef = [S.elemAt (length w2TxoRefs `div` 2) w2TxoRefs] |
| 181 | + overridedW2TxoRefs = overrideW2TxOutRefs w2MiddleTxoRef -- need to override index due to bug 695 |
| 182 | + Trace.setSigningProcess w1 (Just $ signPrivateKeys [paymentPrivateKey $ walletToMockWallet' w1, paymentPrivateKey $ walletToMockWallet' w2]) |
| 183 | + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW2TxoRefs overridedW2TxoRefs w2PaymentPubKeyHash |
| 184 | + void $ Trace.waitNSlots 1 |
| 185 | + |
| 186 | + in checkPredicate "Successful use of mustSpendPubKeyOutput with a single txOutRef from other wallet" |
| 187 | + (assertValidatedTransactionCount 2 .&&. walletFundsChange w2 (Ada.lovelaceValueOf $ negate lovelacePerInitialUtxo)) |
| 188 | + (void trace) |
| 189 | + |
| 190 | +-- | Uses onchain and offchain constraint mustSpendPubKeyOutput to spend all utxos from other wallet |
| 191 | +mustSpendAllUtxosFromOtherWallet :: TestTree |
| 192 | +mustSpendAllUtxosFromOtherWallet = |
| 193 | + let trace = do |
| 194 | + w2State <- Trace.agentState w2 |
| 195 | + let w2TxoRefs = txoRefsFromWalletState w2State |
| 196 | + allW2TxoRefs = S.elems w2TxoRefs |
| 197 | + overridedW2TxoRefs = overrideW2TxOutRefs allW2TxoRefs -- need to override index due to bug 695 |
| 198 | + Trace.setSigningProcess w1 (Just $ signPrivateKeys [paymentPrivateKey $ walletToMockWallet' w1, paymentPrivateKey $ walletToMockWallet' w2]) |
| 199 | + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW2TxoRefs overridedW2TxoRefs w2PaymentPubKeyHash |
| 200 | + void $ Trace.waitNSlots 1 |
| 201 | + |
| 202 | + in checkPredicate "Successful use of mustSpendPubKeyOutput with all initial txOutRefs from other wallet" |
| 203 | + (assertValidatedTransactionCount 2 .&&. walletFundsChange w2 (Ada.lovelaceValueOf $ negate initialLovelacePerWallet)) |
| 204 | + (void trace) |
| 205 | + |
| 206 | +-- Contract error is thrown when mustSpendPubKeyOutput is expecting a txo that does not exist |
| 207 | +contractErrorWhenAttemptingToSpendNonExistentOutput :: TestTree |
| 208 | +contractErrorWhenAttemptingToSpendNonExistentOutput = |
| 209 | + let contract = mustSpendPubKeyOutputContract [nonExistentTxoRef] [nonExistentTxoRef] w1PaymentPubKeyHash |
| 210 | + trace = do |
| 211 | + void $ Trace.activateContractWallet w1 contract |
| 212 | + void $ Trace.waitNSlots 1 |
| 213 | + |
| 214 | + in checkPredicate "Fail validation when mustSpendPubKeyOutput constraint expects a non-existing txo" |
| 215 | + (assertContractError contract (Trace.walletInstanceTag w1) (\case { ConstraintResolutionContractError ( Constraints.TxOutRefNotFound txoRefInError) -> txoRefInError == nonExistentTxoRef; _ -> False }) "failed to throw error" |
| 216 | + .&&. assertValidatedTransactionCount 1) |
| 217 | + (void trace) |
| 218 | + |
| 219 | +-- Uses onchain and offchain constraint mustSpendPubKeyOutput with a different expected txo onchain, asserts script evaluation error. |
| 220 | +phase2FailureWhenTxoIsNotSpent :: TestTree |
| 221 | +phase2FailureWhenTxoIsNotSpent = |
| 222 | + let trace = do |
| 223 | + w1State <- Trace.agentState w1 |
| 224 | + let w1TxoRefs = txoRefsFromWalletState w1State |
| 225 | + w1MiddleTxoRef = [S.elemAt (length w1TxoRefs `div` 2) w1TxoRefs] |
| 226 | + overridedW1TxoRefs = overrideW1TxOutRefs w1MiddleTxoRef -- need to override index due to bug 695 |
| 227 | + void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract overridedW1TxoRefs [nonExistentTxoRef] w1PaymentPubKeyHash |
| 228 | + void $ Trace.waitNSlots 1 |
| 229 | + |
| 230 | + in checkPredicate "Fail phase-2 validation when txo expected by on-chain mustSpendPubKeyOutput does not exist" |
| 231 | + (assertFailedTransaction (\_ err _ -> case err of {Ledger.ScriptFailure (EvaluationError ("L7":_) _) -> True; _ -> False })) |
| 232 | + (void trace) |
| 233 | + |
| 234 | +{-# INLINEABLE mkValidator #-} |
| 235 | +mkValidator :: [TxOutRef] -> () -> ScriptContext -> Bool |
| 236 | +mkValidator txOutRefs _ ctx = P.traceIfFalse "mustSpendPubKeyOutput not satisfied" (Constraints.checkScriptContext @() @() (P.mconcat mustSpendPubKeyOutputs) ctx) |
| 237 | + where |
| 238 | + mustSpendPubKeyOutputs = P.fmap Constraints.mustSpendPubKeyOutput txOutRefs |
| 239 | + |
| 240 | +data UnitTest |
| 241 | +instance Scripts.ValidatorTypes UnitTest where |
| 242 | + type instance DatumType UnitTest = [TxOutRef] |
| 243 | + type instance RedeemerType UnitTest = () |
| 244 | + |
| 245 | +typedValidator :: Scripts.TypedValidator UnitTest |
| 246 | +typedValidator = Scripts.mkTypedValidator @UnitTest |
| 247 | + $$(PlutusTx.compile [||mkValidator||]) |
| 248 | + $$(PlutusTx.compile [|| wrap ||]) |
| 249 | + where |
| 250 | + wrap = Scripts.mkUntypedValidator |
| 251 | + |
| 252 | +validatorScript :: Validator |
| 253 | +validatorScript = Scripts.validatorScript typedValidator |
| 254 | + |
| 255 | +valHash :: ValidatorHash |
| 256 | +valHash = Scripts.validatorHash typedValidator |
| 257 | + |
| 258 | +scrAddress :: Ledger.Address |
| 259 | +scrAddress = Ledger.scriptHashAddress valHash |
0 commit comments