Skip to content

Commit 304a423

Browse files
mikekekemikekeke
committed
Merge branch 'master' into gergely/vasil
2 parents 302bc39 + 761a0d6 commit 304a423

File tree

2 files changed

+276
-18
lines changed

2 files changed

+276
-18
lines changed

‎src/BotPlutusInterface/Balance.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ import Data.Kind (Type)
4848
import Data.List qualified as List
4949
import Data.Map (Map)
5050
import Data.Map qualified as Map
51-
import Data.Maybe (fromMaybe, isJust, mapMaybe)
51+
import Data.Maybe (fromMaybe, isJust, isJust, mapMaybe)
5252
import Data.Set qualified as Set
5353
import Data.Text (Text)
5454
import Data.Text qualified as Text
@@ -109,7 +109,7 @@ balanceTxIO ::
109109
Eff effs (Either Text Tx)
110110
balanceTxIO = balanceTxIO' @w defaultBalanceConfig
111111

112-
-- | `balanceTxIO'` is more flexible version of `balanceTxIO`, this let us specify custom `BalanceConfig`.
112+
-- | `balanceTxIO'` is more flexible version of `balanceTxIO`, this lets us specify custom `BalanceConfig`.
113113
balanceTxIO' ::
114114
forall (w :: Type) (effs :: [Type -> Type]).
115115
(Member (PABEffect w) effs) =>
@@ -384,6 +384,7 @@ handleNonAdaChange balanceCfg changeAddr utxos tx = runEitherT $ do
384384
Tx.txOutAddress txout == changeAddr
385385
&& not (justLovelace $ Tx.txOutValue txout)
386386
&& hasNoDatum txout
387+
&& hasNoDatum txout
387388
)
388389
else (\txout -> Tx.txOutAddress txout == changeAddr && hasNoDatum txout)
389390

‎test/Spec/BotPlutusInterface/Balance.hs‎

Lines changed: 273 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,24 +1,61 @@
1+
{-# LANGUAGE QuasiQuotes #-}
2+
{-# LANGUAGE TemplateHaskell #-}
3+
14
module Spec.BotPlutusInterface.Balance (tests) where
25

3-
import BotPlutusInterface.Balance (defaultBalanceConfig, withFee)
6+
import BotPlutusInterface.Balance (balanceTxIO, defaultBalanceConfig, withFee)
47
import BotPlutusInterface.Balance qualified as Balance
58
import BotPlutusInterface.Effects (PABEffect)
9+
import BotPlutusInterface.Types (
10+
ContractEnvironment (cePABConfig),
11+
PABConfig (pcOwnPubKeyHash),
12+
)
13+
import Control.Lens ((&), (.~), (<>~), (^.))
614
import Data.Default (Default (def))
15+
import Data.Function (on)
16+
import Data.List (delete, partition)
717
import Data.Map qualified as Map
818
import Data.Text qualified as Text
19+
import Data.Void (Void)
920
import Ledger qualified
1021
import Ledger.Ada qualified as Ada
1122
import Ledger.Ada qualified as Value
1223
import Ledger.Address (Address, PaymentPubKeyHash (PaymentPubKeyHash))
1324
import Ledger.Address qualified as Address
1425
import Ledger.CardanoWallet qualified as Wallet
26+
import Ledger.Constraints qualified as Constraints
27+
import Ledger.Constraints.OffChain qualified as OffChain
1528
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)
1739
import Ledger.Value qualified as Value
18-
import Spec.MockContract (currencySymbol1, 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+
currencySymbol1, runPABEffectPure,
50+
utxos,
51+
)
1952
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)
2155
import Prelude
56+
import Plutus.Script.Utils.Scripts qualified as ScriptUtils
57+
import Plutus.Script.Utils.V1.Address qualified as ScriptUtils
58+
import Prettyprinter (pretty)
2259

