Add mustNotSpendUtxosWhere balancer constraint

src/Contract/BalanceTxConstraints.purs

@@ -6,8 +6,10 @@ import Ctl.Internal.BalanceTx.Constraints
   ( BalanceTxConstraintsBuilder
   , BalancerConfig(BalancerConfig)
   , BalancerConstraints(BalancerConstraints)
+  , UtxoPredicate
   , mustGenChangeOutsWithMaxTokenQuantity
   , mustNotSpendUtxoWithOutRef
+  , mustNotSpendUtxosWhere
   , mustNotSpendUtxosWithOutRefs
   , mustSendChangeToAddress
   , mustSendChangeWithDatum

src/Internal/BalanceTx/BalanceTx.purs

@@ -22,6 +22,7 @@ import Cardano.Types
   , Transaction
   , TransactionBody
   , TransactionOutput
+  , TransactionUnspentOutput
   , UtxoMap
   , Value(Value)
   , _amount
@@ -38,12 +39,15 @@ import Cardano.Types
   , _witnessSet
   )
 import Cardano.Types.Address (Address)
+import Cardano.Types.Address (getPaymentCredential) as Address
 import Cardano.Types.BigNum as BigNum
 import Cardano.Types.Coin as Coin
+import Cardano.Types.Credential (asPubKeyHash) as Credential
 import Cardano.Types.OutputDatum (OutputDatum(OutputDatum))
-import Cardano.Types.TransactionBody (_votingProposals)
+import Cardano.Types.TransactionBody (_collateral, _votingProposals)
 import Cardano.Types.TransactionInput (TransactionInput)
-import Cardano.Types.TransactionUnspentOutput as TransactionUnspentOutputs
+import Cardano.Types.TransactionUnspentOutput (_output)
+import Cardano.Types.TransactionUnspentOutput as TransactionUnspentOutput
 import Cardano.Types.TransactionWitnessSet (_redeemers)
 import Cardano.Types.UtxoMap (pprintUtxoMap)
 import Cardano.Types.Value (getMultiAsset, mkValue, pprintValue)
@@ -65,17 +69,20 @@ import Ctl.Internal.BalanceTx.Collateral
   ( addTxCollateral
   , addTxCollateralReturn
   )
-import Ctl.Internal.BalanceTx.Collateral.Select (selectCollateral)
+import Ctl.Internal.BalanceTx.Collateral.Select
+  ( minRequiredCollateral
+  , selectCollateral
+  ) as Collateral
 import Ctl.Internal.BalanceTx.Constraints
   ( BalanceTxConstraintsBuilder
   , _collateralUtxos
-  , _nonSpendableInputs
   )
 import Ctl.Internal.BalanceTx.Constraints
   ( _changeAddress
   , _changeDatum
   , _maxChangeOutputTokenQuantity
   , _nonSpendableInputs
+  , _nonSpendableInputsPredicates
   , _selectionStrategy
   , _srcAddresses
   ) as Constraints
@@ -137,7 +144,7 @@ import Data.Array.NonEmpty
 import Data.Array.NonEmpty as NEA
 import Data.Bitraversable (ltraverse)
 import Data.Either (Either, hush, note)
-import Data.Foldable (fold, foldMap, foldr, length, null, sum)
+import Data.Foldable (any, foldMap, foldr, length, null, or, sum)
 import Data.Lens (view)
 import Data.Lens.Getter ((^.))
 import Data.Lens.Setter ((%~), (.~), (?~))
