1
+ {-# LANGUAGE QuasiQuotes #-}
2
+ {-# LANGUAGE TemplateHaskell #-}
3
+
1
4
module Spec.BotPlutusInterface.Balance (tests ) where
2
5
3
- import BotPlutusInterface.Balance (defaultBalanceConfig , withFee )
6
+ import BotPlutusInterface.Balance (balanceTxIO , defaultBalanceConfig , withFee )
4
7
import BotPlutusInterface.Balance qualified as Balance
5
8
import BotPlutusInterface.Effects (PABEffect )
9
+ import BotPlutusInterface.Types (
10
+ ContractEnvironment (cePABConfig ),
11
+ PABConfig (pcOwnPubKeyHash ),
12
+ )
13
+ import Control.Lens ((&) , (.~) , (<>~) , (^.) )
6
14
import Data.Default (Default (def ))
15
+ import Data.Function (on )
16
+ import Data.List (delete , partition )
7
17
import Data.Map qualified as Map
8
18
import Data.Set qualified as Set
9
19
import Data.Text qualified as Text
20
+ import Data.Void (Void )
10
21
import Ledger qualified
11
22
import Ledger.Ada qualified as Ada
12
23
import Ledger.Address (Address , PaymentPubKeyHash (PaymentPubKeyHash ))
13
24
import Ledger.Address qualified as Address
14
25
import Ledger.CardanoWallet qualified as Wallet
26
+ import Ledger.Constraints qualified as Constraints
27
+ import Ledger.Constraints.OffChain qualified as OffChain
15
28
import Ledger.Crypto (PubKeyHash )
16
- import Ledger.Tx (Tx (.. ), TxIn (.. ), TxInType (.. ), TxOut (.. ), TxOutRef (.. ))
29
+ import Ledger.Scripts qualified as Scripts
30
+ import Ledger.Tx (
31
+ ChainIndexTxOut (.. ),
32
+ Tx (.. ),
33
+ TxIn (.. ),
34
+ TxInType (.. ),
35
+ TxOut (.. ),
36
+ TxOutRef (.. ),
37
+ )
38
+ import Ledger.Value (AssetClass , Value )
17
39
import Ledger.Value qualified as Value
18
- import Spec.MockContract (runPABEffectPure )
40
+ import Plutus.V1.Ledger.Api qualified as Api
41
+ import PlutusTx qualified
42
+ import Spec.MockContract (
43
+ MockContractState ,
44
+ contractEnv ,
45
+ paymentPkh3 ,
46
+ pkh3 ,
47
+ pkhAddr3 ,
48
+ -- runContractPure,
49
+ runPABEffectPure ,
50
+ utxos ,
51
+ )
19
52
import Test.Tasty (TestTree , testGroup )
20
- import Test.Tasty.HUnit (Assertion , assertFailure , testCase , (@?=) )
53
+ import Test.Tasty.HUnit (Assertion , assertBool , assertFailure , testCase , (@?=) )
54
+ import Text.Printf (printf )
21
55
import Prelude
22
56
23
57
{- | Tests for 'cardano-cli query utxo' result parsers
@@ -30,21 +64,35 @@ tests =
30
64
[ testCase " Add utxos to cover fees" addUtxosForFees
31
65
, testCase " Add utxos to cover native tokens" addUtxosForNativeTokens
32
66
, testCase " Add utxos to cover change min utxo" addUtxosForChange
67
+ , testCase " Don't add change to UTxOs with datums (1)" dontAddChangeToDatum
68
+ , testCase " Don't add change to UTxOs with datums (2)" dontAddChangeToDatum2
33
69
]
34
70
71
+ validator :: Scripts. Validator
72
+ validator =
73
+ Scripts. mkValidatorScript
74
+ $$ (PlutusTx. compile [|| (\ _ _ _ -> () )|| ])
75
+
76
+ valHash :: Ledger. ValidatorHash
77
+ valHash = Scripts. validatorHash validator
78
+
35
79
pkh1 , pkh2 :: PubKeyHash
36
80
pkh1 = Address. unPaymentPubKeyHash . Wallet. paymentPubKeyHash $ Wallet. knownMockWallet 1
37
81
pkh2 = Address. unPaymentPubKeyHash . Wallet. paymentPubKeyHash $ Wallet. knownMockWallet 2
38
82
39
- addr1 , addr2 :: Address
83
+ addr1 , addr2 , valAddr :: Address
40
84
addr1 = Ledger. pubKeyHashAddress (PaymentPubKeyHash pkh1) Nothing
41
85
addr2 = Ledger. pubKeyHashAddress (PaymentPubKeyHash pkh2) Nothing
86
+ valAddr = Ledger. scriptAddress validator
42
87
43
- txOutRef1 , txOutRef2 , txOutRef3 , txOutRef4 :: TxOutRef
88
+ txOutRef1 , txOutRef2 , txOutRef3 , txOutRef4 , txOutRef5 , txOutRef6 , txOutRef7 :: TxOutRef
44
89
txOutRef1 = TxOutRef " 384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 0
45
90
txOutRef2 = TxOutRef " 52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 1
46
91
txOutRef3 = TxOutRef " d8a5630a9d7e913f9d186c95e5138a239a4e79ece3414ac894dbf37280944de3" 0
47
92
txOutRef4 = TxOutRef " d8a5630a9d7e913f9d186c95e5138a239a4e79ece3414ac894dbf37280944de3" 2
93
+ txOutRef5 = TxOutRef " 52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 0
94
+ txOutRef6 = TxOutRef " 52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 3
95
+ txOutRef7 = TxOutRef " 384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 1
48
96
49
97
txIn1 , txIn2 , txIn3 , txIn4 :: TxIn
50
98
txIn1 = TxIn txOutRef1 (Just ConsumePublicKeyAddress )
@@ -56,7 +104,29 @@ utxo1, utxo2, utxo3, utxo4 :: (TxOutRef, TxOut)
56
104
utxo1 = (txOutRef1, TxOut addr1 (Ada. lovelaceValueOf 1_100_000 ) Nothing )
57
105
utxo2 = (txOutRef2, TxOut addr1 (Ada. lovelaceValueOf 1_000_000 ) Nothing )
58
106
utxo3 = (txOutRef3, TxOut addr1 (Ada. lovelaceValueOf 900_000 ) Nothing )
59
- utxo4 = (txOutRef4, TxOut addr1 (Ada. lovelaceValueOf 800_000 <> Value. singleton " 11223344" " Token" 200 ) Nothing )
107
+ utxo4 = (txOutRef4, TxOut addr1 (Ada. lovelaceValueOf 800_000 <> Value. assetClassValue tokenAsset 200 ) Nothing )
108
+
109
+ scrValue :: Value. Value
110
+ scrValue = Value. assetClassValue tokenAsset 200 <> Ada. lovelaceValueOf 500_000
111
+
112
+ scrValue' :: Value. Value
113
+ scrValue' = Value. assetClassValue tokenAsset 120 <> Ada. lovelaceValueOf 500_000
114
+
115
+ scrDatum :: Ledger. Datum
116
+ scrDatum = Ledger. Datum $ Api. toBuiltinData (23 :: Integer )
117
+
118
+ scrDatumHash :: Ledger. DatumHash
119
+ scrDatumHash = Ledger. datumHash scrDatum
120
+
121
+ acValueOf :: AssetClass -> Value -> Integer
122
+ acValueOf = flip Value. assetClassValueOf
123
+
124
+ -- | Get the amount of lovelace in a `Value`.
125
+ lovelaceInValue :: Value -> Integer
126
+ lovelaceInValue = acValueOf (Value. assetClass Api. adaSymbol Api. adaToken)
127
+
128
+ tokenAsset :: Value. AssetClass
129
+ tokenAsset = Value. assetClass " 11223344" " Token"
60
130
61
131
addUtxosForFees :: Assertion
62
132
addUtxosForFees = do
@@ -105,3 +175,176 @@ addUtxosForChange = do
105
175
case ebalancedTx of
106
176
Left e -> assertFailure (Text. unpack e)
107
177
Right balancedTx -> txInputs <$> balancedTx @?= Right (Set. fromList [txIn1, txIn2])
178
+
179
+ dontAddChangeToDatum :: Assertion
180
+ dontAddChangeToDatum = do
181
+ let scrTxOut' =
182
+ ScriptChainIndexTxOut
183
+ valAddr
184
+ (Right validator)
185
+ (Right scrDatum)
186
+ scrValue
187
+ scrTxOut = Ledger. toTxOut scrTxOut'
188
+ usrTxOut' =
189
+ PublicKeyChainIndexTxOut
190
+ pkhAddr3
191
+ (Ada. lovelaceValueOf 1_001_000 )
192
+ usrTxOut = Ledger. toTxOut usrTxOut'
193
+ initState :: MockContractState ()
194
+ initState =
195
+ def & utxos .~ [(txOutRef6, scrTxOut), (txOutRef7, usrTxOut)]
196
+ & contractEnv .~ contractEnv'
197
+ pabConf :: PABConfig
198
+ pabConf = def {pcOwnPubKeyHash = pkh3}
199
+ contractEnv' :: ContractEnvironment ()
200
+ contractEnv' = def {cePABConfig = pabConf}
201
+
202
+ -- Input UTxOs:
203
+ -- UTxO 1:
204
+ -- - From: User
205
+ -- - Amt : 1.001 ADA
206
+ -- UTxO 2:
207
+ -- - From: Script
208
+ -- - Amt : 0.5 ADA + 200 Tokens
209
+ --
210
+ -- Output UTxOs:
211
+ -- UTxO 1:
212
+ -- - To : User
213
+ -- - Amt: 1 ADA
214
+ -- UTxO 2:
215
+ -- - To : Script
216
+ -- - Amt: 0.5005 Ada + 200 Token
217
+ --
218
+ -- Fees : 400 Lovelace
219
+ -- Change : 100 Lovelace
220
+
221
+ scrLkups =
222
+ Constraints. unspentOutputs (Map. fromList [(txOutRef6, scrTxOut'), (txOutRef7, usrTxOut')])
223
+ <> Constraints. ownPaymentPubKeyHash paymentPkh3
224
+ txConsts =
225
+ -- Pay the same datum to the script, but with more ada.
226
+ Constraints. mustPayToOtherScript valHash scrDatum (scrValue <> Ada. lovelaceValueOf 500 )
227
+ <> Constraints. mustPayToPubKey paymentPkh3 (Ada. lovelaceValueOf 1_000_000 )
228
+ <> Constraints. mustSpendScriptOutput txOutRef6 Ledger. unitRedeemer
229
+ <> Constraints. mustSpendPubKeyOutput txOutRef7
230
+ eunbalancedTx = Constraints. mkTx @ Void scrLkups txConsts
231
+
232
+ unbalancedTx <- liftAssertFailure eunbalancedTx (\ err -> " MkTx Error: " <> show err)
233
+ let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @ () @ '[PABEffect () ] pabConf pkh3 unbalancedTx)
234
+ eRslt' <- liftAssertFailure eRslt (\ txt -> " PAB effect error: " <> Text. unpack txt)
235
+ trx <- liftAssertFailure eRslt' (\ txt -> " Balancing error: " <> Text. unpack txt)
236
+ let scrTxOut'' = scrTxOut' & Ledger. ciTxOutValue <>~ Ada. lovelaceValueOf 500
237
+ scrTxOutExpected = Ledger. toTxOut scrTxOut''
238
+ isScrUtxo :: TxOut -> Bool
239
+ isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected
240
+ (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx)
241
+ assertBool
242
+ ( " Expected UTxO not in output Tx."
243
+ <> " \n Expected UTxO: \n "
244
+ <> show scrTxOutExpected
245
+ <> " \n Balanced Script UTxOs: \n "
246
+ <> show balScrUtxos
247
+ <> " \n Other Balanced UTxOs: \n "
248
+ <> show balOtherUtxos
249
+ <> " \n Unbalanced UTxOs: \n "
250
+ <> show (txOutputs (unbalancedTx ^. OffChain. tx))
251
+ )
252
+ (scrTxOutExpected `elem` txOutputs trx)
253
+
254
+ -- Like the first one, but
255
+ -- only has inputs from the script.
256
+ dontAddChangeToDatum2 :: Assertion
257
+ dontAddChangeToDatum2 = do
258
+ let scrTxOut' =
259
+ ScriptChainIndexTxOut
260
+ valAddr
261
+ (Right validator)
262
+ (Right scrDatum)
263
+ (scrValue <> Ada. lovelaceValueOf 1_500_000 )
264
+ scrTxOut = Ledger. toTxOut scrTxOut'
265
+ initState :: MockContractState ()
266
+ initState =
267
+ def & utxos .~ [(txOutRef6, scrTxOut)]
268
+ & contractEnv .~ contractEnv'
269
+ pabConf :: PABConfig
270
+ pabConf = def {pcOwnPubKeyHash = pkh3}
271
+ contractEnv' :: ContractEnvironment ()
272
+ contractEnv' = def {cePABConfig = pabConf}
273
+
274
+ -- Input UTxO :
275
+ -- - 2.0 ADA
276
+ -- - 200 tokens
277
+ -- Output UTxO :
278
+ -- - 0.5 ADA
279
+ -- - 120 tokens
280
+ -- Change:
281
+ -- - 1.5 ADA (400 Lovelace to fees)
282
+ -- - 80 tokens
283
+
284
+ scrLkups =
285
+ Constraints. unspentOutputs (Map. fromList [(txOutRef6, scrTxOut')])
286
+ <> Constraints. ownPaymentPubKeyHash paymentPkh3
287
+ txConsts =
288
+ -- Pay the same datum to the script, but with LESS ada
289
+ -- and fewer tokens. This is to ensure that the excess
290
+ -- ADA and tokens are moved into their own UTxO(s),
291
+ -- rather than just being left in the original UTxO.
292
+ -- (The extra ada is used to cover fees etc...)
293
+ Constraints. mustPayToOtherScript valHash scrDatum scrValue'
294
+ <> Constraints. mustSpendScriptOutput txOutRef6 Ledger. unitRedeemer
295
+ eunbalancedTx = Constraints. mkTx @ Void scrLkups txConsts
296
+
297
+ unbalancedTx <- liftAssertFailure eunbalancedTx (\ err -> " MkTx Error: " <> show err)
298
+ let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @ () @ '[PABEffect () ] pabConf pkh3 unbalancedTx)
299
+ eRslt' <- liftAssertFailure eRslt (\ txt -> " PAB effect error: " <> Text. unpack txt)
300
+ trx <- liftAssertFailure eRslt' (\ txt -> " Balancing error: " <> Text. unpack txt)
301
+ let scrTxOut'' = scrTxOut' & Ledger. ciTxOutValue .~ scrValue'
302
+ scrTxOutExpected = Ledger. toTxOut scrTxOut''
303
+ isScrUtxo :: TxOut -> Bool
304
+ isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected
305
+ (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx)
306
+ -- Check that the expected script UTxO
307
+ -- is in the output.
308
+ assertBool
309
+ ( " Expected UTxO not in output Tx."
310
+ <> " \n Expected UTxO: \n "
311
+ <> show scrTxOutExpected
312
+ <> " \n Balanced Script UTxOs: \n "
313
+ <> show balScrUtxos
314
+ <> " \n Other Balanced UTxOs: \n "
315
+ <> show balOtherUtxos
316
+ <> " \n Unbalanced UTxOs: \n "
317
+ <> show (txOutputs (unbalancedTx ^. OffChain. tx))
318
+ )
319
+ (scrTxOutExpected `elem` txOutputs trx)
320
+ -- Check that the output has the remaining change
321
+ let trxFee = txFee trx
322
+ adaChange' :: Integer
323
+ adaChange' = ((-) `on` (lovelaceInValue . txOutValue)) scrTxOut scrTxOutExpected
324
+ adaChange :: Integer
325
+ adaChange = adaChange' - lovelaceInValue trxFee
326
+ tokChange :: Integer
327
+ tokChange = ((-) `on` (acValueOf tokenAsset . txOutValue)) scrTxOut scrTxOutExpected
328
+ remainingTxOuts :: [TxOut ]
329
+ remainingTxOuts = delete scrTxOutExpected (txOutputs trx)
330
+ remainingValue :: Value. Value
331
+ remainingValue = foldMap txOutValue remainingTxOuts
332
+ -- Check for ADA change
333
+ assertBool
334
+ ( " Other UTxOs do not contain expected ADA change."
335
+ <> printf " \n Expected Amount : %d Lovelace" adaChange
336
+ <> printf " \n Actual Amount : %d Lovelace" (lovelaceInValue remainingValue)
337
+ )
338
+ (adaChange == lovelaceInValue remainingValue)
339
+ -- Check for Token change
340
+ assertBool
341
+ ( " Other UTxOs do not contain expected Token change."
342
+ <> printf " \n Expected Amount : %d tokens" tokChange
343
+ <> printf " \n Actual Amount : %d tokens" (acValueOf tokenAsset remainingValue)
344
+ )
345
+ (tokChange == acValueOf tokenAsset remainingValue)
346
+
347
+ -- | Lift an `Either` value into an `assertFailure`.
348
+ liftAssertFailure :: Either a b -> (a -> String ) -> IO b
349
+ liftAssertFailure (Left err) fstr = assertFailure (fstr err)
350
+ liftAssertFailure (Right rslt) _ = return rslt
0 commit comments