From c9b7cbcb515046d33c6f7f01b50212130b1009c4 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Tue, 9 Aug 2022 12:23:33 -0400 Subject: [PATCH 01/15] Partitions UTxOs into those with/without datums. Fails the "redeem from validator" test. --- src/BotPlutusInterface/Balance.hs | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 79f43215..475d39d0 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -45,7 +45,7 @@ import Data.List ((\\)) import Data.List qualified as List import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe, isJust) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text @@ -122,6 +122,9 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = let utxoIndex :: Map TxOutRef TxOut utxoIndex = fmap Tx.toTxOut utxos <> unBalancedTxUtxoIndex unbalancedTx + utxoIndexD, utxoIndexS :: Map TxOutRef TxOut + (utxoIndexD, utxoIndexS) = splitUtxos utxoIndex + requiredSigs :: [PubKeyHash] requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx) @@ -148,7 +151,13 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = else hoistEither $ addSignatories ownPkh privKeys requiredSigs tx -- Balance the tx - (balancedTx, minUtxos) <- balanceTxLoop utxoIndex privKeys [] preBalancedTx + -- (balancedTx, minUtxos) <- balanceTxLoop utxoIndex privKeys [] preBalancedTx + (balancedTx', minUtxos) <- balanceTxLoop utxoIndexS privKeys [] preBalancedTx + + let txOuts1 = txOutputs balancedTx' + txOuts2 = txOuts1 <> Map.elems utxoIndexD + balancedTx = balancedTx' {txOutputs = txOuts2} + -- Get current Ada change let adaChange = getAdaChange utxoIndex balancedTx @@ -314,6 +323,14 @@ getAdaChange utxos = lovelaceValue . getChange utxos getNonAdaChange :: Map TxOutRef TxOut -> Tx -> Value getNonAdaChange utxos = Ledger.noAdaValue . getChange utxos +hasDatum :: TxOut -> Bool +hasDatum = isJust . txOutDatumHash + +-- | Split UTxOs into ones that have data +-- and those that don't. +splitUtxos :: Map TxOutRef TxOut -> (Map TxOutRef TxOut, Map TxOutRef TxOut) +splitUtxos = Map.partition hasDatum + -- | Add min lovelaces to each tx output addLovelaces :: [(TxOut, Integer)] -> Tx -> Tx addLovelaces minLovelaces tx = From 3db502d7ea515bd3fdcb9a72a15ca7b6fa8402fa Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Tue, 9 Aug 2022 14:20:37 -0400 Subject: [PATCH 02/15] Slightly changed where Datum Txs are re-added. Also made it so `addAdaChange` never adds change to UTxOs with datums. --- src/BotPlutusInterface/Balance.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 475d39d0..3a022080 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -152,11 +152,11 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = -- Balance the tx -- (balancedTx, minUtxos) <- balanceTxLoop utxoIndex privKeys [] preBalancedTx - (balancedTx', minUtxos) <- balanceTxLoop utxoIndexS privKeys [] preBalancedTx + (balancedTx, minUtxos) <- balanceTxLoop utxoIndexS privKeys [] preBalancedTx - let txOuts1 = txOutputs balancedTx' - txOuts2 = txOuts1 <> Map.elems utxoIndexD - balancedTx = balancedTx' {txOutputs = txOuts2} + let txOuts1 = txOutputs balancedTx + addDatumTxs txos = txos <> Map.elems utxoIndexD + addDatums tx = tx {txOutputs = (addDatumTxs (txOutputs tx))} -- Get current Ada change @@ -173,7 +173,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = -- Get the updated change, add it to the tx let finalAdaChange = getAdaChange utxoIndex balancedTxWithChange - fullyBalancedTx = addAdaChange balanceCfg changeAddr finalAdaChange balancedTxWithChange + fullyBalancedTx = addDatums $ addAdaChange balanceCfg changeAddr finalAdaChange balancedTxWithChange txInfoLog = printBpiLog @w (Debug [TxBalancingLog]) $ "UnbalancedTx TxInputs: " @@ -418,7 +418,7 @@ addAdaChange balanceCfg changeAddr change tx { txOutputs = List.reverse $ modifyFirst - (\txout -> Tx.txOutAddress txout == changeAddr && justLovelace (txOutValue txout)) + (\txout -> Tx.txOutAddress txout == changeAddr && justLovelace (txOutValue txout) && Tx.txOutDatumHash txout == Nothing) (fmap $ addValueToTxOut $ Ada.lovelaceValueOf change) (List.reverse $ txOutputs tx) } @@ -426,7 +426,7 @@ addAdaChange balanceCfg changeAddr change tx tx { txOutputs = modifyFirst - ((== changeAddr) . Tx.txOutAddress) + (\txout -> Tx.txOutAddress txout == changeAddr && Tx.txOutDatumHash txout == Nothing) (fmap $ addValueToTxOut $ Ada.lovelaceValueOf change) (txOutputs tx) } From fc1134f32bb1ff73d84d2fa25f0960b18749877d Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Wed, 10 Aug 2022 11:44:51 -0400 Subject: [PATCH 03/15] Formatting/Linting --- src/BotPlutusInterface/Balance.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 3a022080..10930fa2 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -45,7 +45,7 @@ import Data.List ((\\)) import Data.List qualified as List import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe (fromMaybe, mapMaybe, isJust) +import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text @@ -156,8 +156,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = let txOuts1 = txOutputs balancedTx addDatumTxs txos = txos <> Map.elems utxoIndexD - addDatums tx = tx {txOutputs = (addDatumTxs (txOutputs tx))} - + addDatums tx = tx {txOutputs = addDatumTxs (txOutputs tx)} -- Get current Ada change let adaChange = getAdaChange utxoIndex balancedTx @@ -326,8 +325,9 @@ getNonAdaChange utxos = Ledger.noAdaValue . getChange utxos hasDatum :: TxOut -> Bool hasDatum = isJust . txOutDatumHash --- | Split UTxOs into ones that have data --- and those that don't. +{- | Split UTxOs into ones that have data + and those that don't. +-} splitUtxos :: Map TxOutRef TxOut -> (Map TxOutRef TxOut, Map TxOutRef TxOut) splitUtxos = Map.partition hasDatum @@ -418,7 +418,7 @@ addAdaChange balanceCfg changeAddr change tx { txOutputs = List.reverse $ modifyFirst - (\txout -> Tx.txOutAddress txout == changeAddr && justLovelace (txOutValue txout) && Tx.txOutDatumHash txout == Nothing) + (\txout -> Tx.txOutAddress txout == changeAddr && justLovelace (txOutValue txout) && isNothing (Tx.txOutDatumHash txout)) (fmap $ addValueToTxOut $ Ada.lovelaceValueOf change) (List.reverse $ txOutputs tx) } @@ -426,7 +426,7 @@ addAdaChange balanceCfg changeAddr change tx tx { txOutputs = modifyFirst - (\txout -> Tx.txOutAddress txout == changeAddr && Tx.txOutDatumHash txout == Nothing) + (\txout -> Tx.txOutAddress txout == changeAddr && isNothing (Tx.txOutDatumHash txout)) (fmap $ addValueToTxOut $ Ada.lovelaceValueOf change) (txOutputs tx) } From e50e57a5eb3d49cc2e146351f63e76e8741c36e6 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Fri, 12 Aug 2022 12:04:16 -0400 Subject: [PATCH 04/15] Removed most splitting code. Turns out it was unnecessary and unwanted; instead just left the code that only adds Ada change to UTxOs that don't have datums. All tests pass now. --- src/BotPlutusInterface/Balance.hs | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 10930fa2..84bab0af 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -122,8 +122,9 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = let utxoIndex :: Map TxOutRef TxOut utxoIndex = fmap Tx.toTxOut utxos <> unBalancedTxUtxoIndex unbalancedTx - utxoIndexD, utxoIndexS :: Map TxOutRef TxOut - (utxoIndexD, utxoIndexS) = splitUtxos utxoIndex + -- Partition UTxOs into those with and without datums. + -- utxoIndexD, utxoIndexS :: Map TxOutRef TxOut + -- (utxoIndexD, utxoIndexS) = splitUtxos utxoIndex requiredSigs :: [PubKeyHash] requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx) @@ -151,12 +152,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = else hoistEither $ addSignatories ownPkh privKeys requiredSigs tx -- Balance the tx - -- (balancedTx, minUtxos) <- balanceTxLoop utxoIndex privKeys [] preBalancedTx - (balancedTx, minUtxos) <- balanceTxLoop utxoIndexS privKeys [] preBalancedTx - - let txOuts1 = txOutputs balancedTx - addDatumTxs txos = txos <> Map.elems utxoIndexD - addDatums tx = tx {txOutputs = addDatumTxs (txOutputs tx)} + (balancedTx, minUtxos) <- balanceTxLoop utxoIndex privKeys [] preBalancedTx -- Get current Ada change let adaChange = getAdaChange utxoIndex balancedTx @@ -172,7 +168,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = -- Get the updated change, add it to the tx let finalAdaChange = getAdaChange utxoIndex balancedTxWithChange - fullyBalancedTx = addDatums $ addAdaChange balanceCfg changeAddr finalAdaChange balancedTxWithChange + fullyBalancedTx = addAdaChange balanceCfg changeAddr finalAdaChange balancedTxWithChange txInfoLog = printBpiLog @w (Debug [TxBalancingLog]) $ "UnbalancedTx TxInputs: " @@ -325,11 +321,8 @@ getNonAdaChange utxos = Ledger.noAdaValue . getChange utxos hasDatum :: TxOut -> Bool hasDatum = isJust . txOutDatumHash -{- | Split UTxOs into ones that have data - and those that don't. --} -splitUtxos :: Map TxOutRef TxOut -> (Map TxOutRef TxOut, Map TxOutRef TxOut) -splitUtxos = Map.partition hasDatum +hasNoDatum :: TxOut -> Bool +hasNoDatum = isNothing . txOutDatumHash -- | Add min lovelaces to each tx output addLovelaces :: [(TxOut, Integer)] -> Tx -> Tx @@ -418,7 +411,7 @@ addAdaChange balanceCfg changeAddr change tx { txOutputs = List.reverse $ modifyFirst - (\txout -> Tx.txOutAddress txout == changeAddr && justLovelace (txOutValue txout) && isNothing (Tx.txOutDatumHash txout)) + (\txout -> Tx.txOutAddress txout == changeAddr && justLovelace (txOutValue txout) && hasNoDatum txout) (fmap $ addValueToTxOut $ Ada.lovelaceValueOf change) (List.reverse $ txOutputs tx) } @@ -426,7 +419,7 @@ addAdaChange balanceCfg changeAddr change tx tx { txOutputs = modifyFirst - (\txout -> Tx.txOutAddress txout == changeAddr && isNothing (Tx.txOutDatumHash txout)) + (\txout -> Tx.txOutAddress txout == changeAddr && hasNoDatum txout) (fmap $ addValueToTxOut $ Ada.lovelaceValueOf change) (txOutputs tx) } From f7be4a2ddce15bc43d6b82d343081dee5520ce7b Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Tue, 16 Aug 2022 13:17:54 -0400 Subject: [PATCH 05/15] Added basic "Don't add change" test. Unsure whether it accurately tests whether change isn't added to utxos with datums. --- src/BotPlutusInterface/Balance.hs | 9 ++-- test/Spec/BotPlutusInterface/Balance.hs | 66 ++++++++++++++++++++++--- 2 files changed, 65 insertions(+), 10 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 84bab0af..7b4d2d41 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -45,7 +45,7 @@ import Data.List ((\\)) import Data.List qualified as List import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text @@ -104,7 +104,7 @@ balanceTxIO :: Eff effs (Either Text Tx) balanceTxIO = balanceTxIO' @w defaultBalanceConfig --- | `balanceTxIO'` is more flexible version of `balanceTxIO`, this let us specify custom `BalanceConfig`. +-- | `balanceTxIO'` is more flexible version of `balanceTxIO`, this lets us specify custom `BalanceConfig`. balanceTxIO' :: forall (w :: Type) (effs :: [Type -> Type]). (Member (PABEffect w) effs) => @@ -322,7 +322,7 @@ hasDatum :: TxOut -> Bool hasDatum = isJust . txOutDatumHash hasNoDatum :: TxOut -> Bool -hasNoDatum = isNothing . txOutDatumHash +hasNoDatum = not . hasDatum -- | Add min lovelaces to each tx output addLovelaces :: [(TxOut, Integer)] -> Tx -> Tx @@ -382,8 +382,9 @@ handleNonAdaChange balanceCfg changeAddr utxos tx = ( \txout -> Tx.txOutAddress txout == changeAddr && not (justLovelace $ Tx.txOutValue txout) + && hasNoDatum txout ) - else (\txout -> Tx.txOutAddress txout == changeAddr) + else (\txout -> Tx.txOutAddress txout == changeAddr && hasNoDatum txout) newOutput = TxOut { txOutAddress = changeAddr diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index 3c04b106..7cd49339 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + module Spec.BotPlutusInterface.Balance (tests) where -import BotPlutusInterface.Balance (defaultBalanceConfig, withFee) +import BotPlutusInterface.Balance (balanceTxIO, defaultBalanceConfig, withFee) import BotPlutusInterface.Balance qualified as Balance import BotPlutusInterface.Effects (PABEffect) import Data.Default (Default (def)) @@ -13,11 +16,14 @@ import Ledger.Address (Address, PaymentPubKeyHash (PaymentPubKeyHash)) import Ledger.Address qualified as Address import Ledger.CardanoWallet qualified as Wallet import Ledger.Crypto (PubKeyHash) +import Ledger.Scripts qualified as Scripts import Ledger.Tx (Tx (..), TxIn (..), TxInType (..), TxOut (..), TxOutRef (..)) import Ledger.Value qualified as Value +import Plutus.V1.Ledger.Api qualified as Api +import PlutusTx qualified import Spec.MockContract (runPABEffectPure) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) import Prelude {- | Tests for 'cardano-cli query utxo' result parsers @@ -30,33 +36,50 @@ tests = [ testCase "Add utxos to cover fees" addUtxosForFees , testCase "Add utxos to cover native tokens" addUtxosForNativeTokens , testCase "Add utxos to cover change min utxo" addUtxosForChange + , testCase "Don't add change to UTxOs with datums" dontAddChangeToDatum ] +validator :: Scripts.Validator +validator = + Scripts.mkValidatorScript + $$(PlutusTx.compile [||(\_ _ _ -> ())||]) + +valHash :: Ledger.ValidatorHash +(Just valHash) = Ledger.toValidatorHash addr3 + pkh1, pkh2 :: PubKeyHash pkh1 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 1 pkh2 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 2 -addr1, addr2 :: Address +addr1, addr2, addr3 :: Address addr1 = Ledger.pubKeyHashAddress (PaymentPubKeyHash pkh1) Nothing addr2 = Ledger.pubKeyHashAddress (PaymentPubKeyHash pkh2) Nothing +addr3 = Ledger.scriptAddress validator -txOutRef1, txOutRef2, txOutRef3, txOutRef4 :: TxOutRef +txOutRef1, txOutRef2, txOutRef3, txOutRef4, txOutRef5, txOutRef6, txOutRef7 :: TxOutRef txOutRef1 = TxOutRef "384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 0 txOutRef2 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 1 txOutRef3 = TxOutRef "d8a5630a9d7e913f9d186c95e5138a239a4e79ece3414ac894dbf37280944de3" 0 txOutRef4 = TxOutRef "d8a5630a9d7e913f9d186c95e5138a239a4e79ece3414ac894dbf37280944de3" 2 +txOutRef5 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 0 +txOutRef6 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 3 +txOutRef7 = TxOutRef "384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 1 -txIn1, txIn2, txIn3, txIn4 :: TxIn +txIn1, txIn2, txIn3, txIn4, txIn5 :: TxIn txIn1 = TxIn txOutRef1 (Just ConsumePublicKeyAddress) txIn2 = TxIn txOutRef2 (Just ConsumePublicKeyAddress) txIn3 = TxIn txOutRef3 (Just ConsumePublicKeyAddress) txIn4 = TxIn txOutRef4 (Just ConsumePublicKeyAddress) +txIn5 = TxIn txOutRef5 (Just ConsumeSimpleScriptAddress) -utxo1, utxo2, utxo3, utxo4 :: (TxOutRef, TxOut) +utxo1, utxo2, utxo3, utxo4, utxo5, utxo6, utxo7 :: (TxOutRef, TxOut) utxo1 = (txOutRef1, TxOut addr1 (Ada.lovelaceValueOf 1_100_000) Nothing) utxo2 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 1_000_000) Nothing) utxo3 = (txOutRef3, TxOut addr1 (Ada.lovelaceValueOf 900_000) Nothing) utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.singleton "11223344" "Token" 200) Nothing) +utxo5 = (txOutRef5, TxOut addr3 (Ada.lovelaceValueOf 900_000) (Just $ Ledger.DatumHash "")) +utxo6 = (txOutRef6, TxOut addr3 (Value.singleton "11223344" "Token" 200) Nothing) +utxo7 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 5_000_000) Nothing) addUtxosForFees :: Assertion addUtxosForFees = do @@ -105,3 +128,34 @@ addUtxosForChange = do case ebalancedTx of Left e -> assertFailure (Text.unpack e) Right balancedTx -> txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2]) + +dontAddChangeToDatum :: Assertion +dontAddChangeToDatum = do + let txout = TxOut addr2 (Ada.lovelaceValueOf 1_300_000) Nothing + txout2 = snd utxo5 + txout3 = snd utxo6 + tx = mempty {txOutputs = [txout, txout2, txout3]} `withFee` 500_000 + minUtxo = [(txout, 1_000_000), (txout3, 1_100_000)] -- add change to these utxos + utxoIndex = Map.fromList [utxo5, utxo3, utxo1, utxo4, utxo7] + ownAddr = addr1 + ebalancedTx = + fst $ + runPABEffectPure def $ + Balance.balanceTxStep @() @'[PABEffect ()] defaultBalanceConfig minUtxo utxoIndex ownAddr tx + + case ebalancedTx of + Left e -> assertFailure (Text.unpack e) + Right (Left e) -> assertFailure (Text.unpack e) + Right (Right balancedTx) -> + assertBool + ( "Original UTxO not in output;\n" + <> "TxOuts: " + <> show (txOutputs balancedTx) + <> "\n" + <> "TxIns : " + <> show (txInputs balancedTx) + <> "\n" + ) + $ snd utxo5 `elem` txOutputs balancedTx + +-- txIn5 `Set.member` (txInputs balancedTx) From f0db48449045e4d08c293015eff0debaa7f2c6c0 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Wed, 17 Aug 2022 13:17:36 -0400 Subject: [PATCH 06/15] Started work on proper test for utxo change. Completely replaced former test, haven't yet finished new test. --- test/Spec/BotPlutusInterface/Balance.hs | 106 ++++++++++++++++-------- 1 file changed, 72 insertions(+), 34 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index 7cd49339..e0d48718 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -6,22 +6,42 @@ module Spec.BotPlutusInterface.Balance (tests) where import BotPlutusInterface.Balance (balanceTxIO, defaultBalanceConfig, withFee) import BotPlutusInterface.Balance qualified as Balance import BotPlutusInterface.Effects (PABEffect) +import BotPlutusInterface.Types ( + ContractEnvironment (cePABConfig), + PABConfig (pcOwnPubKeyHash, pcProtocolParams), + ) +import Control.Lens ((&), (.~), (^.)) import Data.Default (Default (def)) import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text +import Data.Void (Void) import Ledger qualified import Ledger.Ada qualified as Ada import Ledger.Address (Address, PaymentPubKeyHash (PaymentPubKeyHash)) import Ledger.Address qualified as Address import Ledger.CardanoWallet qualified as Wallet +import Ledger.Constraints qualified as Constraints import Ledger.Crypto (PubKeyHash) import Ledger.Scripts qualified as Scripts -import Ledger.Tx (Tx (..), TxIn (..), TxInType (..), TxOut (..), TxOutRef (..)) +import Ledger.Tx ( + ChainIndexTxOut (..), + Tx (..), + TxIn (..), + TxInType (..), + TxOut (..), + TxOutRef (..), + ) import Ledger.Value qualified as Value import Plutus.V1.Ledger.Api qualified as Api import PlutusTx qualified -import Spec.MockContract (runPABEffectPure) +import Spec.MockContract ( + MockContractState, + contractEnv, + runContractPure, + runPABEffectPure, + utxos, + ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) import Prelude @@ -45,7 +65,7 @@ validator = $$(PlutusTx.compile [||(\_ _ _ -> ())||]) valHash :: Ledger.ValidatorHash -(Just valHash) = Ledger.toValidatorHash addr3 +valHash = Scripts.validatorHash validator pkh1, pkh2 :: PubKeyHash pkh1 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 1 @@ -72,15 +92,24 @@ txIn3 = TxIn txOutRef3 (Just ConsumePublicKeyAddress) txIn4 = TxIn txOutRef4 (Just ConsumePublicKeyAddress) txIn5 = TxIn txOutRef5 (Just ConsumeSimpleScriptAddress) -utxo1, utxo2, utxo3, utxo4, utxo5, utxo6, utxo7 :: (TxOutRef, TxOut) +utxo1, utxo2, utxo3, utxo4, utxo7 :: (TxOutRef, TxOut) utxo1 = (txOutRef1, TxOut addr1 (Ada.lovelaceValueOf 1_100_000) Nothing) utxo2 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 1_000_000) Nothing) utxo3 = (txOutRef3, TxOut addr1 (Ada.lovelaceValueOf 900_000) Nothing) utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.singleton "11223344" "Token" 200) Nothing) -utxo5 = (txOutRef5, TxOut addr3 (Ada.lovelaceValueOf 900_000) (Just $ Ledger.DatumHash "")) -utxo6 = (txOutRef6, TxOut addr3 (Value.singleton "11223344" "Token" 200) Nothing) +-- utxo5 = (txOutRef5, TxOut addr3 (Ada.lovelaceValueOf 900_000) (Just $ Ledger.DatumHash "")) +-- utxo6 = (txOutRef6, TxOut addr3 (Value.singleton "11223344" "Token" 200) Nothing) utxo7 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 5_000_000) Nothing) +scrValue :: Value.Value +scrValue = (Value.singleton "11223344" "Token" 200) <> (Ada.lovelaceValueOf 500_000) + +scrDatum :: Ledger.Datum +scrDatum = Ledger.Datum $ Api.toBuiltinData (23 :: Integer) + +scrDatumHash :: Ledger.DatumHash +scrDatumHash = Ledger.datumHash scrDatum + addUtxosForFees :: Assertion addUtxosForFees = do let txout = TxOut addr2 (Ada.lovelaceValueOf 1_000_000) Nothing @@ -131,31 +160,40 @@ addUtxosForChange = do dontAddChangeToDatum :: Assertion dontAddChangeToDatum = do - let txout = TxOut addr2 (Ada.lovelaceValueOf 1_300_000) Nothing - txout2 = snd utxo5 - txout3 = snd utxo6 - tx = mempty {txOutputs = [txout, txout2, txout3]} `withFee` 500_000 - minUtxo = [(txout, 1_000_000), (txout3, 1_100_000)] -- add change to these utxos - utxoIndex = Map.fromList [utxo5, utxo3, utxo1, utxo4, utxo7] - ownAddr = addr1 - ebalancedTx = - fst $ - runPABEffectPure def $ - Balance.balanceTxStep @() @'[PABEffect ()] defaultBalanceConfig minUtxo utxoIndex ownAddr tx - - case ebalancedTx of - Left e -> assertFailure (Text.unpack e) - Right (Left e) -> assertFailure (Text.unpack e) - Right (Right balancedTx) -> - assertBool - ( "Original UTxO not in output;\n" - <> "TxOuts: " - <> show (txOutputs balancedTx) - <> "\n" - <> "TxIns : " - <> show (txInputs balancedTx) - <> "\n" - ) - $ snd utxo5 `elem` txOutputs balancedTx - --- txIn5 `Set.member` (txInputs balancedTx) + let scrTxOut' = + ScriptChainIndexTxOut + addr3 + (Right validator) -- (valHash, Just validator) + (Right scrDatum) -- (scrDatumHash, Just scrDatum) + scrValue + scrTxOut = Ledger.toTxOut scrTxOut' + usrTxOut' = + PublicKeyChainIndexTxOut + addr1 + (Ada.lovelaceValueOf 5_000_000) + usrTxOut = Ledger.toTxOut usrTxOut' + -- initState :: MockContractState () + initState = + def & utxos .~ [(txOutRef6, scrTxOut), (txOutRef7, usrTxOut)] + & contractEnv .~ contractEnv' + pabConf :: PABConfig + pabConf = def {pcOwnPubKeyHash = pkh1} + -- contractEnv' :: ContractEnvironment () + contractEnv' = def {cePABConfig = pabConf} + + -- TODO: set these up. + scrLkups = mempty + txConsts = mempty + + eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts + + case eunbalancedTx of + Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr) + Right unbalancedTx -> do + let (eRslt, finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh1 unbalancedTx) + case eRslt of + (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) + (Right (Left txt)) -> assertFailure ("Balancing error: " <> Text.unpack txt) + (Right (Right trx)) -> do + -- TODO + assertFailure "Incomplete Test" From 2ff844d93d934ac953ae9713a81baa23b9c71c9b Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Fri, 19 Aug 2022 12:01:04 -0400 Subject: [PATCH 07/15] Fixed issue with missing key / fixed constraints. Still need to write actual test. --- test/Spec/BotPlutusInterface/Balance.hs | 33 +++++++++++++++---------- 1 file changed, 20 insertions(+), 13 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index e0d48718..7e49bfef 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -38,6 +38,9 @@ import PlutusTx qualified import Spec.MockContract ( MockContractState, contractEnv, + paymentPkh3, + pkh3, + pkhAddr3, runContractPure, runPABEffectPure, utxos, @@ -71,10 +74,10 @@ pkh1, pkh2 :: PubKeyHash pkh1 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 1 pkh2 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 2 -addr1, addr2, addr3 :: Address +addr1, addr2, valAddr :: Address addr1 = Ledger.pubKeyHashAddress (PaymentPubKeyHash pkh1) Nothing addr2 = Ledger.pubKeyHashAddress (PaymentPubKeyHash pkh2) Nothing -addr3 = Ledger.scriptAddress validator +valAddr = Ledger.scriptAddress validator txOutRef1, txOutRef2, txOutRef3, txOutRef4, txOutRef5, txOutRef6, txOutRef7 :: TxOutRef txOutRef1 = TxOutRef "384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 0 @@ -102,7 +105,7 @@ utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.singleton utxo7 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 5_000_000) Nothing) scrValue :: Value.Value -scrValue = (Value.singleton "11223344" "Token" 200) <> (Ada.lovelaceValueOf 500_000) +scrValue = Value.singleton "11223344" "Token" 200 <> Ada.lovelaceValueOf 500_000 scrDatum :: Ledger.Datum scrDatum = Ledger.Datum $ Api.toBuiltinData (23 :: Integer) @@ -162,14 +165,14 @@ dontAddChangeToDatum :: Assertion dontAddChangeToDatum = do let scrTxOut' = ScriptChainIndexTxOut - addr3 + valAddr (Right validator) -- (valHash, Just validator) (Right scrDatum) -- (scrDatumHash, Just scrDatum) scrValue scrTxOut = Ledger.toTxOut scrTxOut' usrTxOut' = PublicKeyChainIndexTxOut - addr1 + pkhAddr3 (Ada.lovelaceValueOf 5_000_000) usrTxOut = Ledger.toTxOut usrTxOut' -- initState :: MockContractState () @@ -177,23 +180,27 @@ dontAddChangeToDatum = do def & utxos .~ [(txOutRef6, scrTxOut), (txOutRef7, usrTxOut)] & contractEnv .~ contractEnv' pabConf :: PABConfig - pabConf = def {pcOwnPubKeyHash = pkh1} + pabConf = def {pcOwnPubKeyHash = pkh3} -- contractEnv' :: ContractEnvironment () contractEnv' = def {cePABConfig = pabConf} - -- TODO: set these up. - scrLkups = mempty - txConsts = mempty - + scrLkups = + Constraints.unspentOutputs (Map.fromList [(txOutRef6, scrTxOut'), (txOutRef7, usrTxOut')]) + <> Constraints.ownPaymentPubKeyHash paymentPkh3 + txConsts = + -- Pay the same datum to the script, but with more ada. + Constraints.mustPayToOtherScript valHash scrDatum (scrValue <> Ada.lovelaceValueOf 1_000_000) + <> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer + <> Constraints.mustSpendPubKeyOutput txOutRef7 eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts case eunbalancedTx of Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr) Right unbalancedTx -> do - let (eRslt, finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh1 unbalancedTx) + let (eRslt, finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) case eRslt of (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) - (Right (Left txt)) -> assertFailure ("Balancing error: " <> Text.unpack txt) + (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt -- <> "\n(Tx: " <> show unbalancedTx <> ")" (Right (Right trx)) -> do - -- TODO + -- TODO: Write the actual test. assertFailure "Incomplete Test" From 48329eb0766c0faa78fbfbcac066b9c75ca5b166 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Fri, 19 Aug 2022 12:41:05 -0400 Subject: [PATCH 08/15] Wrote actual test for UTxO change. Unfortunately, it fails. Unsure if this is an issue with the balancing code, or with the constraints used to construct the Tx. --- test/Spec/BotPlutusInterface/Balance.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index 7e49bfef..0a1561c0 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -41,7 +41,7 @@ import Spec.MockContract ( paymentPkh3, pkh3, pkhAddr3, - runContractPure, + -- runContractPure, runPABEffectPure, utxos, ) @@ -197,10 +197,17 @@ dontAddChangeToDatum = do case eunbalancedTx of Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr) Right unbalancedTx -> do - let (eRslt, finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) + let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) case eRslt of (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt -- <> "\n(Tx: " <> show unbalancedTx <> ")" (Right (Right trx)) -> do -- TODO: Write the actual test. - assertFailure "Incomplete Test" + assertBool + ( "Original UTxO not in output Tx." + <> "\nOriginal UTxO: " + <> show scrTxOut + <> "\nNew UTxOs: " + <> show (txOutputs trx) + ) + (scrTxOut `elem` txOutputs trx) From cb16ad76d1de1953670c686ef139fe95cf99ff74 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Fri, 19 Aug 2022 15:07:37 -0400 Subject: [PATCH 09/15] UTxO change test now passes. Unsure whether it correctly tests the condition, but it seems to. --- test/Spec/BotPlutusInterface/Balance.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index 0a1561c0..ab335fae 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -10,7 +10,7 @@ import BotPlutusInterface.Types ( ContractEnvironment (cePABConfig), PABConfig (pcOwnPubKeyHash, pcProtocolParams), ) -import Control.Lens ((&), (.~), (^.)) +import Control.Lens ((&), (.~), (<>~), (^.)) import Data.Default (Default (def)) import Data.Map qualified as Map import Data.Set qualified as Set @@ -22,6 +22,7 @@ import Ledger.Address (Address, PaymentPubKeyHash (PaymentPubKeyHash)) import Ledger.Address qualified as Address import Ledger.CardanoWallet qualified as Wallet import Ledger.Constraints qualified as Constraints +import Ledger.Constraints.OffChain qualified as OffChain import Ledger.Crypto (PubKeyHash) import Ledger.Scripts qualified as Scripts import Ledger.Tx ( @@ -173,7 +174,7 @@ dontAddChangeToDatum = do usrTxOut' = PublicKeyChainIndexTxOut pkhAddr3 - (Ada.lovelaceValueOf 5_000_000) + (Ada.lovelaceValueOf 1_001_000) usrTxOut = Ledger.toTxOut usrTxOut' -- initState :: MockContractState () initState = @@ -189,7 +190,9 @@ dontAddChangeToDatum = do <> Constraints.ownPaymentPubKeyHash paymentPkh3 txConsts = -- Pay the same datum to the script, but with more ada. - Constraints.mustPayToOtherScript valHash scrDatum (scrValue <> Ada.lovelaceValueOf 1_000_000) + Constraints.mustPayToOtherScript valHash scrDatum (scrValue <> Ada.lovelaceValueOf 500) + -- <> Constraints.mustPayToOtherScript valHash scrDatum (Ada.lovelaceValueOf 1_000_000) + <> Constraints.mustPayToPubKey paymentPkh3 (Ada.lovelaceValueOf 1_000_000) <> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer <> Constraints.mustSpendPubKeyOutput txOutRef7 eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts @@ -202,12 +205,15 @@ dontAddChangeToDatum = do (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt -- <> "\n(Tx: " <> show unbalancedTx <> ")" (Right (Right trx)) -> do - -- TODO: Write the actual test. + let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue <>~ Ada.lovelaceValueOf 500 + scrTxOutNew = Ledger.toTxOut scrTxOut'' assertBool ( "Original UTxO not in output Tx." <> "\nOriginal UTxO: " <> show scrTxOut <> "\nNew UTxOs: " <> show (txOutputs trx) + <> "\nUnbalanced UTxOs: " + <> show (txOutputs (unbalancedTx ^. OffChain.tx)) ) - (scrTxOut `elem` txOutputs trx) + (scrTxOutNew `elem` txOutputs trx) From 6df20aa933c7a70dbf075d71884dd66b159f89f3 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Mon, 22 Aug 2022 12:41:14 -0400 Subject: [PATCH 10/15] Added second test for UTxO change. This test shows that if an input UTxO has more ADA or Tokens than needed, and is being sent (with a datum) to a script address, the excess value won't go with it. --- test/Spec/BotPlutusInterface/Balance.hs | 84 +++++++++++++++++++++++-- 1 file changed, 80 insertions(+), 4 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index ab335fae..7ae530f3 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -60,7 +60,8 @@ tests = [ testCase "Add utxos to cover fees" addUtxosForFees , testCase "Add utxos to cover native tokens" addUtxosForNativeTokens , testCase "Add utxos to cover change min utxo" addUtxosForChange - , testCase "Don't add change to UTxOs with datums" dontAddChangeToDatum + , testCase "Don't add change to UTxOs with datums (1)" dontAddChangeToDatum + , testCase "Don't add change to UTxOs with datums (2)" dontAddChangeToDatum2 ] validator :: Scripts.Validator @@ -108,6 +109,9 @@ utxo7 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 5_000_000) Nothing) scrValue :: Value.Value scrValue = Value.singleton "11223344" "Token" 200 <> Ada.lovelaceValueOf 500_000 +scrValue' :: Value.Value +scrValue' = Value.singleton "11223344" "Token" 100 <> Ada.lovelaceValueOf 500_000 + scrDatum :: Ledger.Datum scrDatum = Ledger.Datum $ Api.toBuiltinData (23 :: Integer) @@ -185,6 +189,25 @@ dontAddChangeToDatum = do -- contractEnv' :: ContractEnvironment () contractEnv' = def {cePABConfig = pabConf} + -- Input UTxOs: + -- UTxO 1: + -- - From: User + -- - Amt : 1.001 ADA + -- UTxO 2: + -- - From: Script + -- - Amt : 0.5 ADA + 200 Tokens + -- + -- Output UTxOs: + -- UTxO 1: + -- - To : User + -- - Amt: 1 ADA + -- UTxO 2: + -- - To : Script + -- - Amt: 1.0005 Ada + 200 Token + -- + -- Fees : 400 Lovelace + -- Change : 100 Lovelace + scrLkups = Constraints.unspentOutputs (Map.fromList [(txOutRef6, scrTxOut'), (txOutRef7, usrTxOut')]) <> Constraints.ownPaymentPubKeyHash paymentPkh3 @@ -208,9 +231,62 @@ dontAddChangeToDatum = do let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue <>~ Ada.lovelaceValueOf 500 scrTxOutNew = Ledger.toTxOut scrTxOut'' assertBool - ( "Original UTxO not in output Tx." - <> "\nOriginal UTxO: " - <> show scrTxOut + ( "Expected UTxO not in output Tx." + <> "\nExpected UTxO: " + <> show scrTxOutNew + <> "\nNew UTxOs: " + <> show (txOutputs trx) + <> "\nUnbalanced UTxOs: " + <> show (txOutputs (unbalancedTx ^. OffChain.tx)) + ) + (scrTxOutNew `elem` txOutputs trx) + +-- Like the first one, but +-- only has inputs from the script. +dontAddChangeToDatum2 :: Assertion +dontAddChangeToDatum2 = do + let scrTxOut' = + ScriptChainIndexTxOut + valAddr + (Right validator) -- (valHash, Just validator) + (Right scrDatum) -- (scrDatumHash, Just scrDatum) + (scrValue <> Ada.lovelaceValueOf 1_500_000) + scrTxOut = Ledger.toTxOut scrTxOut' + -- initState :: MockContractState () + initState = + def & utxos .~ [(txOutRef6, scrTxOut)] + & contractEnv .~ contractEnv' + pabConf :: PABConfig + pabConf = def {pcOwnPubKeyHash = pkh3} + -- contractEnv' :: ContractEnvironment () + contractEnv' = def {cePABConfig = pabConf} + + scrLkups = + Constraints.unspentOutputs (Map.fromList [(txOutRef6, scrTxOut')]) + <> Constraints.ownPaymentPubKeyHash paymentPkh3 + txConsts = + -- Pay the same datum to the script, but with LESS ada + -- and fewer tokens. This is to ensure that the excess + -- ADA and tokens are moved into their own UTxO(s), + -- (The extra ada is used to cover fees etc...) + Constraints.mustPayToOtherScript valHash scrDatum scrValue' + <> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer + eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts + + case eunbalancedTx of + Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr) + Right unbalancedTx -> do + let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) + case eRslt of + (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) + (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt -- <> "\n(Tx: " <> show unbalancedTx <> ")" + (Right (Right trx)) -> do + let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue .~ scrValue' + scrTxOutNew = Ledger.toTxOut scrTxOut'' + assertBool + ( "Expected UTxO not in output Tx." + <> "\nExpected UTxO: " + <> show scrTxOutNew <> "\nNew UTxOs: " <> show (txOutputs trx) <> "\nUnbalanced UTxOs: " From 904c3e52a0b826e157f1aed2f7637328be61476c Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Tue, 23 Aug 2022 10:17:30 -0400 Subject: [PATCH 11/15] Some minor changes. Mostly just removing comments. --- src/BotPlutusInterface/Balance.hs | 4 --- test/Spec/BotPlutusInterface/Balance.hs | 46 +++++++++++++++---------- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 7b4d2d41..fc215358 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -122,10 +122,6 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = let utxoIndex :: Map TxOutRef TxOut utxoIndex = fmap Tx.toTxOut utxos <> unBalancedTxUtxoIndex unbalancedTx - -- Partition UTxOs into those with and without datums. - -- utxoIndexD, utxoIndexS :: Map TxOutRef TxOut - -- (utxoIndexD, utxoIndexS) = splitUtxos utxoIndex - requiredSigs :: [PubKeyHash] requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index 7ae530f3..be02c64e 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -171,8 +171,8 @@ dontAddChangeToDatum = do let scrTxOut' = ScriptChainIndexTxOut valAddr - (Right validator) -- (valHash, Just validator) - (Right scrDatum) -- (scrDatumHash, Just scrDatum) + (Right validator) + (Right scrDatum) scrValue scrTxOut = Ledger.toTxOut scrTxOut' usrTxOut' = @@ -180,13 +180,13 @@ dontAddChangeToDatum = do pkhAddr3 (Ada.lovelaceValueOf 1_001_000) usrTxOut = Ledger.toTxOut usrTxOut' - -- initState :: MockContractState () + initState :: MockContractState () initState = def & utxos .~ [(txOutRef6, scrTxOut), (txOutRef7, usrTxOut)] & contractEnv .~ contractEnv' pabConf :: PABConfig pabConf = def {pcOwnPubKeyHash = pkh3} - -- contractEnv' :: ContractEnvironment () + contractEnv' :: ContractEnvironment () contractEnv' = def {cePABConfig = pabConf} -- Input UTxOs: @@ -203,7 +203,7 @@ dontAddChangeToDatum = do -- - Amt: 1 ADA -- UTxO 2: -- - To : Script - -- - Amt: 1.0005 Ada + 200 Token + -- - Amt: 0.5005 Ada + 200 Token -- -- Fees : 400 Lovelace -- Change : 100 Lovelace @@ -214,7 +214,6 @@ dontAddChangeToDatum = do txConsts = -- Pay the same datum to the script, but with more ada. Constraints.mustPayToOtherScript valHash scrDatum (scrValue <> Ada.lovelaceValueOf 500) - -- <> Constraints.mustPayToOtherScript valHash scrDatum (Ada.lovelaceValueOf 1_000_000) <> Constraints.mustPayToPubKey paymentPkh3 (Ada.lovelaceValueOf 1_000_000) <> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer <> Constraints.mustSpendPubKeyOutput txOutRef7 @@ -226,20 +225,20 @@ dontAddChangeToDatum = do let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) case eRslt of (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) - (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt -- <> "\n(Tx: " <> show unbalancedTx <> ")" + (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt (Right (Right trx)) -> do let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue <>~ Ada.lovelaceValueOf 500 - scrTxOutNew = Ledger.toTxOut scrTxOut'' + scrTxOutExpected = Ledger.toTxOut scrTxOut'' assertBool ( "Expected UTxO not in output Tx." <> "\nExpected UTxO: " - <> show scrTxOutNew + <> show scrTxOutExpected <> "\nNew UTxOs: " <> show (txOutputs trx) <> "\nUnbalanced UTxOs: " <> show (txOutputs (unbalancedTx ^. OffChain.tx)) ) - (scrTxOutNew `elem` txOutputs trx) + (scrTxOutExpected `elem` txOutputs trx) -- Like the first one, but -- only has inputs from the script. @@ -248,19 +247,29 @@ dontAddChangeToDatum2 = do let scrTxOut' = ScriptChainIndexTxOut valAddr - (Right validator) -- (valHash, Just validator) - (Right scrDatum) -- (scrDatumHash, Just scrDatum) + (Right validator) + (Right scrDatum) (scrValue <> Ada.lovelaceValueOf 1_500_000) scrTxOut = Ledger.toTxOut scrTxOut' - -- initState :: MockContractState () + initState :: MockContractState () initState = def & utxos .~ [(txOutRef6, scrTxOut)] & contractEnv .~ contractEnv' pabConf :: PABConfig pabConf = def {pcOwnPubKeyHash = pkh3} - -- contractEnv' :: ContractEnvironment () + contractEnv' :: ContractEnvironment () contractEnv' = def {cePABConfig = pabConf} + -- Input UTxO : + -- - 2.0 ADA + -- - 200 tokens + -- Output UTxO : + -- - 0.5 ADA + -- - 100 tokens + -- Change: + -- - 1.5 ADA (400 Lovelace to fees) + -- - 100 tokens + scrLkups = Constraints.unspentOutputs (Map.fromList [(txOutRef6, scrTxOut')]) <> Constraints.ownPaymentPubKeyHash paymentPkh3 @@ -268,6 +277,7 @@ dontAddChangeToDatum2 = do -- Pay the same datum to the script, but with LESS ada -- and fewer tokens. This is to ensure that the excess -- ADA and tokens are moved into their own UTxO(s), + -- rather than just being left in the original UTxO. -- (The extra ada is used to cover fees etc...) Constraints.mustPayToOtherScript valHash scrDatum scrValue' <> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer @@ -279,17 +289,17 @@ dontAddChangeToDatum2 = do let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) case eRslt of (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) - (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt -- <> "\n(Tx: " <> show unbalancedTx <> ")" + (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt (Right (Right trx)) -> do let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue .~ scrValue' - scrTxOutNew = Ledger.toTxOut scrTxOut'' + scrTxOutExpected = Ledger.toTxOut scrTxOut'' assertBool ( "Expected UTxO not in output Tx." <> "\nExpected UTxO: " - <> show scrTxOutNew + <> show scrTxOutExpected <> "\nNew UTxOs: " <> show (txOutputs trx) <> "\nUnbalanced UTxOs: " <> show (txOutputs (unbalancedTx ^. OffChain.tx)) ) - (scrTxOutNew `elem` txOutputs trx) + (scrTxOutExpected `elem` txOutputs trx) From e569941c1cb1b317294f09579b32d8ff3ec08f16 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Tue, 23 Aug 2022 12:29:37 -0400 Subject: [PATCH 12/15] Improved test clarity, among other things. Test error messages now separate result UTxOs into those bound for the script vs. those going anywhere else. Also, the second test now checks that the remaining change is indeed part of the balanced tx, and doesn't just disappear. --- test/Spec/BotPlutusInterface/Balance.hs | 77 ++++++++++++++++++++++--- 1 file changed, 68 insertions(+), 9 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index be02c64e..dbe93f42 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -12,6 +12,8 @@ import BotPlutusInterface.Types ( ) import Control.Lens ((&), (.~), (<>~), (^.)) import Data.Default (Default (def)) +import Data.Function (on) +import Data.List (delete, partition) import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text @@ -33,6 +35,7 @@ import Ledger.Tx ( TxOut (..), TxOutRef (..), ) +import Ledger.Value (AssetClass, Value) import Ledger.Value qualified as Value import Plutus.V1.Ledger.Api qualified as Api import PlutusTx qualified @@ -101,16 +104,16 @@ utxo1, utxo2, utxo3, utxo4, utxo7 :: (TxOutRef, TxOut) utxo1 = (txOutRef1, TxOut addr1 (Ada.lovelaceValueOf 1_100_000) Nothing) utxo2 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 1_000_000) Nothing) utxo3 = (txOutRef3, TxOut addr1 (Ada.lovelaceValueOf 900_000) Nothing) -utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.singleton "11223344" "Token" 200) Nothing) +utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.assetClassValue tokenAsset 200) Nothing) -- utxo5 = (txOutRef5, TxOut addr3 (Ada.lovelaceValueOf 900_000) (Just $ Ledger.DatumHash "")) -- utxo6 = (txOutRef6, TxOut addr3 (Value.singleton "11223344" "Token" 200) Nothing) utxo7 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 5_000_000) Nothing) scrValue :: Value.Value -scrValue = Value.singleton "11223344" "Token" 200 <> Ada.lovelaceValueOf 500_000 +scrValue = Value.assetClassValue tokenAsset 200 <> Ada.lovelaceValueOf 500_000 scrValue' :: Value.Value -scrValue' = Value.singleton "11223344" "Token" 100 <> Ada.lovelaceValueOf 500_000 +scrValue' = Value.assetClassValue tokenAsset 120 <> Ada.lovelaceValueOf 500_000 scrDatum :: Ledger.Datum scrDatum = Ledger.Datum $ Api.toBuiltinData (23 :: Integer) @@ -118,6 +121,16 @@ scrDatum = Ledger.Datum $ Api.toBuiltinData (23 :: Integer) scrDatumHash :: Ledger.DatumHash scrDatumHash = Ledger.datumHash scrDatum +acValueOf :: AssetClass -> Value -> Integer +acValueOf = flip Value.assetClassValueOf + +-- | Get the amount of lovelace in a `Value`. +lovelaceInValue :: Value -> Integer +lovelaceInValue = acValueOf (Value.assetClass Api.adaSymbol Api.adaToken) + +tokenAsset :: Value.AssetClass +tokenAsset = Value.assetClass "11223344" "Token" + addUtxosForFees :: Assertion addUtxosForFees = do let txout = TxOut addr2 (Ada.lovelaceValueOf 1_000_000) Nothing @@ -229,12 +242,17 @@ dontAddChangeToDatum = do (Right (Right trx)) -> do let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue <>~ Ada.lovelaceValueOf 500 scrTxOutExpected = Ledger.toTxOut scrTxOut'' + isScrUtxo :: TxOut -> Bool + isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected + (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx) assertBool ( "Expected UTxO not in output Tx." <> "\nExpected UTxO: " <> show scrTxOutExpected - <> "\nNew UTxOs: " - <> show (txOutputs trx) + <> "\nBalanced Script UTxOs: " + <> show balScrUtxos + <> "\nOther Balanced UTxOs: " + <> show balOtherUtxos <> "\nUnbalanced UTxOs: " <> show (txOutputs (unbalancedTx ^. OffChain.tx)) ) @@ -265,10 +283,10 @@ dontAddChangeToDatum2 = do -- - 200 tokens -- Output UTxO : -- - 0.5 ADA - -- - 100 tokens + -- - 120 tokens -- Change: -- - 1.5 ADA (400 Lovelace to fees) - -- - 100 tokens + -- - 80 tokens scrLkups = Constraints.unspentOutputs (Map.fromList [(txOutRef6, scrTxOut')]) @@ -293,13 +311,54 @@ dontAddChangeToDatum2 = do (Right (Right trx)) -> do let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue .~ scrValue' scrTxOutExpected = Ledger.toTxOut scrTxOut'' + isScrUtxo :: TxOut -> Bool + isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected + (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx) + -- Check that the expected script UTxO + -- is in the output. assertBool ( "Expected UTxO not in output Tx." <> "\nExpected UTxO: " <> show scrTxOutExpected - <> "\nNew UTxOs: " - <> show (txOutputs trx) + <> "\nBalanced Script UTxOs: " + <> show balScrUtxos + <> "\nOther Balanced UTxOs: " + <> show balOtherUtxos <> "\nUnbalanced UTxOs: " <> show (txOutputs (unbalancedTx ^. OffChain.tx)) ) (scrTxOutExpected `elem` txOutputs trx) + -- Check that the output has the remaining change + let trxFee = txFee trx + adaChange' :: Integer + adaChange' = ((-) `on` (lovelaceInValue . txOutValue)) scrTxOut scrTxOutExpected + adaChange :: Integer + adaChange = adaChange' - lovelaceInValue trxFee + tokChange :: Integer + tokChange = ((-) `on` (acValueOf tokenAsset . txOutValue)) scrTxOut scrTxOutExpected + remainingTxOuts :: [TxOut] + remainingTxOuts = delete scrTxOutExpected (txOutputs trx) + remainingValue :: Value.Value + remainingValue = foldMap txOutValue remainingTxOuts + -- Check for ADA change + assertBool + ( "Other UTxOs do not contain expected ADA change." + <> "\nExpected Amount : " + <> show adaChange + <> " Lovelace" + <> "\nActual Amount : " + <> show (lovelaceInValue remainingValue) + <> " Lovelace" + ) + (adaChange == lovelaceInValue remainingValue) + -- Check for Token change + assertBool + ( "Other UTxOs do not contain expected Token change." + <> "\nExpected Amount : " + <> show tokChange + <> " tokens" + <> "\nActual Amount : " + <> show (acValueOf tokenAsset remainingValue) + <> " tokens" + ) + (tokChange == acValueOf tokenAsset remainingValue) From e2a0217bbe4c1044ff45646f1b248c912dd72a73 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Tue, 23 Aug 2022 12:48:12 -0400 Subject: [PATCH 13/15] Removed some unused code. --- test/Spec/BotPlutusInterface/Balance.hs | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index dbe93f42..41d3d5ed 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -8,7 +8,7 @@ import BotPlutusInterface.Balance qualified as Balance import BotPlutusInterface.Effects (PABEffect) import BotPlutusInterface.Types ( ContractEnvironment (cePABConfig), - PABConfig (pcOwnPubKeyHash, pcProtocolParams), + PABConfig (pcOwnPubKeyHash), ) import Control.Lens ((&), (.~), (<>~), (^.)) import Data.Default (Default (def)) @@ -93,21 +93,17 @@ txOutRef5 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797 txOutRef6 = TxOutRef "52a003b3f4956433429631afe4002f82a924a5a7a891db7ae1f6434797a57dff" 3 txOutRef7 = TxOutRef "384de3f29396fdf687551e3f9e05bd400adcd277720c71f1d2b61f17f5183e51" 1 -txIn1, txIn2, txIn3, txIn4, txIn5 :: TxIn +txIn1, txIn2, txIn3, txIn4 :: TxIn txIn1 = TxIn txOutRef1 (Just ConsumePublicKeyAddress) txIn2 = TxIn txOutRef2 (Just ConsumePublicKeyAddress) txIn3 = TxIn txOutRef3 (Just ConsumePublicKeyAddress) txIn4 = TxIn txOutRef4 (Just ConsumePublicKeyAddress) -txIn5 = TxIn txOutRef5 (Just ConsumeSimpleScriptAddress) -utxo1, utxo2, utxo3, utxo4, utxo7 :: (TxOutRef, TxOut) +utxo1, utxo2, utxo3, utxo4 :: (TxOutRef, TxOut) utxo1 = (txOutRef1, TxOut addr1 (Ada.lovelaceValueOf 1_100_000) Nothing) utxo2 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 1_000_000) Nothing) utxo3 = (txOutRef3, TxOut addr1 (Ada.lovelaceValueOf 900_000) Nothing) utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.assetClassValue tokenAsset 200) Nothing) --- utxo5 = (txOutRef5, TxOut addr3 (Ada.lovelaceValueOf 900_000) (Just $ Ledger.DatumHash "")) --- utxo6 = (txOutRef6, TxOut addr3 (Value.singleton "11223344" "Token" 200) Nothing) -utxo7 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 5_000_000) Nothing) scrValue :: Value.Value scrValue = Value.assetClassValue tokenAsset 200 <> Ada.lovelaceValueOf 500_000 From 92bf04380e78df2dbc244782a77b64d7f8e96375 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Thu, 25 Aug 2022 10:37:13 -0400 Subject: [PATCH 14/15] Flattened case statements. Since `assertFailure` throws an error, you don't actually have to case the rest of the do-block. --- test/Spec/BotPlutusInterface/Balance.hs | 169 ++++++++++++------------ 1 file changed, 83 insertions(+), 86 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index 41d3d5ed..4f4cc82e 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -228,31 +228,27 @@ dontAddChangeToDatum = do <> Constraints.mustSpendPubKeyOutput txOutRef7 eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts - case eunbalancedTx of - Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr) - Right unbalancedTx -> do - let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) - case eRslt of - (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) - (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt - (Right (Right trx)) -> do - let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue <>~ Ada.lovelaceValueOf 500 - scrTxOutExpected = Ledger.toTxOut scrTxOut'' - isScrUtxo :: TxOut -> Bool - isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected - (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx) - assertBool - ( "Expected UTxO not in output Tx." - <> "\nExpected UTxO: " - <> show scrTxOutExpected - <> "\nBalanced Script UTxOs: " - <> show balScrUtxos - <> "\nOther Balanced UTxOs: " - <> show balOtherUtxos - <> "\nUnbalanced UTxOs: " - <> show (txOutputs (unbalancedTx ^. OffChain.tx)) - ) - (scrTxOutExpected `elem` txOutputs trx) + unbalancedTx <- liftAssertFailure eunbalancedTx (\err -> "MkTx Error: " <> show err) + let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) + eRslt' <- liftAssertFailure eRslt (\txt -> "PAB effect error: " <> Text.unpack txt) + trx <- liftAssertFailure eRslt' (\txt -> "Balancing error: " <> Text.unpack txt) + let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue <>~ Ada.lovelaceValueOf 500 + scrTxOutExpected = Ledger.toTxOut scrTxOut'' + isScrUtxo :: TxOut -> Bool + isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected + (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx) + assertBool + ( "Expected UTxO not in output Tx." + <> "\nExpected UTxO: " + <> show scrTxOutExpected + <> "\nBalanced Script UTxOs: " + <> show balScrUtxos + <> "\nOther Balanced UTxOs: " + <> show balOtherUtxos + <> "\nUnbalanced UTxOs: " + <> show (txOutputs (unbalancedTx ^. OffChain.tx)) + ) + (scrTxOutExpected `elem` txOutputs trx) -- Like the first one, but -- only has inputs from the script. @@ -297,64 +293,65 @@ dontAddChangeToDatum2 = do <> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts - case eunbalancedTx of - Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr) - Right unbalancedTx -> do - let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) - case eRslt of - (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt) - (Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt - (Right (Right trx)) -> do - let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue .~ scrValue' - scrTxOutExpected = Ledger.toTxOut scrTxOut'' - isScrUtxo :: TxOut -> Bool - isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected - (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx) - -- Check that the expected script UTxO - -- is in the output. - assertBool - ( "Expected UTxO not in output Tx." - <> "\nExpected UTxO: " - <> show scrTxOutExpected - <> "\nBalanced Script UTxOs: " - <> show balScrUtxos - <> "\nOther Balanced UTxOs: " - <> show balOtherUtxos - <> "\nUnbalanced UTxOs: " - <> show (txOutputs (unbalancedTx ^. OffChain.tx)) - ) - (scrTxOutExpected `elem` txOutputs trx) - -- Check that the output has the remaining change - let trxFee = txFee trx - adaChange' :: Integer - adaChange' = ((-) `on` (lovelaceInValue . txOutValue)) scrTxOut scrTxOutExpected - adaChange :: Integer - adaChange = adaChange' - lovelaceInValue trxFee - tokChange :: Integer - tokChange = ((-) `on` (acValueOf tokenAsset . txOutValue)) scrTxOut scrTxOutExpected - remainingTxOuts :: [TxOut] - remainingTxOuts = delete scrTxOutExpected (txOutputs trx) - remainingValue :: Value.Value - remainingValue = foldMap txOutValue remainingTxOuts - -- Check for ADA change - assertBool - ( "Other UTxOs do not contain expected ADA change." - <> "\nExpected Amount : " - <> show adaChange - <> " Lovelace" - <> "\nActual Amount : " - <> show (lovelaceInValue remainingValue) - <> " Lovelace" - ) - (adaChange == lovelaceInValue remainingValue) - -- Check for Token change - assertBool - ( "Other UTxOs do not contain expected Token change." - <> "\nExpected Amount : " - <> show tokChange - <> " tokens" - <> "\nActual Amount : " - <> show (acValueOf tokenAsset remainingValue) - <> " tokens" - ) - (tokChange == acValueOf tokenAsset remainingValue) + unbalancedTx <- liftAssertFailure eunbalancedTx (\err -> "MkTx Error: " <> show err) + let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx) + eRslt' <- liftAssertFailure eRslt (\txt -> "PAB effect error: " <> Text.unpack txt) + trx <- liftAssertFailure eRslt' (\txt -> "Balancing error: " <> Text.unpack txt) + let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue .~ scrValue' + scrTxOutExpected = Ledger.toTxOut scrTxOut'' + isScrUtxo :: TxOut -> Bool + isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected + (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx) + -- Check that the expected script UTxO + -- is in the output. + assertBool + ( "Expected UTxO not in output Tx." + <> "\nExpected UTxO: " + <> show scrTxOutExpected + <> "\nBalanced Script UTxOs: " + <> show balScrUtxos + <> "\nOther Balanced UTxOs: " + <> show balOtherUtxos + <> "\nUnbalanced UTxOs: " + <> show (txOutputs (unbalancedTx ^. OffChain.tx)) + ) + (scrTxOutExpected `elem` txOutputs trx) + -- Check that the output has the remaining change + let trxFee = txFee trx + adaChange' :: Integer + adaChange' = ((-) `on` (lovelaceInValue . txOutValue)) scrTxOut scrTxOutExpected + adaChange :: Integer + adaChange = adaChange' - lovelaceInValue trxFee + tokChange :: Integer + tokChange = ((-) `on` (acValueOf tokenAsset . txOutValue)) scrTxOut scrTxOutExpected + remainingTxOuts :: [TxOut] + remainingTxOuts = delete scrTxOutExpected (txOutputs trx) + remainingValue :: Value.Value + remainingValue = foldMap txOutValue remainingTxOuts + -- Check for ADA change + assertBool + ( "Other UTxOs do not contain expected ADA change." + <> "\nExpected Amount : " + <> show adaChange + <> " Lovelace" + <> "\nActual Amount : " + <> show (lovelaceInValue remainingValue) + <> " Lovelace" + ) + (adaChange == lovelaceInValue remainingValue) + -- Check for Token change + assertBool + ( "Other UTxOs do not contain expected Token change." + <> "\nExpected Amount : " + <> show tokChange + <> " tokens" + <> "\nActual Amount : " + <> show (acValueOf tokenAsset remainingValue) + <> " tokens" + ) + (tokChange == acValueOf tokenAsset remainingValue) + +-- | Lift an `Either` value into an `assertFailure`. +liftAssertFailure :: Either a b -> (a -> String) -> IO b +liftAssertFailure (Left err) fstr = assertFailure (fstr err) +liftAssertFailure (Right rslt) _ = return rslt From b3127f985810b8a86e3420698be42c9e79e93fc4 Mon Sep 17 00:00:00 2001 From: David Wilson <30732161+Anteproperispomenon@users.noreply.github.com> Date: Thu, 25 Aug 2022 11:26:48 -0400 Subject: [PATCH 15/15] Used `printf` for some error messages. --- test/Spec/BotPlutusInterface/Balance.hs | 33 ++++++++++--------------- 1 file changed, 13 insertions(+), 20 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index 4f4cc82e..3648799a 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -51,6 +51,7 @@ import Spec.MockContract ( ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) +import Text.Printf (printf) import Prelude {- | Tests for 'cardano-cli query utxo' result parsers @@ -239,13 +240,13 @@ dontAddChangeToDatum = do (balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx) assertBool ( "Expected UTxO not in output Tx." - <> "\nExpected UTxO: " + <> "\nExpected UTxO: \n" <> show scrTxOutExpected - <> "\nBalanced Script UTxOs: " + <> "\nBalanced Script UTxOs: \n" <> show balScrUtxos - <> "\nOther Balanced UTxOs: " + <> "\nOther Balanced UTxOs: \n" <> show balOtherUtxos - <> "\nUnbalanced UTxOs: " + <> "\nUnbalanced UTxOs: \n" <> show (txOutputs (unbalancedTx ^. OffChain.tx)) ) (scrTxOutExpected `elem` txOutputs trx) @@ -306,13 +307,13 @@ dontAddChangeToDatum2 = do -- is in the output. assertBool ( "Expected UTxO not in output Tx." - <> "\nExpected UTxO: " + <> "\nExpected UTxO: \n" <> show scrTxOutExpected - <> "\nBalanced Script UTxOs: " + <> "\nBalanced Script UTxOs: \n" <> show balScrUtxos - <> "\nOther Balanced UTxOs: " + <> "\nOther Balanced UTxOs: \n" <> show balOtherUtxos - <> "\nUnbalanced UTxOs: " + <> "\nUnbalanced UTxOs: \n" <> show (txOutputs (unbalancedTx ^. OffChain.tx)) ) (scrTxOutExpected `elem` txOutputs trx) @@ -331,23 +332,15 @@ dontAddChangeToDatum2 = do -- Check for ADA change assertBool ( "Other UTxOs do not contain expected ADA change." - <> "\nExpected Amount : " - <> show adaChange - <> " Lovelace" - <> "\nActual Amount : " - <> show (lovelaceInValue remainingValue) - <> " Lovelace" + <> printf "\nExpected Amount : %d Lovelace" adaChange + <> printf "\nActual Amount : %d Lovelace" (lovelaceInValue remainingValue) ) (adaChange == lovelaceInValue remainingValue) -- Check for Token change assertBool ( "Other UTxOs do not contain expected Token change." - <> "\nExpected Amount : " - <> show tokChange - <> " tokens" - <> "\nActual Amount : " - <> show (acValueOf tokenAsset remainingValue) - <> " tokens" + <> printf "\nExpected Amount : %d tokens" tokChange + <> printf "\nActual Amount : %d tokens" (acValueOf tokenAsset remainingValue) ) (tokChange == acValueOf tokenAsset remainingValue)