Skip to content
This repository was archived by the owner on Dec 2, 2024. It is now read-only.

Commit 3796dc1

Browse files
author
James Browning
committed
Add MustSpendPubKeyOutputs tests (incomplete)
1 parent cbbd984 commit 3796dc1

File tree

3 files changed

+193
-0
lines changed

3 files changed

+193
-0
lines changed

‎plutus-contract/plutus-contract.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -244,6 +244,7 @@ test-suite plutus-contract-test
244244
Spec.ThreadToken
245245
Spec.TxConstraints.MustMint
246246
Spec.TxConstraints.MustSpendAtLeast
247+
Spec.TxConstraints.MustSpendPubKeyOutput
247248
Spec.TxConstraints.RequiredSigner
248249
Spec.TxConstraints.TimeValidity
249250

‎plutus-contract/test/Spec.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ import Spec.State qualified
1313
import Spec.ThreadToken qualified
1414
import Spec.TxConstraints.MustMint qualified
1515
import Spec.TxConstraints.MustSpendAtLeast qualified
16+
import Spec.TxConstraints.MustSpendPubKeyOutput qualified
1617
import Spec.TxConstraints.RequiredSigner qualified
1718
import Spec.TxConstraints.TimeValidity qualified
1819
import Test.Tasty (TestTree, defaultMain, testGroup)
@@ -29,6 +30,7 @@ tests = testGroup "plutus-contract" [
2930
Spec.ThreadToken.tests,
3031
Spec.TxConstraints.MustMint.tests,
3132
Spec.TxConstraints.MustSpendAtLeast.tests,
33+
Spec.TxConstraints.MustSpendPubKeyOutput.tests,
3234
Spec.TxConstraints.RequiredSigner.tests,
3335
Spec.TxConstraints.TimeValidity.tests,
3436
Spec.Secrets.tests,

‎plutus-contract/test/Spec/TxConstraints/MustSpendPubKeyOutput.hs‎

Lines changed: 190 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,190 @@
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 (ownPaymentPubKeyHash, plutusV1TypedValidatorLookups,
22+
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 (assertValidatedTransactionCount, checkPredicateOptions, defaultCheckOptions,
31+
mockWalletPaymentPubKeyHash, w1, w2)
32+
import Plutus.Trace qualified as Trace
33+
import Plutus.V1.Ledger.Api (Datum (Datum), ScriptContext, TxOutRef (TxOutRef, txOutRefIdx), Validator, ValidatorHash)
34+
import PlutusTx qualified
35+
import PlutusTx.Prelude qualified as P
36+
import Wallet.Emulator.Wallet (WalletState, chainIndexEmulatorState, signPrivateKeys, walletToMockWallet')
37+
38+
tests :: TestTree
39+
tests =
40+
testGroup "MustSpendPubKeyOutput"
41+
[ spendSingleOwnWalletPubKeyOutput
42+
, spendAllOwnWalletPubKeyOutputs
43+
, spendOtherWalletPubKeyOutput
44+
-- , spendMultiplePubKeyOutputs
45+
-- , unableToSpendOtherWalletPubKeyOutputFromOwnWallet
46+
-- , unableToSpendNonExistentOutput
47+
-- , phase2Failure
48+
]
49+
50+
-- wallet starts with 10 utxos of 10 ada by default, this amount paid to script spends 1 utxo.
51+
baseLovelaceLockedByScript :: Integer
52+
baseLovelaceLockedByScript = 5_000_000
53+
54+
mustSpendPubKeyOutputContract :: [TxOutRef] -> Ledger.PaymentPubKeyHash -> Contract () Empty ContractError ()
55+
mustSpendPubKeyOutputContract txOutRefs pkh = do
56+
let lookups1 = Constraints.plutusV1TypedValidatorLookups typedValidator
57+
tx1 = Constraints.mustPayToTheScript txOutRefs (Ada.lovelaceValueOf baseLovelaceLockedByScript)
58+
ledgerTx1 <- submitTxConstraintsWith lookups1 tx1
59+
awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1
60+
61+
pubKeyUtxos <- utxosAt $ Ledger.pubKeyHashAddress pkh Nothing
62+
logInfo @String $ "pubKeyUtxos:: " ++ show pubKeyUtxos
63+
scriptUtxos <- utxosAt scrAddress
64+
let lookups2 = Constraints.plutusV1TypedValidatorLookups typedValidator
65+
<> Constraints.unspentOutputs pubKeyUtxos
66+
<> Constraints.unspentOutputs scriptUtxos
67+
<> Constraints.ownPaymentPubKeyHash pkh
68+
tx2 =
69+
Constraints.collectFromTheScript scriptUtxos ()
70+
<> Constraints.mustIncludeDatum (Datum $ PlutusTx.toBuiltinData txOutRefs)
71+
<> mconcat mustSpendPubKeyOutputs
72+
ledgerTx2 <- submitTxConstraintsWith @UnitTest lookups2 tx2
73+
awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx2
74+
75+
where
76+
mustSpendPubKeyOutputs = fmap Constraints.mustSpendPubKeyOutput txOutRefs
77+
78+
{-
79+
-- TODO 1: Raise bug to investigate why wallet does not exist in chain state in this trace
80+
trace :: Trace.EmulatorTrace ()
81+
trace = do
82+
void $ Trace.waitNSlots 1
83+
thisChainState <- Trace.chainState
84+
let w1PaymentPubKeyHash = mockWalletPaymentPubKeyHash w1
85+
thisBlockchain = thisChainState ^. chainNewestFirst
86+
thisEmulatorState = emulatorState thisBlockchain
87+
walletStateMap = thisEmulatorState ^. walletStates
88+
w1State = fromJust $ M.lookup w1 walletStateMap
89+
90+
w1EmulatorState = _chainIndexEmulatorState w1State
91+
w1DiskState = _diskState w1EmulatorState
92+
w1FirstTxoRef = head $ S.elems $ head $ M.elems $ w1DiskState ^. addressMap ^. unCredentialMap
93+
94+
void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1FirstTxoRef w1PaymentPubKeyHash
95+
void $ Trace.waitNSlots 1
96+
-}
97+
98+
{-
99+
-- TODO 2: Raise bug to investigate why wallet's utxos in emulator's diskstate have indexes starting at 0 when they actually start at 50
100+
trace :: Trace.EmulatorTrace ()
101+
trace = do
102+
w1State <- Trace.agentState w1
103+
let w1PaymentPubKeyHash = mockWalletPaymentPubKeyHash w1
104+
w1EmulatorState = w1State ^. chainIndexEmulatorState
105+
w1DiskState = w1EmulatorState ^. diskState
106+
w1TxoRef = S.elemAt 3 $ head $ M.elems (w1DiskState ^. addressMap ^. unCredentialMap)
107+
void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1TxoRef w1PaymentPubKeyHash
108+
void $ Trace.waitNSlots 1
109+
-}
110+
111+
txoRefsFromWalletState :: WalletState -> Set TxOutRef
112+
txoRefsFromWalletState ws = head $ M.elems $ ws ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap
113+
114+
-- needed to workaround bug
115+
overrideW1TxOutRefs :: [TxOutRef] -> [TxOutRef]
116+
overrideW1TxOutRefs = overrideTxOutRefIdxes 50
117+
118+
overrideW2TxOutRefs :: [TxOutRef] -> [TxOutRef]
119+
overrideW2TxOutRefs = overrideTxOutRefIdxes 20
120+
121+
overrideTxOutRefIdxes :: Integer -> [TxOutRef] -> [TxOutRef]
122+
overrideTxOutRefIdxes i = fmap (\r@TxOutRef{txOutRefIdx=idx} -> r{txOutRefIdx= idx + i})
123+
--
124+
125+
spendSingleOwnWalletPubKeyOutput :: TestTree
126+
spendSingleOwnWalletPubKeyOutput =
127+
let trace = do
128+
w1State <- Trace.agentState w1
129+
let w1PaymentPubKeyHash = mockWalletPaymentPubKeyHash w1
130+
w1TxoRefs = txoRefsFromWalletState w1State
131+
w1MiddleTxoRef = [S.elemAt (length w1TxoRefs `quot` 2) w1TxoRefs]
132+
w1TxoRefWithIdxPlus50 = overrideW1TxOutRefs w1MiddleTxoRef -- need to override index due to bug (see TODO 2)
133+
void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1TxoRefWithIdxPlus50 w1PaymentPubKeyHash
134+
void $ Trace.waitNSlots 1
135+
136+
in checkPredicateOptions defaultCheckOptions "Successful use of mustSpendPubKeyOutput with a single txOutRef from own wallet" (assertValidatedTransactionCount 2) (void trace)
137+
138+
spendAllOwnWalletPubKeyOutputs :: TestTree
139+
spendAllOwnWalletPubKeyOutputs =
140+
let trace = do
141+
w1State <- Trace.agentState w1
142+
let w1PaymentPubKeyHash = mockWalletPaymentPubKeyHash w1
143+
w1TxoRefs = txoRefsFromWalletState w1State
144+
w1TailTxoRefs = tail $ S.elems w1TxoRefs
145+
w1TxoRefsWithIdxPlus50 = overrideW1TxOutRefs w1TailTxoRefs -- need to override index due to bug (see TODO 2)
146+
void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w1TxoRefsWithIdxPlus50 w1PaymentPubKeyHash
147+
void $ Trace.waitNSlots 1
148+
149+
in checkPredicateOptions defaultCheckOptions "Successful use of mustSpendPubKeyOutput with all remaining txOutRefs from own wallet" (assertValidatedTransactionCount 2) (void trace)
150+
151+
spendOtherWalletPubKeyOutput :: TestTree
152+
spendOtherWalletPubKeyOutput =
153+
let trace = do
154+
w1State <- Trace.agentState w2
155+
let w2PaymentPubKeyHash = mockWalletPaymentPubKeyHash w2
156+
w2TxoRefs = txoRefsFromWalletState w1State
157+
w2MiddleTxoRef = [S.elemAt (length w2TxoRefs `quot` 2) w2TxoRefs]
158+
w2TxoRefWithIdxPlus50 = overrideW2TxOutRefs w2MiddleTxoRef -- need to override index due to bug (see TODO 2)
159+
Trace.setSigningProcess w1 (Just $ signPrivateKeys [paymentPrivateKey $ walletToMockWallet' w1, paymentPrivateKey $ walletToMockWallet' w2]) -- why is this needed here but not for mustProduceAtLeast?
160+
void $ Trace.activateContractWallet w1 $ mustSpendPubKeyOutputContract w2TxoRefWithIdxPlus50 w2PaymentPubKeyHash
161+
void $ Trace.waitNSlots 1
162+
163+
in checkPredicateOptions defaultCheckOptions "Successful use of mustSpendPubKeyOutput with a single txOutRef from other wallet" (assertValidatedTransactionCount 2) (void trace)
164+
165+
{-# INLINEABLE mkValidator #-}
166+
mkValidator :: [TxOutRef] -> () -> ScriptContext -> Bool
167+
mkValidator txOutRefs _ ctx = P.traceIfFalse "mustSpendPubKeyOutput not satisfied" (Constraints.checkScriptContext @() @() (P.mconcat mustSpendPubKeyOutputs) ctx)
168+
where
169+
mustSpendPubKeyOutputs = P.fmap Constraints.mustSpendPubKeyOutput txOutRefs
170+
171+
data UnitTest
172+
instance Scripts.ValidatorTypes UnitTest where
173+
type instance DatumType UnitTest = [TxOutRef]
174+
type instance RedeemerType UnitTest = ()
175+
176+
typedValidator :: Scripts.TypedValidator UnitTest
177+
typedValidator = Scripts.mkTypedValidator @UnitTest
178+
$$(PlutusTx.compile [||mkValidator||])
179+
$$(PlutusTx.compile [|| wrap ||])
180+
where
181+
wrap = Scripts.mkUntypedValidator
182+
183+
validatorScript :: Validator
184+
validatorScript = Scripts.validatorScript typedValidator
185+
186+
valHash :: ValidatorHash
187+
valHash = Scripts.validatorHash typedValidator
188+
189+
scrAddress :: Ledger.Address
190+
scrAddress = Ledger.scriptHashAddress valHash

0 commit comments

Comments
 (0)