diff --git a/examples/ChangeGeneration.purs b/examples/ChangeGeneration.purs new file mode 100644 index 0000000000..f9acd350d2 --- /dev/null +++ b/examples/ChangeGeneration.purs @@ -0,0 +1,57 @@ +module Ctl.Examples.ChangeGeneration (checkChangeOutputsDistribution) where + +import Prelude + +import Contract.Monad (Contract, liftedE) +import Contract.PlutusData (PlutusData, unitDatum) +import Contract.ScriptLookups as Lookups +import Contract.Scripts (validatorHash) +import Contract.Transaction (_body, _outputs, balanceTx) +import Contract.TxConstraints (TxConstraints) +import Contract.TxConstraints as Constraints +import Contract.UnbalancedTx (mkUnbalancedTx) +import Contract.Value as Value +import Contract.Wallet (ownPaymentPubKeyHashes, ownStakePubKeyHashes) +import Ctl.Examples.AlwaysSucceeds as AlwaysSucceeds +import Data.Array (fold, replicate, zip) +import Data.Array (length) as Array +import Data.BigInt (fromInt) as BigInt +import Data.Lens (to, (^.)) +import Data.Maybe (Maybe(Just, Nothing)) +import Data.Newtype (unwrap) +import Data.Tuple (Tuple(Tuple)) +import Test.Spec.Assertions (shouldEqual) + +-- | A contract that creates `outputsToScript` number of outputs at a script address, +-- | `outputsToSelf` outputs going to own address, and asserts that the number of change +-- | outputs is equal to `expectedOutputs`. +checkChangeOutputsDistribution :: Int -> Int -> Int -> Contract Unit +checkChangeOutputsDistribution outputsToScript outputsToSelf expectedOutputs = + do + pkhs <- ownPaymentPubKeyHashes + skhs <- ownStakePubKeyHashes + validator <- AlwaysSucceeds.alwaysSucceedsScript + let + vhash = validatorHash validator + value = Value.lovelaceValueOf $ BigInt.fromInt 10000000 + + constraintsToSelf :: TxConstraints Unit Unit + constraintsToSelf = fold <<< fold $ replicate outputsToSelf + $ zip pkhs skhs <#> \(Tuple pkh mbSkh) -> case mbSkh of + Nothing -> Constraints.mustPayToPubKey pkh value + Just skh -> Constraints.mustPayToPubKeyAddress pkh skh value + + constraintsToScripts :: TxConstraints Unit Unit + constraintsToScripts = fold $ replicate outputsToScript + $ Constraints.mustPayToScript vhash unitDatum + Constraints.DatumWitness + value + + constraints = constraintsToSelf <> constraintsToScripts + + lookups :: Lookups.ScriptLookups PlutusData + lookups = mempty + unbalancedTx <- liftedE $ mkUnbalancedTx lookups constraints + balancedTx <- liftedE $ balanceTx unbalancedTx + let outputs = balancedTx ^. to unwrap <<< _body <<< _outputs + Array.length outputs `shouldEqual` expectedOutputs diff --git a/src/Internal/BalanceTx/BalanceTx.purs b/src/Internal/BalanceTx/BalanceTx.purs index 3564d007fc..d6462dc5f9 100644 --- a/src/Internal/BalanceTx/BalanceTx.purs +++ b/src/Internal/BalanceTx/BalanceTx.purs @@ -167,6 +167,7 @@ import Data.Map (Map) import Data.Map (empty, insert, lookup, toUnfoldable, union) as Map import Data.Maybe (Maybe(Just, Nothing), fromMaybe, isJust, maybe) import Data.Newtype (class Newtype, unwrap, wrap) +import Data.Set (Set) import Data.Set as Set import Data.Traversable (for, traverse) import Data.Tuple (fst) @@ -443,7 +444,10 @@ runBalancer p = do runNextBalancerStep state@{ transaction } = do let txBody = transaction ^. _transaction <<< _body inputValue <- except $ getInputValue p.allUtxos txBody - changeOutputs <- makeChange p.changeAddress p.changeDatum inputValue + ownWalletAddresses <- asks _.ownAddresses + changeOutputs <- makeChange ownWalletAddresses p.changeAddress + p.changeDatum + inputValue p.certsFee txBody @@ -551,13 +555,20 @@ setTxChangeOutputs outputs tx = -- | Taken from cardano-wallet: -- | https://github.com/input-output-hk/cardano-wallet/blob/4c2eb651d79212157a749d8e69a48fff30862e93/lib/wallet/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs#L1396 makeChange - :: Address + :: Set Address + -> Address -> OutputDatum -> Value -> Coin -> TxBody -> BalanceTxM (Array TransactionOutput) -makeChange changeAddress changeDatum inputValue certsFee txBody = +makeChange + ownWalletAddresses + changeAddress + changeDatum + inputValue + certsFee + txBody = -- Always generate change when a transaction has no outputs to avoid issues -- with transaction confirmation: -- FIXME: https://github.com/Plutonomicon/cardano-transaction-lib/issues/1293 @@ -576,6 +587,12 @@ makeChange changeAddress changeDatum inputValue certsFee txBody = -- | -- | Taken from cardano-wallet: -- | https://github.com/input-output-hk/cardano-wallet/blob/4c2eb651d79212157a749d8e69a48fff30862e93/lib/wallet/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs#L1447 + -- | + -- | Differences from cardano-wallet: + -- | + -- | - We only consider outputs that go back to our wallet when deciding on + -- | the number of desired outputs for change generation. See + -- | https://github.com/Plutonomicon/cardano-transaction-lib/issues/1530 changeValueOutputCoinPairs :: NonEmptyArray (Value /\ BigInt) changeValueOutputCoinPairs = outputCoins # NEArray.zip changeForAssets @@ -599,10 +616,16 @@ makeChange changeAddress changeDatum inputValue certsFee txBody = unbundle :: Value -> Value /\ BigInt unbundle (Value coin assets) = mkValue mempty assets /\ unwrap coin + -- find outputs belonging to one of the wallet's addresses. + ownAddressOutputs :: Array TransactionOutput + ownAddressOutputs = Array.filter + (unwrap >>> _.address >>> flip Set.member ownWalletAddresses) + txOutputs + changeForAssets :: NonEmptyArray Value changeForAssets = foldr - (NEArray.zipWith (<>) <<< makeChangeForAsset txOutputs) - (NEArray.replicate (length txOutputs) mempty) + (NEArray.zipWith (<>) <<< makeChangeForAsset ownAddressOutputs) + (NEArray.replicate (length ownAddressOutputs) mempty) excessAssets outputCoins :: NonEmptyArray BigInt diff --git a/src/Internal/BalanceTx/Types.purs b/src/Internal/BalanceTx/Types.purs index d7bf8bc763..89bc6833d3 100644 --- a/src/Internal/BalanceTx/Types.purs +++ b/src/Internal/BalanceTx/Types.purs @@ -22,13 +22,13 @@ import Ctl.Internal.BalanceTx.Constraints ( BalanceTxConstraints , BalanceTxConstraintsBuilder ) -import Ctl.Internal.BalanceTx.Constraints - ( buildBalanceTxConstraints - ) as Constraints +import Ctl.Internal.BalanceTx.Constraints (buildBalanceTxConstraints) as Constraints import Ctl.Internal.BalanceTx.Error (BalanceTxError) import Ctl.Internal.Cardano.Types.Transaction (Costmdls(Costmdls), Transaction) import Ctl.Internal.Contract.Monad (Contract, ContractEnv) +import Ctl.Internal.Contract.Wallet (getWalletAddresses) import Ctl.Internal.Serialization.Address (NetworkId) +import Ctl.Internal.Serialization.Address as Csl import Ctl.Internal.Types.ProtocolParameters (CoinsPerUtxoUnit) import Ctl.Internal.Types.Scripts (Language) import Ctl.Internal.Wallet (Cip30Wallet, cip30Wallet) @@ -40,10 +40,11 @@ import Data.Map (filterKeys) as Map import Data.Maybe (Maybe) import Data.Newtype (class Newtype, over, unwrap) import Data.Set (Set) -import Data.Set (member) as Set +import Data.Set (fromFoldable, member) as Set import Data.Show.Generic (genericShow) -type BalanceTxMContext = { constraints :: BalanceTxConstraints } +type BalanceTxMContext = + { constraints :: BalanceTxConstraints, ownAddresses :: Set Csl.Address } type BalanceTxM (a :: Type) = ExceptT BalanceTxError (ReaderT BalanceTxMContext Contract) a @@ -78,8 +79,11 @@ withBalanceTxConstraints . BalanceTxConstraintsBuilder -> ReaderT BalanceTxMContext Contract a -> Contract a -withBalanceTxConstraints constraintsBuilder = - flip runReaderT { constraints } +withBalanceTxConstraints constraintsBuilder m = do + -- we can ignore failures due to reward addresses because reward addresses + -- do not receive transaction outputs from dApps + ownAddresses <- Set.fromFoldable <$> getWalletAddresses + flip runReaderT { constraints, ownAddresses } m where constraints :: BalanceTxConstraints constraints = Constraints.buildBalanceTxConstraints constraintsBuilder diff --git a/test/BalanceTx/ChangeGeneration.purs b/test/BalanceTx/ChangeGeneration.purs new file mode 100644 index 0000000000..9f64048469 --- /dev/null +++ b/test/BalanceTx/ChangeGeneration.purs @@ -0,0 +1,39 @@ +module Test.Ctl.BalanceTx.ChangeGeneration (suite) where + +import Prelude + +import Contract.Test (ContractTest, InitialUTxOs, withKeyWallet, withWallets) +import Ctl.Examples.ChangeGeneration (checkChangeOutputsDistribution) +import Ctl.Internal.Test.TestPlanM (TestPlanM) +import Data.BigInt (fromInt) as BigInt +import Mote (group, test) + +suite :: TestPlanM ContractTest Unit +suite = do + group "BalanceTx.ChangeGeneration" do + group + "The number of change outputs must equal the number of normal outputs going to our own address" + do + test "no outputs to own address" do + mkChangeOutputs 10 0 11 + test "1 output to own address" do + mkChangeOutputs 10 1 12 + test "2 outputs to own address" do + mkChangeOutputs 10 2 14 + test "2 outputs to own address" do + mkChangeOutputs 10 3 16 + test "0 outputs to script address, 10 outputs to own address" do + mkChangeOutputs 0 10 20 + +mkChangeOutputs :: Int -> Int -> Int -> ContractTest +mkChangeOutputs outputsToScript outputsToSelf expectedOutputs = do + let + distribution :: InitialUTxOs + distribution = + [ BigInt.fromInt 1000_000_000 + , BigInt.fromInt 2000_000_000 + ] + withWallets distribution \alice -> do + withKeyWallet alice do + checkChangeOutputsDistribution outputsToScript outputsToSelf + expectedOutputs diff --git a/test/Plutip.purs b/test/Plutip.purs index 87e00f8546..d80ff74083 100644 --- a/test/Plutip.purs +++ b/test/Plutip.purs @@ -30,6 +30,7 @@ import Effect.Aff ) import Mote (group, test) import Mote.Monad (mapTest) +import Test.Ctl.BalanceTx.ChangeGeneration as ChangeGeneration import Test.Ctl.Plutip.Common (config) import Test.Ctl.Plutip.Contract as Contract import Test.Ctl.Plutip.Contract.Assert as Assert @@ -63,6 +64,7 @@ main = interruptOnSignal SIGINT =<< launchAff do flip mapTest QueryM.AffInterface.suite (noWallet <<< wrapQueryM) NetworkId.suite + ChangeGeneration.suite Contract.suite UtxoDistribution.suite testPlutipContracts config OgmiosMempool.suite diff --git a/test/Plutip/Contract.purs b/test/Plutip/Contract.purs index 624e2b2d25..72519cc847 100644 --- a/test/Plutip/Contract.purs +++ b/test/Plutip/Contract.purs @@ -206,51 +206,7 @@ suite = do void $ waitUntilSlot $ Slot $ BigNum.fromInt 160 void $ waitUntilSlot $ Slot $ BigNum.fromInt 161 void $ waitUntilSlot $ Slot $ BigNum.fromInt 241 - only $ group "Regressions" do - only $ test "#1530 - too many change outputs" do - do - let - distribution :: InitialUTxOs - distribution = - [ BigInt.fromInt 1000_000_000 - , BigInt.fromInt 2000_000_000 - ] - withWallets distribution \alice -> do - withKeyWallet alice do - mp <- alwaysMintsPolicy - _ /\ cs <- mkCurrencySymbol alwaysMintsPolicy - tn <- mkTokenName "TheToken" - -- do - -- let - -- constraints :: Constraints.TxConstraints Void Void - -- constraints = Constraints.mustMintValue - -- $ Value.singleton cs tn - -- $ BigInt.fromInt 100 - - -- lookups :: Lookups.ScriptLookups Void - -- lookups = Lookups.mintingPolicy mp - - -- txHash <- submitTxFromConstraints lookups constraints - -- awaitTxConfirmed txHash - do - validator <- AlwaysSucceeds.alwaysSucceedsScript - let vhash = validatorHash validator - let - constraints :: TxConstraints Unit Unit - constraints = fold $ replicate 20 - $ Constraints.mustPayToScript vhash unitDatum - Constraints.DatumWitness - -- $ Value.singleton cs tn one - $ Value.lovelaceValueOf $ BigInt.fromInt 10000000 - - lookups :: Lookups.ScriptLookups PlutusData - lookups = mempty - unbalancedTx <- liftedE $ mkUnbalancedTx lookups constraints - balancedTx <- liftedE $ balanceTx unbalancedTx - let outputs = balancedTx ^. to unwrap <<< _body <<< _outputs - liftEffect $ Console.log $ show (Array.length outputs) <> " " <> - show outputs - + group "Regressions" do skip $ test "#1441 - Mint many assets at once - fails with TooManyAssetsInOutput" do