@@ -147,6 +154,7 @@ import Data.Map (Map)
 import Data.Map
   ( empty
   , filter
+  , filterWithKey
   , insert
   , isEmpty
   , lookup
@@ -209,11 +217,6 @@ balanceTxWithConstraints transaction extraUtxos constraintsBuilder =
             <#> traverse (note CouldNotGetUtxos)
               >>> map (foldr Map.union Map.empty) -- merge all utxos into one map
 
-    unbalancedCollTx <- transactionWithNetworkId >>=
-      if Array.null (transaction ^. _witnessSet <<< _redeemers)
-      -- Don't set collateral if tx doesn't contain phase-2 scripts:
-      then pure
-      else setTransactionCollateral changeAddress
     let
       allUtxos :: UtxoMap
       allUtxos =
@@ -223,6 +226,12 @@ balanceTxWithConstraints transaction extraUtxos constraintsBuilder =
 
     availableUtxos <- liftContract $ filterLockedUtxos allUtxos
 
+    unbalancedCollTx <- transactionWithNetworkId >>=
+      if Array.null (transaction ^. _witnessSet <<< _redeemers)
+      -- Don't set collateral if tx doesn't contain phase-2 scripts:
+      then pure
+      else setTransactionCollateral changeAddress availableUtxos
+
     Logger.info (pprintUtxoMap allUtxos) "balanceTxWithConstraints: all UTxOs"
     Logger.info (pprintUtxoMap availableUtxos)
       "balanceTxWithConstraints: available UTxOs"
@@ -253,40 +262,76 @@ balanceTxWithConstraints transaction extraUtxos constraintsBuilder =
       (transaction ^. _body <<< _networkId)
     pure (transaction # _body <<< _networkId ?~ networkId)
 
-setTransactionCollateral :: Address -> Transaction -> BalanceTxM Transaction
-setTransactionCollateral changeAddr transaction = do
-  nonSpendableSet <- asksConstraints _nonSpendableInputs
+setTransactionCollateral
+  :: Address -> UtxoMap -> Transaction -> BalanceTxM Transaction
+setTransactionCollateral changeAddr availableUtxos transaction = do
+  nonSpendableSet <- asksConstraints Constraints._nonSpendableInputs
+  nonSpendableInputsPredicates <- asksConstraints
+    Constraints._nonSpendableInputsPredicates
   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
+  let
+    isSpendable = \input output ->
+      not (Set.member input nonSpendableSet) &&
+        not (any (\f -> f input output) nonSpendableInputsPredicates)
   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
+      let
+        isSpendableUtxo = \utxo -> isSpendable (unwrap utxo).input
+          (unwrap utxo).output
       { 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 (TransactionUnspentOutputs.toUtxoMap filteredUtxos))
-      pure spendableUtxos
+          (pprintUtxoMap (TransactionUnspentOutput.toUtxoMap filteredUtxos))
+      let
+        collVal =
+          foldMap (Val.fromValue <<< view (_output <<< _amount))
+            spendableUtxos
+        minRequiredCollateral =
+          BigNum.toBigInt $
+            unwrap Collateral.minRequiredCollateral
+      if (Val.getCoin collVal < minRequiredCollateral) then do
+        logWarn' $ pprintTagSet
+          "Filtered collateral UTxOs do not cover the minimum required \
+          \collateral, reselecting collateral using CTL algorithm."
+          (pprintUtxoMap (TransactionUnspentOutput.toUtxoMap spendableUtxos))
+        let
+          isPkhUtxo txOut = isJust do
+            cred <- Address.getPaymentCredential $ (unwrap txOut).address
+            Credential.asPubKeyHash $ unwrap cred
+        availableUtxos' <- liftContract $
+          Map.filter isPkhUtxo <<< Map.filterWithKey isSpendable <$>
+            filterLockedUtxos availableUtxos
+        selectCollateral availableUtxos'
+      else 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
-      let
-        maxCollateralInputs = UInt.toInt $ params.maxCollateralInputs
-        mbCollateral =
-          Array.fromFoldable <$>
-            selectCollateral params.coinsPerUtxoByte maxCollateralInputs utxoMap
-      liftEither $ note (InsufficientCollateralUtxos utxoMap) mbCollateral
+    Just utxoMap -> selectCollateral utxoMap
   addTxCollateralReturn collateral (addTxCollateral collateral transaction)
     changeAddr
 
+-- | Select collateral from the provided utxos using internal CTL
+-- | collateral selection algorithm.
+selectCollateral :: UtxoMap -> BalanceTxM (Array TransactionUnspentOutput)
+selectCollateral utxos = do
+  pparams <- unwrap <$> liftContract getProtocolParameters
+  let
+    maxCollateralInputs = UInt.toInt $ pparams.maxCollateralInputs
+    mbCollateral =
+      Array.fromFoldable <$> Collateral.selectCollateral
+        pparams.coinsPerUtxoByte
+        maxCollateralInputs
+        utxos
+  liftEither $ note (InsufficientCollateralUtxos utxos)
+    mbCollateral
+
 --------------------------------------------------------------------------------
 -- Balancing Algorithm
 --------------------------------------------------------------------------------
@@ -346,46 +391,51 @@ runBalancer p = do
     isCip30 <- liftContract $ isCip30Wallet
     -- Get collateral inputs to mark them as unspendable.
     -- Some CIP-30 wallets don't allow to sign Txs that spend it.
-    nonSpendableCollateralInputs <-
-      if isCip30 then
-        liftContract $ Wallet.getWalletCollateral <#>
-          fold >>> map (unwrap >>> _.input) >>> Set.fromFoldable
-      else mempty
-    asksConstraints Constraints._nonSpendableInputs <#>
-      append nonSpendableCollateralInputs >>>
-        \nonSpendableInputs ->
-          foldr
-            ( \(oref /\ output) acc ->
-                let
-                  hasInlineDatum :: Boolean
-                  hasInlineDatum = case (unwrap output).datum of
-                    Just (OutputDatum _) -> true
-                    _ -> false
-
-                  hasScriptRef :: Boolean
-                  hasScriptRef = isJust (unwrap output).scriptRef
-
-                  spendable :: Boolean
-                  spendable = not $ Set.member oref nonSpendableInputs ||
-                    Set.member oref referenceInputSet
-
-                  validInContext :: Boolean
-                  validInContext = not $ txHasPlutusV1 &&
-                    (hasInlineDatum || hasScriptRef)
-                in
-                  case spendable, validInContext of
-                    true, true -> acc
-                      { spendable = Map.insert oref output acc.spendable }
-                    true, false -> acc
-                      { invalidInContext = Map.insert oref output
-                          acc.invalidInContext
-                      }
-                    _, _ -> acc
-            )
-            { spendable: Map.empty
-            , invalidInContext: Map.empty
-            }
-            (Map.toUnfoldable p.utxos :: Array _)
+    let
+      nonSpendableCollateralInputs =
+        if isCip30 then
+          Set.fromFoldable $ p.transaction ^. _body <<< _collateral
+        else mempty
+    constraints <- unwrap <$> asks _.constraints
+    let
+      nonSpendableInputs =
+        constraints.nonSpendableInputs <> nonSpendableCollateralInputs
+    pure $ foldr
+      ( \(oref /\ output) acc ->
+          let
+            hasInlineDatum :: Boolean
+            hasInlineDatum = case (unwrap output).datum of
+              Just (OutputDatum _) -> true
+              _ -> false
+
+            hasScriptRef :: Boolean
+            hasScriptRef = isJust (unwrap output).scriptRef
+
+            spendable :: Boolean
+            spendable = not $ or
+              [ Set.member oref nonSpendableInputs
+              , Set.member oref referenceInputSet
+              , any (\f -> f oref output)
+                  constraints.nonSpendableInputsPredicates
+              ]
+
+            validInContext :: Boolean
+            validInContext = not $ txHasPlutusV1 &&
+              (hasInlineDatum || hasScriptRef)
+          in
+            case spendable, validInContext of
+              true, true -> acc
+                { spendable = Map.insert oref output acc.spendable }
+              true, false -> acc
+                { invalidInContext = Map.insert oref output
+                    acc.invalidInContext
+                }
+              _, _ -> acc
+      )
+      { spendable: Map.empty
+      , invalidInContext: Map.empty
+      }
+      (Map.toUnfoldable p.utxos :: Array _)
 
   mainLoop :: BalancerState Transaction -> BalanceTxM Transaction
   mainLoop = worker <<< PrebalanceTx

src/Internal/BalanceTx/Constraints.purs

@@ -1,9 +1,11 @@
 module Ctl.Internal.BalanceTx.Constraints
   ( BalanceTxConstraintsBuilder
   , BalancerConstraints(BalancerConstraints)
-  , buildBalancerConfig
   , BalancerConfig(BalancerConfig)
+  , UtxoPredicate
+  , buildBalancerConfig
   , mustGenChangeOutsWithMaxTokenQuantity
+  , mustNotSpendUtxosWhere
   , mustNotSpendUtxosWithOutRefs
   , mustNotSpendUtxoWithOutRef
   , mustSendChangeToAddress
@@ -19,13 +21,14 @@ module Ctl.Internal.BalanceTx.Constraints
   , _changeDatum
   , _maxChangeOutputTokenQuantity
   , _nonSpendableInputs
+  , _nonSpendableInputsPredicates
   , _selectionStrategy
   , _srcAddresses
   ) where
 
 import Prelude
 
-import Cardano.Types (Address, TransactionInput, UtxoMap)
+import Cardano.Types (Address, TransactionInput, TransactionOutput, UtxoMap)
 import Cardano.Types.OutputDatum (OutputDatum)
 import Ctl.Internal.BalanceTx.CoinSelection
   ( SelectionStrategy(SelectionStrategyOptimal)
@@ -49,6 +52,7 @@ newtype BalancerConfig = BalancerConfig
   , collateralUtxos :: Maybe UtxoMap
   , maxChangeOutputTokenQuantity :: Maybe BigInt
   , nonSpendableInputs :: Set TransactionInput
+  , nonSpendableInputsPredicates :: Array UtxoPredicate
   , srcAddresses :: Maybe (Array Address)
   , changeAddress :: Maybe Address
   , changeDatum :: Maybe OutputDatum
@@ -57,6 +61,8 @@ newtype BalancerConfig = BalancerConfig
 
 derive instance Newtype BalancerConfig _
 
+type UtxoPredicate = TransactionInput -> TransactionOutput -> Boolean
+
 _additionalUtxos :: Lens' BalancerConfig UtxoMap
 _additionalUtxos = _Newtype <<< prop (Proxy :: Proxy "additionalUtxos")
 
@@ -70,6 +76,10 @@ _maxChangeOutputTokenQuantity =
 _nonSpendableInputs :: Lens' BalancerConfig (Set TransactionInput)
 _nonSpendableInputs = _Newtype <<< prop (Proxy :: Proxy "nonSpendableInputs")
 
+_nonSpendableInputsPredicates :: Lens' BalancerConfig (Array UtxoPredicate)
+_nonSpendableInputsPredicates =
+  _Newtype <<< prop (Proxy :: Proxy "nonSpendableInputsPredicates")
+
 _srcAddresses :: Lens' BalancerConfig (Maybe (Array Address))
 _srcAddresses = _Newtype <<< prop (Proxy :: Proxy "srcAddresses")
 
@@ -104,6 +114,7 @@ buildBalancerConfig = applyFlipped defaultConstraints <<< unwrap
     , collateralUtxos: Nothing
     , maxChangeOutputTokenQuantity: Nothing
     , nonSpendableInputs: mempty
+    , nonSpendableInputsPredicates: mempty
     , srcAddresses: Nothing
     , changeDatum: Nothing
     , changeAddress: Nothing
@@ -166,6 +177,17 @@ mustNotSpendUtxosWithOutRefs = wrap <<< appendOver _nonSpendableInputs
 mustNotSpendUtxoWithOutRef :: TransactionInput -> BalancerConstraints
 mustNotSpendUtxoWithOutRef = mustNotSpendUtxosWithOutRefs <<< Set.singleton
 
+-- | Tells the balancer not to spend UTxO's based on the given predicate.
+-- | Note that `mustNotSpendUtxosWhere` constraints are stacked when specified
+-- | multiple times, and utxos are tested against each predicate. The order of
+-- | specifying multiple `mustNotSpendUtxosWhere` constraints does NOT affect
+-- | the resulting set.
+mustNotSpendUtxosWhere :: UtxoPredicate -> BalanceTxConstraintsBuilder
+mustNotSpendUtxosWhere =
+  wrap
+    <<< appendOver _nonSpendableInputsPredicates
+    <<< Array.singleton
+
 -- | Tells the balancer to use the provided UTxO set when evaluating script
 -- | execution units (sets `additionalUtxoSet` of Ogmios `EvaluateTx`).
 -- | Note that you need to use `unspentOutputs` lookup to make these UTxO's

src/Internal/Contract/Hooks.purs

@@ -6,11 +6,11 @@ module Ctl.Internal.Contract.Hooks
 
 import Prelude
 
-import Cardano.Types.PrivateKey (PrivateKey)
 import Cardano.Types.Transaction (Transaction)
 import Data.Maybe (Maybe(Nothing))
 import Effect (Effect)
 import Effect.Exception (Error)
+import Node.Path (FilePath)
 
 type Hooks =
   { beforeSign :: Maybe (Effect Unit)
@@ -22,10 +22,7 @@ type Hooks =
   }
 
 type ClusterParameters =
-  { privateKeys :: Array PrivateKey
-  , nodeSocketPath :: String
-  , nodeConfigPath :: String
-  , privateKeysDirectory :: String
+  { nodeSocketPath :: FilePath
   }
 
 emptyHooks :: Hooks