2360
{- | Tests for 'cardano-cli query utxo' result parsers
2461
@since 0.1
@@ -30,21 +67,35 @@ tests =
3067
[ testCase "Add utxos to cover fees" addUtxosForFees
3168
, testCase "Add utxos to cover native tokens" addUtxosForNativeTokens
3269
, testCase "Add utxos to cover change min utxo" addUtxosForChange
70+
, testCase "Don't add change to UTxOs with datums (1)" dontAddChangeToDatum
71+
, testCase "Don't add change to UTxOs with datums (2)" dontAddChangeToDatum2
3372
]
3473

74+
validator :: Scripts.Validator
75+
validator =
76+
Scripts.mkValidatorScript
77+
$$(PlutusTx.compile [||(\_ _ _ -> ())||])
78+
79+
valHash :: Ledger.ValidatorHash
80+
valHash = Scripts.validatorHash validator
81+
3582
pkh1, pkh2 :: PubKeyHash
3683
pkh1 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 1
3784
pkh2 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 2
3885

39-
addr1, addr2 :: Address
86+
addr1, addr2, valAddr :: Address
4087
addr1 = Ledger.pubKeyHashAddress (PaymentPubKeyHash pkh1) Nothing
4188
addr2 = Ledger.pubKeyHashAddress (PaymentPubKeyHash pkh2) Nothing
89+
valAddr = ScriptUtils.mkValidatorAddress validator
4290

43-
txOutRef1, txOutRef2, txOutRef3, txOutRef4 :: TxOutRef
91+
txOutRef1, txOutRef2, txOutRef3, txOutRef4, txOutRef5, txOutRef6, txOutRef7 :: TxOutRef
4492
txOutRef1 = TxOutRef "384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 0
4593
txOutRef2 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 1
4694
txOutRef3 = TxOutRef "d8a5630a9d7e913f9d186c95e5138a239a4e79ece3414ac894dbf37280944de3" 0
4795
txOutRef4 = TxOutRef "d8a5630a9d7e913f9d186c95e5138a239a4e79ece3414ac894dbf37280944de3" 2
96+
txOutRef5 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 0
97+
txOutRef6 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 3
98+
txOutRef7 = TxOutRef "384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 1
4899

49100
txIn1, txIn2, txIn3, txIn4 :: TxIn
50101
txIn1 = TxIn txOutRef1 (Just ConsumePublicKeyAddress)
@@ -58,6 +109,29 @@ utxo2 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 1_000_000) Nothing)
58109
utxo3 = (txOutRef3, TxOut addr1 (Ada.lovelaceValueOf 900_000) Nothing)
59110
utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.singleton currencySymbol1 "Token" 200) Nothing)
60111

112+
-- Ada values set to amount that covers min Ada so we don't need to deal with
113+
-- output's adjustments
114+
scrValue :: Value.Value
115+
scrValue = Value.assetClassValue tokenAsset 200 <> Ada.lovelaceValueOf 2_000_000
116+
117+
118+
119+
scrDatum :: Ledger.Datum
120+
scrDatum = Ledger.Datum $ Api.toBuiltinData (23 :: Integer)
121+
122+
scrDatumHash :: Ledger.DatumHash
123+
scrDatumHash = ScriptUtils.datumHash scrDatum
124+
125+
acValueOf :: AssetClass -> Value -> Integer
126+
acValueOf = flip Value.assetClassValueOf
127+
128+
-- | Get the amount of lovelace in a `Value`.
129+
lovelaceInValue :: Value -> Integer
130+
lovelaceInValue = acValueOf (Value.assetClass Api.adaSymbol Api.adaToken)
131+
132+
tokenAsset :: Value.AssetClass
133+
tokenAsset = Value.assetClass currencySymbol1 "Token"
134+
61135
addUtxosForFees :: Assertion
62136
addUtxosForFees = do
63137
let txout = TxOut addr2 (Ada.lovelaceValueOf 1_000_000) Nothing
@@ -75,15 +149,7 @@ addUtxosForFees = do
75149

76150
addUtxosForNativeTokens :: Assertion
77151
addUtxosForNativeTokens = do
78-
let minimumAdaRequired = Value.adaValueOf 1
79-
{- `minimumAdaRequired` has to be added to `txout` because
80-
balancing now decoupled from adjusting minimum Ada amount in output,
81-
and adjusting happens during `adjustUnbalancedTx` Contract
82-
effect execution *before* balancing. Adding `minimumAdaRequired`
83-
to `txout` Value aims to simulate result of `adjustUnbalancedTx` call.
84-
Note that 1 Ada is test value - real amount is determined by Ledger and can vary.
85-
-}
86-
txout = TxOut addr2 (Value.singleton currencySymbol1 "Token" 123 <> minimumAdaRequired) Nothing
152+
let txout = TxOut addr2 (Value.singleton currencySymbol1 "Token" 123) Nothing
87153
tx = mempty {txOutputs = [txout]} `withFee` 500_000
88154
utxoIndex = Map.fromList [utxo1, utxo2, utxo3, utxo4]
89155
ownAddr = addr1
@@ -94,7 +160,7 @@ addUtxosForNativeTokens = do
94160

95161
case ebalancedTx of
96162
Left e -> assertFailure (Text.unpack e)
97-
Right balancedTx -> txInputs <$> balancedTx @?= Right [txIn3, txIn4]
163+
Right balancedTx -> txInputs <$> balancedTx @?= Right [txIn4]
98164

