Skip to content

Commit 761a0d6

Browse files
mikekekemikekeke
authored
Merge pull request #140 from mlabs-haskell/david/tx-change-datum
Don't add change to UTxOs with Datums when Balancing Transactions
2 parents 56546a8 + b3127f9 commit 761a0d6

File tree

2 files changed

+262
-12
lines changed

2 files changed

+262
-12
lines changed

‎src/BotPlutusInterface/Balance.hs‎

Lines changed: 12 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,7 @@ import Data.List ((\\))
4545
import Data.List qualified as List
4646
import Data.Map (Map)
4747
import Data.Map qualified as Map
48-
import Data.Maybe (fromMaybe, mapMaybe)
48+
import Data.Maybe (fromMaybe, isJust, mapMaybe)
4949
import Data.Set qualified as Set
5050
import Data.Text (Text)
5151
import Data.Text qualified as Text
@@ -104,7 +104,7 @@ balanceTxIO ::
104104
Eff effs (Either Text Tx)
105105
balanceTxIO = balanceTxIO' @w defaultBalanceConfig
106106

107-
-- | `balanceTxIO'` is more flexible version of `balanceTxIO`, this let us specify custom `BalanceConfig`.
107+
-- | `balanceTxIO'` is more flexible version of `balanceTxIO`, this lets us specify custom `BalanceConfig`.
108108
balanceTxIO' ::
109109
forall (w :: Type) (effs :: [Type -> Type]).
110110
(Member (PABEffect w) effs) =>
@@ -314,6 +314,12 @@ getAdaChange utxos = lovelaceValue . getChange utxos
314314
getNonAdaChange :: Map TxOutRef TxOut -> Tx -> Value
315315
getNonAdaChange utxos = Ledger.noAdaValue . getChange utxos
316316

317+
hasDatum :: TxOut -> Bool
318+
hasDatum = isJust . txOutDatumHash
319+
320+
hasNoDatum :: TxOut -> Bool
321+
hasNoDatum = not . hasDatum
322+
317323
-- | Add min lovelaces to each tx output
318324
addLovelaces :: [(TxOut, Integer)] -> Tx -> Tx
319325
addLovelaces minLovelaces tx =
@@ -372,8 +378,9 @@ handleNonAdaChange balanceCfg changeAddr utxos tx =
372378
( \txout ->
373379
Tx.txOutAddress txout == changeAddr
374380
&& not (justLovelace $ Tx.txOutValue txout)
381+
&& hasNoDatum txout
375382
)
376-
else (\txout -> Tx.txOutAddress txout == changeAddr)
383+
else (\txout -> Tx.txOutAddress txout == changeAddr && hasNoDatum txout)
377384
newOutput =
378385
TxOut
379386
{ txOutAddress = changeAddr
@@ -401,15 +408,15 @@ addAdaChange balanceCfg changeAddr change tx
401408
{ txOutputs =
402409
List.reverse $
403410
modifyFirst
404-
(\txout -> Tx.txOutAddress txout == changeAddr && justLovelace (txOutValue txout))
411+
(\txout -> Tx.txOutAddress txout == changeAddr && justLovelace (txOutValue txout) && hasNoDatum txout)
405412
(fmap $ addValueToTxOut $ Ada.lovelaceValueOf change)
406413
(List.reverse $ txOutputs tx)
407414
}
408415
| otherwise =
409416
tx
410417
{ txOutputs =
411418
modifyFirst
412-
((== changeAddr) . Tx.txOutAddress)
419+
(\txout -> Tx.txOutAddress txout == changeAddr && hasNoDatum txout)
413420
(fmap $ addValueToTxOut $ Ada.lovelaceValueOf change)
414421
(txOutputs tx)
415422
}

‎test/Spec/BotPlutusInterface/Balance.hs‎

Lines changed: 250 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,57 @@
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.Set qualified as Set
919
import Data.Text qualified as Text
20+
import Data.Void (Void)
1021
import Ledger qualified
1122
import Ledger.Ada qualified as Ada
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 (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+
)
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
2256

2357
{- | Tests for 'cardano-cli query utxo' result parsers
@@ -30,21 +64,35 @@ tests =
3064
[ testCase "Add utxos to cover fees" addUtxosForFees
3165
, testCase "Add utxos to cover native tokens" addUtxosForNativeTokens
3266
, 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
3369
]
3470

71+
validator :: Scripts.Validator
72+
validator =
73+
Scripts.mkValidatorScript
74+
$$(PlutusTx.compile [||(\_ _ _ -> ())||])
75+
76+
valHash :: Ledger.ValidatorHash
77+
valHash = Scripts.validatorHash validator
78+
3579
pkh1, pkh2 :: PubKeyHash
3680
pkh1 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 1
3781
pkh2 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 2
3882

39-
addr1, addr2 :: Address
83+
addr1, addr2, valAddr :: Address
4084
addr1 = Ledger.pubKeyHashAddress (PaymentPubKeyHash pkh1) Nothing
4185
addr2 = Ledger.pubKeyHashAddress (PaymentPubKeyHash pkh2) Nothing
86+
valAddr = Ledger.scriptAddress validator
4287

43-
txOutRef1, txOutRef2, txOutRef3, txOutRef4 :: TxOutRef
88+
txOutRef1, txOutRef2, txOutRef3, txOutRef4, txOutRef5, txOutRef6, txOutRef7 :: TxOutRef
4489
txOutRef1 = TxOutRef "384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 0
4590
txOutRef2 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 1
4691
txOutRef3 = TxOutRef "d8a5630a9d7e913f9d186c95e5138a239a4e79ece3414ac894dbf37280944de3" 0
4792
txOutRef4 = TxOutRef "d8a5630a9d7e913f9d186c95e5138a239a4e79ece3414ac894dbf37280944de3" 2
93+
txOutRef5 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 0
94+
txOutRef6 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 3
95+
txOutRef7 = TxOutRef "384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 1
4896

4997
txIn1, txIn2, txIn3, txIn4 :: TxIn
5098
txIn1 = TxIn txOutRef1 (Just ConsumePublicKeyAddress)
@@ -56,7 +104,29 @@ utxo1, utxo2, utxo3, utxo4 :: (TxOutRef, TxOut)
56104
utxo1 = (txOutRef1, TxOut addr1 (Ada.lovelaceValueOf 1_100_000) Nothing)
57105
utxo2 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 1_000_000) Nothing)
58106
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"
60130

61131
addUtxosForFees :: Assertion
62132
addUtxosForFees = do
@@ -105,3 +175,176 @@ addUtxosForChange = do
105175
case ebalancedTx of
106176
Left e -> assertFailure (Text.unpack e)
107177
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+
<> "\nExpected UTxO: \n"
244+
<> show scrTxOutExpected
245+
<> "\nBalanced Script UTxOs: \n"
246+
<> show balScrUtxos
247+
<> "\nOther Balanced UTxOs: \n"
248+
<> show balOtherUtxos
249+
<> "\nUnbalanced 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+
<> "\nExpected UTxO: \n"
311+
<> show scrTxOutExpected
312+
<> "\nBalanced Script UTxOs: \n"
313+
<> show balScrUtxos
314+
<> "\nOther Balanced UTxOs: \n"
315+
<> show balOtherUtxos
316+
<> "\nUnbalanced 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 "\nExpected Amount : %d Lovelace" adaChange
336+
<> printf "\nActual 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 "\nExpected Amount : %d tokens" tokChange
343+
<> printf "\nActual 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

Comments
 (0)