Merge pull request #1513 from Plutonomicon/klntsky/use-additional-addresses-as-collateral

Add `mustUseCollateralUtxos` balancer constraint

Author: klntsky

CHANGELOG.md

@@ -83,6 +83,7 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/)
 - Support for generic CIP-30 wallets by name ([#1524](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1524))
 - Full additional utxos support for Blockfrost backend ([#1537](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1537))
 - New `submitTxE`, an error returning variant of `submitTx`
+- Allow providing a custom set of UTxOs for collateral selection, overriding the wallet (`mustUseCollateralUtxos` balancer constraint) ([#1513](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1513))
 
 ### Changed
 

doc/balancing.md

@@ -18,10 +18,12 @@ Transaction balancing in Cardano is the process of finding a set of inputs and o
 
 CTL allows tweaking the default balancer behavior by letting the user impose constraints on the UTxO set that is used in the process (`balanceTxWithConstraints`):
 
-- providing additional UTxOs to use: `mustUseUtxosAtAddresses` / `mustUseUtxosAtAddress` / `mustUseAdditionalUtxos`
-- overriding change address: `mustSendChangeToAddress`
-- prevent certain UTxOs from being spent: `mustNotSpendUtxosWithOutRefs` / `mustNotSpendUtxoWithOutRef`
-- distribute token outputs equally between change UTxOs: `mustGenChangeOutsWithMaxTokenQuantity`
+- Using arbitrary address as user's own (for transaction balancing): `mustUseUtxosAtAddresses` / `mustUseUtxosAtAddress`
+- Providing additional UTxOs to use: `mustUseAdditionalUtxos`
+- Bypassing wallet's collateral selection and selecting collateral UTxOs from a given set: `mustUseCollateralUtxos`
+- Overriding change address: `mustSendChangeToAddress`
+- Preventing certain UTxOs from being spent: `mustNotSpendUtxosWithOutRefs` / `mustNotSpendUtxoWithOutRef`
+- Distributing token outputs equally between change UTxOs: `mustGenChangeOutsWithMaxTokenQuantity`
 
 ## Concurrent spending
 
@@ -31,11 +33,11 @@ Obviously, the number of available UTxOs must be greater than the number of tran
 
 ## Balancing a Tx for other wallet
 
-Setting `mustUseUtxosAtAddress` and `mustSendChangeToAddress` at the same time allows to build a transaction without any connection to the current wallet. For example, it's possible to balance it on server-side and send to the user to sign, or balance a Tx on one user's side while leaving fees at the expense of some other user.
+Setting `mustUseUtxosAtAddress`, `mustSendChangeToAddress` and `mustUseCollateralUtxos` at the same time allows to build a transaction without any connection to the current wallet. For example, it's possible to balance it on server-side and send to the user to sign, or balance a Tx on one user's side while leaving fees at the expense of some other user.
 
 ## Synchronization
 
-Before balancing, CTL synchronizes the wallet with the query layer, i.e. waits until all UTxOs that the wallet returns are visible in the query layer. Thus the situation when the query layer refuses to validate a Tx (either during ex-units evaluation or on Tx submission) is only possible due to a rollback. Please see [our docs for query layer synchronization](./query-layers.md).
+Before balancing, CTL tries to synchronize the wallet state with the query layer, i.e. waits until all UTxOs that the wallet returns are visible in the query layer. Thus the situation when the query layer refuses to validate a Tx (either during ex-units evaluation or on Tx submission) is only possible due to a rollback or a synchronization timeout. Please see [our docs for query layer synchronization](./query-layers.md).
 
 ## Balancing process limitations
 

examples/BalanceTxConstraints.purs

@@ -5,14 +5,13 @@ module Ctl.Examples.BalanceTxConstraints
 
 import Contract.Prelude
 
-import Contract.Address
-  ( Address
-  )
+import Contract.Address (Address)
 import Contract.BalanceTxConstraints
   ( BalanceTxConstraintsBuilder
   , mustGenChangeOutsWithMaxTokenQuantity
   , mustNotSpendUtxoWithOutRef
   , mustSendChangeToAddress
+  , mustUseCollateralUtxos
   , mustUseUtxosAtAddress
   ) as BalanceTxConstraints
 import Contract.Log (logInfo')
@@ -43,6 +42,7 @@ import Contract.Value (singleton, valueOf) as Value
 import Contract.Wallet
   ( KeyWallet
   , getWalletAddressesWithNetworkTag
+  , getWalletCollateral
   , ownPaymentPubKeyHashes
   , withKeyWallet
   )
@@ -52,7 +52,7 @@ import Ctl.Examples.Helpers (mkCurrencySymbol, mkTokenName) as Helpers
 import Data.Array (head)
 import Data.Array (sort) as Array
 import Data.BigInt (BigInt, fromInt)
-import Data.Map (keys, member) as Map
+import Data.Map (fromFoldable, keys, member) as Map
 import Data.Set (findMin) as Set
 
 newtype ContractParams = ContractParams
@@ -63,6 +63,7 @@ newtype ContractParams = ContractParams
 type ContractResult =
   { txHash :: TransactionHash
   , changeAddress :: Address
+  , nonSpendableAddress :: Address
   , mintedToken :: CurrencySymbol /\ TokenName
   , nonSpendableOref :: TransactionInput
   }
@@ -100,8 +101,8 @@ assertSelectedUtxoIsNotSpent
   :: ContractCheck ContractResult
 assertSelectedUtxoIsNotSpent =
   assertionToCheck "Non-spendable UTxO hasn't been spent"
-    \{ changeAddress, nonSpendableOref } -> do
-      utxos <- lift $ utxosAt changeAddress
+    \{ nonSpendableAddress, nonSpendableOref } -> do
+      utxos <- lift $ utxosAt nonSpendableAddress
       let
         assertionFailure :: ContractAssertionFailure
         assertionFailure =
@@ -120,6 +121,11 @@ contract :: ContractParams -> Contract Unit
 contract (ContractParams p) = do
   logInfo' "Examples.BalanceTxConstraints"
 
+  aliceAddress <-
+    liftedM "Failed to get Alice's address"
+      $ head
+      <$> (withKeyWallet p.aliceKeyWallet getWalletAddressesWithNetworkTag)
+
   alicePubKeyHash <-
     liftedM "Failed to get own PKH" $ head <$> ownPaymentPubKeyHashes
 
@@ -133,9 +139,16 @@ contract (ContractParams p) = do
       $ head
       <$> (withKeyWallet p.bobKeyWallet getWalletAddressesWithNetworkTag)
 
+  bobsCollateralArray <- withKeyWallet p.bobKeyWallet do
+    fold <$> getWalletCollateral
+  let
+    bobsCollateral =
+      Map.fromFoldable $ bobsCollateralArray <#> unwrap >>>
+        \{ input, output } -> Tuple input output
+
   nonSpendableOref <-
-    liftedM "Failed to get utxos at Bob's address"
-      (Set.findMin <<< Map.keys <$> utxosAt bobAddress)
+    liftedM "Failed to get utxos at Alice's address"
+      (Set.findMin <<< Map.keys <$> utxosAt aliceAddress)
 
   mp /\ cs <- Helpers.mkCurrencySymbol alwaysMintsPolicy
   tn <- Helpers.mkTokenName "The Token"
@@ -154,6 +167,7 @@ contract (ContractParams p) = do
         <> BalanceTxConstraints.mustUseUtxosAtAddress bobAddress
         <> BalanceTxConstraints.mustSendChangeToAddress bobAddress
         <> BalanceTxConstraints.mustNotSpendUtxoWithOutRef nonSpendableOref
+        <> BalanceTxConstraints.mustUseCollateralUtxos bobsCollateral
 
   void $ runChecks checks $ lift do
     unbalancedTx <- mkUnbalancedTx lookups constraints
@@ -171,4 +185,10 @@ contract (ContractParams p) = do
     logInfo' "Tx submitted successfully!"
 
     let changeAddress = (unwrap bobAddress).address
-    pure { txHash, changeAddress, mintedToken: cs /\ tn, nonSpendableOref }
+    pure
+      { txHash
+      , changeAddress
+      , nonSpendableAddress: (unwrap aliceAddress).address
+      , mintedToken: cs /\ tn
+      , nonSpendableOref
+      }

spago.dhall

@@ -9,6 +9,7 @@ You can edit this file as you like.
   , "aff-promise"
   , "aff-retry"
   , "affjax"
+  , "ansi"
   , "argonaut"
   , "argonaut-codecs"
   , "arraybuffer-types"

src/Contract/BalanceTxConstraints.purs

@@ -11,6 +11,7 @@ import Ctl.Internal.BalanceTx.Constraints
   , mustSendChangeWithDatum
   , mustUseAdditionalUtxos
   , mustUseCoinSelectionStrategy
+  , mustUseCollateralUtxos
   , mustUseUtxosAtAddress
   , mustUseUtxosAtAddresses
   ) as BalanceTxConstraints

src/Contract/Transaction.purs

@@ -49,8 +49,6 @@ import Contract.UnbalancedTx (mkUnbalancedTx)
 import Control.Monad.Error.Class (catchError, liftEither, throwError)
 import Control.Monad.Reader (ReaderT, asks, runReaderT)
 import Control.Monad.Reader.Class (ask)
-import Ctl.Internal.BalanceTx (FinalizedTransaction)
-import Ctl.Internal.BalanceTx (FinalizedTransaction(FinalizedTransaction)) as FinalizedTransaction
 import Ctl.Internal.BalanceTx (balanceTxWithConstraints) as BalanceTx
 import Ctl.Internal.BalanceTx.Constraints (BalanceTxConstraintsBuilder)
 import Ctl.Internal.BalanceTx.Error
@@ -60,6 +58,7 @@ import Ctl.Internal.BalanceTx.Error
       , CouldNotConvertScriptOutputToTxInput
       , CouldNotGetChangeAddress
       , CouldNotGetCollateral
+      , InsufficientCollateralUtxos
       , CouldNotGetUtxos
       , CollateralReturnError
       , CollateralReturnMinAdaValueCalcError
@@ -72,6 +71,8 @@ import Ctl.Internal.BalanceTx.Error
   , Expected(Expected)
   , explainBalanceTxError
   ) as BalanceTxError
+import Ctl.Internal.BalanceTx.Types (FinalizedTransaction)
+import Ctl.Internal.BalanceTx.Types (FinalizedTransaction(FinalizedTransaction)) as FinalizedTransaction
 import Ctl.Internal.BalanceTx.UnattachedTx (UnindexedTx)
 import Ctl.Internal.Cardano.Types.NativeScript
   ( NativeScript

src/Internal/BalanceTx/BalanceTx.purs

@@ -1,11 +1,10 @@
 module Ctl.Internal.BalanceTx
-  ( module BalanceTxErrorExport
-  , module FinalizedTransaction
-  , balanceTxWithConstraints
+  ( balanceTxWithConstraints
   ) where
 
 import Prelude
 
+import Contract.Log (logWarn')
 import Control.Monad.Error.Class (liftMaybe)
 import Control.Monad.Except.Trans (ExceptT(ExceptT), except, runExceptT)
 import Control.Monad.Logger.Class (info) as Logger
@@ -22,8 +21,10 @@ import Ctl.Internal.BalanceTx.Collateral
   ( addTxCollateral
   , addTxCollateralReturn
   )
+import Ctl.Internal.BalanceTx.Collateral.Select (selectCollateral)
 import Ctl.Internal.BalanceTx.Constraints
   ( BalanceTxConstraintsBuilder
+  , _collateralUtxos
   , _nonSpendableInputs
   )
 import Ctl.Internal.BalanceTx.Constraints
@@ -34,23 +35,10 @@ import Ctl.Internal.BalanceTx.Constraints
   , _selectionStrategy
   , _srcAddresses
   ) as Constraints
-import Ctl.Internal.BalanceTx.Error
-  ( Actual(Actual)
-  , BalanceTxError
-      ( CouldNotGetChangeAddress
-      , CouldNotGetCollateral
-      , CouldNotGetUtxos
-      , ExUnitsEvaluationFailed
-      , ReindexRedeemersError
-      , UtxoLookupFailedFor
-      , UtxoMinAdaValueCalculationFailed
-      )
-  , Expected(Expected)
-  , printTxEvaluationFailure
-  ) as BalanceTxErrorExport
 import Ctl.Internal.BalanceTx.Error
   ( BalanceTxError
-      ( UtxoLookupFailedFor
+      ( InsufficientCollateralUtxos
+      , UtxoLookupFailedFor
       , UtxoMinAdaValueCalculationFailed
       , ReindexRedeemersError
       , CouldNotGetUtxos
@@ -79,7 +67,6 @@ import Ctl.Internal.BalanceTx.Types
   , liftEitherContract
   , withBalanceTxConstraints
   )
-import Ctl.Internal.BalanceTx.Types (FinalizedTransaction(FinalizedTransaction)) as FinalizedTransaction
 import Ctl.Internal.BalanceTx.UnattachedTx
   ( EvaluatedTx
   , UnindexedTx
@@ -106,6 +93,9 @@ import Ctl.Internal.Cardano.Types.Transaction
   , _witnessSet
   , pprintUtxoMap
   )
+import Ctl.Internal.Cardano.Types.TransactionUnspentOutput
+  ( transactionUnspentOutputsToUtxoMap
+  )
 import Ctl.Internal.Cardano.Types.Value
   ( AssetClass
   , Coin(Coin)
@@ -129,10 +119,14 @@ import Ctl.Internal.Contract.Wallet
   , getWalletCollateral
   , getWalletUtxos
   ) as Wallet
-import Ctl.Internal.Helpers (liftEither, (??))
+import Ctl.Internal.Helpers (liftEither, pprintTagSet, (??))
 import Ctl.Internal.Partition (equipartition, partition)
+import Ctl.Internal.Plutus.Conversion (fromPlutusUtxoMap)
 import Ctl.Internal.Serialization.Address (Address)
 import Ctl.Internal.Types.OutputDatum (OutputDatum(NoOutputDatum, OutputDatum))
+import Ctl.Internal.Types.ProtocolParameters
+  ( ProtocolParameters(ProtocolParameters)
+  )
 import Ctl.Internal.Types.Scripts
   ( Language(PlutusV1)
   , PlutusScript(PlutusScript)
@@ -162,14 +156,15 @@ import Data.Lens.Setter ((%~), (.~), (?~))
 import Data.Log.Tag (TagSet, tag, tagSetTag)
 import Data.Log.Tag (fromArray) as TagSet
 import Data.Map (Map)
-import Data.Map (empty, insert, lookup, toUnfoldable, union) as Map
+import Data.Map (empty, filterKeys, 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)
 import Data.Tuple.Nested (type (/\), (/\))
+import Data.UInt (toInt) as UInt
 import Effect.Aff.Class (liftAff)
 import Effect.Class (liftEffect)
 
@@ -275,14 +270,37 @@ balanceTxWithConstraints transaction extraUtxos constraintsBuilder = do
 setTransactionCollateral :: Address -> Transaction -> BalanceTxM Transaction
 setTransactionCollateral changeAddr transaction = do
   nonSpendableSet <- asksConstraints _nonSpendableInputs
-  collateral <- do
-    rawCollateral <- liftEitherContract $ note CouldNotGetCollateral <$>
-      Wallet.getWalletCollateral
-    -- filter out UTxOs that are set as non-spendable in the balancer constraints
-    let
-      isSpendable = not <<< flip Set.member nonSpendableSet <<< _.input <<<
-        unwrap
-    pure $ Array.filter isSpendable rawCollateral
+  mbCollateralUtxos <- asksConstraints _collateralUtxos
+  -- We must filter out UTxOs that are set as non-spendable in the balancer
+  -- constraints
+  let isSpendable = not <<< flip Set.member nonSpendableSet
+  collateral <- case mbCollateralUtxos of
+    -- if no collateral utxos are specified, use the wallet, but filter
+    -- the unspendable ones
+    Nothing -> do
+      let isSpendableUtxo = isSpendable <<< _.input <<< unwrap
+      { yes: spendableUtxos, no: filteredUtxos } <-
+        Array.partition isSpendableUtxo <$> do
+          liftEitherContract $ note CouldNotGetCollateral <$>
+            Wallet.getWalletCollateral
+      when (not $ Array.null filteredUtxos) do
+        logWarn' $ pprintTagSet
+          "Some of the collateral UTxOs returned by the wallet were marked as non-spendable and ignored"
+          (pprintUtxoMap (transactionUnspentOutputsToUtxoMap filteredUtxos))
+      pure spendableUtxos
+    -- otherwise, get all the utxos, filter out unspendable, and select
+    -- collateral using internal algo, that is also used in KeyWallet
+    Just utxoMap -> do
+      ProtocolParameters params <- liftContract getProtocolParameters
+      networkId <- askNetworkId
+      let
+        coinsPerUtxoUnit = params.coinsPerUtxoUnit
+        maxCollateralInputs = UInt.toInt $ params.maxCollateralInputs
+        utxoMap' = fromPlutusUtxoMap networkId $ Map.filterKeys isSpendable
+          utxoMap
+      mbCollateral <- liftEffect $ map Array.fromFoldable <$>
+        selectCollateral coinsPerUtxoUnit maxCollateralInputs utxoMap'
+      liftEither $ note (InsufficientCollateralUtxos utxoMap') mbCollateral
   addTxCollateralReturn collateral (addTxCollateral collateral transaction)
     changeAddr