Modify change generation algorithm to only consider outputs going back

to the wallet when deciding on change UTxO distribution (#1530)

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

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

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

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

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

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