99165
addUtxosForChange :: Assertion
100166
addUtxosForChange = do
@@ -110,3 +176,194 @@ addUtxosForChange = do
110176
case ebalancedTx of
111177
Left e -> assertFailure (Text.unpack e)
112178
Right balancedTx -> txInputs <$> balancedTx @?= Right [txIn1, txIn2]
179+
180+
dontAddChangeToDatum :: Assertion
181+
dontAddChangeToDatum = do
182+
let scrTxOut =
183+
ScriptChainIndexTxOut
184+
valAddr
185+
scrValue
186+
(toHashAndDatum scrDatum)
187+
Nothing
188+
(toHashAndValidator validator)
189+
-- scrTxOut = Ledger.toTxOut scrTxOut'
190+
usrTxOut =
191+
PublicKeyChainIndexTxOut
192+
pkhAddr3
193+
(Ada.lovelaceValueOf 1_001_000)
194+
Nothing
195+
Nothing
196+
-- usrTxOut = Ledger.toTxOut usrTxOut'
197+
initState :: MockContractState ()
198+
initState =
199+
def & utxos .~ [(txOutRef6, scrTxOut), (txOutRef7, usrTxOut)]
200+
& contractEnv .~ contractEnv'
201+
pabConf :: PABConfig
202+
pabConf = def {pcOwnPubKeyHash = pkh3}
203+
contractEnv' :: ContractEnvironment ()
204+
contractEnv' = def {cePABConfig = pabConf}
205+
206+
-- Input UTxOs:
207+
-- UTxO 1:
208+
-- - From: User
209+
-- - Amt : 1.001 ADA
210+
-- UTxO 2:
211+
-- - From: Script
212+
-- - Amt : 2 ADA + 200 Tokens
213+
--
214+
-- Output UTxOs:
215+
-- UTxO 1:
216+
-- - To : User
217+
-- - Amt: 1 ADA
218+
-- UTxO 2:
219+
-- - To : Script
220+
-- - Amt: 1.5 Ada + 200 Token
221+
--
222+
-- Fees : 400 Lovelace
223+
-- Change : 500600 Lovelace
224+
225+
scrLkups =
226+
Constraints.unspentOutputs (Map.fromList [(txOutRef6, scrTxOut), (txOutRef7, usrTxOut)])
227+
<> Constraints.ownPaymentPubKeyHash paymentPkh3
228+
<> Constraints.plutusV1OtherScript validator
229+
230+
payToScriptValue = Ada.lovelaceValueOf 1_500_000
231+
payToUserValue = Ada.lovelaceValueOf 1_000_000
232+
txConsts =
233+
-- Pay the same datum to the script, but with more ada.
234+
Constraints.mustPayToOtherScript valHash scrDatum payToScriptValue
235+
<> Constraints.mustPayToPubKey paymentPkh3 payToUserValue
236+
<> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer
237+
<> Constraints.mustSpendPubKeyOutput txOutRef7
238+
eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts
239+
240+
unbalancedTx <- liftAssertFailure eunbalancedTx (\err -> "MkTx Error: " <> show err)
241+
let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx)
242+
eRslt' <- liftAssertFailure eRslt (\txt -> "PAB effect error: " <> Text.unpack txt)
243+
trx <- liftAssertFailure eRslt' (\txt -> "Balancing error: " <> Text.unpack txt)
244+
let scrTxOut'' = scrTxOut & Ledger.ciTxOutValue .~ payToScriptValue
245+
scrTxOutExpected = Ledger.toTxOut scrTxOut''
246+
isScrUtxo :: TxOut -> Bool
247+
isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected
248+
(balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx)
249+
assertBool
250+
( "Expected UTxO not in output Tx."
251+
<> "\nExpected UTxO: \n"
252+
<> show (pretty scrTxOutExpected)
253+
<> "\nBalanced Script UTxOs: \n"
254+
<> show (pretty balScrUtxos)
255+
<> "\nOther Balanced UTxOs: \n"
256+
<> show (pretty balOtherUtxos)
257+
<> "\nUnbalanced UTxOs: \n"
258+
<> show (pretty (txOutputs (unbalancedTx ^. OffChain.tx)))
259+
)
260+
(scrTxOutExpected `elem` txOutputs trx)
261+
262+
-- Like the first one, but
263+
-- only has inputs from the script.
264+
dontAddChangeToDatum2 :: Assertion
265+
dontAddChangeToDatum2 = do
266+
let scrTxOut =
267+
ScriptChainIndexTxOut
268+
valAddr
269+
(scrValue <> Ada.lovelaceValueOf 1_500_000)
270+
(toHashAndDatum scrDatum)
271+
Nothing
272+
(toHashAndValidator validator)
273+
-- scrTxOut = Ledger.toTxOut scrTxOut'
274+
initState :: MockContractState ()
275+
initState =
276+
def & utxos .~ [(txOutRef6, scrTxOut)]
277+
& contractEnv .~ contractEnv'
278+
pabConf :: PABConfig
279+
pabConf = def {pcOwnPubKeyHash = pkh3}
280+
contractEnv' :: ContractEnvironment ()
281+
contractEnv' = def {cePABConfig = pabConf}
282+
283+
-- Input UTxO :
284+
-- - 3.5 ADA
285+
-- - 200 tokens
286+
-- Output UTxO :
287+
-- - 1 ADA
288+
-- - 120 tokens
289+
-- Change:
290+
-- - 1.5 ADA (400 Lovelace to fees)
291+
-- - 80 tokens
292+
293+
payToScrValue :: Value.Value
294+
payToScrValue = Value.assetClassValue tokenAsset 120 <> Ada.lovelaceValueOf 1_000_000
295+
296+
scrLkups =
297+
Constraints.unspentOutputs (Map.fromList [(txOutRef6, scrTxOut)])
298+
<> Constraints.ownPaymentPubKeyHash paymentPkh3
299+
<> Constraints.plutusV1OtherScript validator
300+
txConsts =
301+
-- Pay the same datum to the script, but with LESS ada
302+
-- and fewer tokens. This is to ensure that the excess
303+
-- ADA and tokens are moved into their own UTxO(s),
304+
-- rather than just being left in the original UTxO.
305+
-- (The extra ada is used to cover fees etc...)
306+
Constraints.mustPayToOtherScript valHash scrDatum payToScrValue
307+
<> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer
308+
eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts
309+
310+
unbalancedTx <- liftAssertFailure eunbalancedTx (\err -> "MkTx Error: " <> show err)
311+
let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx)
312+
eRslt' <- liftAssertFailure eRslt (\txt -> "PAB effect error: " <> Text.unpack txt)
313+
trx <- liftAssertFailure eRslt' (\txt -> "Balancing error: " <> Text.unpack txt)
314+
let scrTxOut'' = scrTxOut & Ledger.ciTxOutValue .~ payToScrValue
315+
scrTxOutExpected = Ledger.toTxOut scrTxOut''
316+
isScrUtxo :: TxOut -> Bool
317+
isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected
318+
(balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx)
319+
-- Check that the expected script UTxO
320+
-- is in the output.
321+
assertBool
322+
( "Expected UTxO not in output Tx."
323+
<> "\nExpected UTxO: \n"
324+
<> show scrTxOutExpected
325+
<> "\nBalanced Script UTxOs: \n"
326+
<> show balScrUtxos
327+
<> "\nOther Balanced UTxOs: \n"
328+
<> show balOtherUtxos
329+
<> "\nUnbalanced UTxOs: \n"
330+
<> show (txOutputs (unbalancedTx ^. OffChain.tx))
331+
)
332+
(scrTxOutExpected `elem` txOutputs trx)
333+
-- Check that the output has the remaining change
334+
let trxFee = txFee trx
335+
adaChange' :: Integer
336+
adaChange' = ((-) `on` (lovelaceInValue . txOutValue)) (Ledger.toTxOut scrTxOut) scrTxOutExpected
337+
adaChange :: Integer
338+
adaChange = adaChange' - lovelaceInValue trxFee
339+
tokChange :: Integer
340+
tokChange = ((-) `on` (acValueOf tokenAsset . txOutValue)) (Ledger.toTxOut scrTxOut) scrTxOutExpected
341+
remainingTxOuts :: [TxOut]
342+
remainingTxOuts = delete scrTxOutExpected (txOutputs trx)
343+
remainingValue :: Value.Value
344+
remainingValue = foldMap txOutValue remainingTxOuts
345+
-- Check for ADA change
346+
assertBool
347+
( "Other UTxOs do not contain expected ADA change."
348+
<> printf "\nExpected Amount : %d Lovelace" adaChange
349+
<> printf "\nActual Amount : %d Lovelace" (lovelaceInValue remainingValue)
350+
)
351+
(adaChange == lovelaceInValue remainingValue)
352+
-- Check for Token change
353+
assertBool
354+
( "Other UTxOs do not contain expected Token change."
355+
<> printf "\nExpected Amount : %d tokens" tokChange
356+
<> printf "\nActual Amount : %d tokens" (acValueOf tokenAsset remainingValue)
357+
)
358+
(tokChange == acValueOf tokenAsset remainingValue)
359+
360+
-- | Lift an `Either` value into an `assertFailure`.
361+
liftAssertFailure :: Either a b -> (a -> String) -> IO b
362+
liftAssertFailure (Left err) fstr = assertFailure (fstr err)
363+
liftAssertFailure (Right rslt) _ = return rslt
364+
365+
toHashAndDatum :: ScriptUtils.Datum -> (ScriptUtils.DatumHash, Maybe ScriptUtils.Datum)
366+
toHashAndDatum d = (ScriptUtils.datumHash d, Just d)
367+
368+
toHashAndValidator :: Api.Validator -> (Api.ValidatorHash, Maybe Api.Validator)
369+
toHashAndValidator v = (Scripts.validatorHash v, Just v)

0 commit comments

Comments
 (0)