Skip to content

Commit

Permalink
Select collateral from available pkh utxos as fallback, Add test
Browse files Browse the repository at this point in the history
  • Loading branch information
errfrom committed Sep 16, 2024
1 parent 6854799 commit 7987528
Show file tree
Hide file tree
Showing 2 changed files with 64 additions and 3 deletions.
12 changes: 11 additions & 1 deletion src/Internal/BalanceTx/BalanceTx.purs
Original file line number Diff line number Diff line change
Expand Up @@ -39,8 +39,10 @@ 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 (_collateral, _votingProposals)
import Cardano.Types.TransactionInput (TransactionInput)
Expand Down Expand Up @@ -152,6 +154,7 @@ import Data.Map (Map)
import Data.Map
( empty
, filter
, filterKeys
, insert
, isEmpty
, lookup
Expand Down Expand Up @@ -292,7 +295,14 @@ setTransactionCollateral changeAddr availableUtxos transaction = do
"Filtered collateral UTxOs do not cover the minimum required \
\collateral, reselecting collateral using CTL algorithm."
(pprintUtxoMap (TransactionUnspentOutput.toUtxoMap spendableUtxos))
selectCollateral availableUtxos
let
isPkhUtxo txOut = isJust do
cred <- Address.getPaymentCredential $ (unwrap txOut).address
Credential.asPubKeyHash $ unwrap cred
availableUtxos' <- liftContract $
Map.filter isPkhUtxo <<< Map.filterKeys 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
Expand Down
55 changes: 53 additions & 2 deletions test/Testnet/Contract.purs
Original file line number Diff line number Diff line change
Expand Up @@ -166,7 +166,7 @@ import Data.Either (Either(Left, Right), hush, isLeft, isRight)
import Data.Foldable (fold, foldM, length)
import Data.Lens (view)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe, isJust)
import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe, isJust, maybe)
import Data.Newtype (unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
Expand Down Expand Up @@ -223,7 +223,7 @@ suite = do
withWallets distribution \alice -> do
withKeyWallet alice ManyAssets.contract
test
"#1509 - Collateral set to one of the inputs in mustNotSpendUtxosWithOutRefs "
"#1509 - Collateral set to one of the inputs in mustNotSpendUtxosWithOutRefs"
do
let
someUtxos =
Expand Down Expand Up @@ -253,6 +253,57 @@ suite = do
)
res `shouldSatisfy` isLeft

test
"#1581 - Fallback to CTL collateral selection when all collateral inputs are non-spendable"
do
let
distribution =
[ BigNum.fromInt 10_000_000
, BigNum.fromInt 10_000_000
]
withWallets distribution \alice ->
withKeyWallet alice do
validator <- AlwaysSucceeds.alwaysSucceedsScript
let vhash = validatorHash validator
logInfo' "Attempt to lock value"
txId <- AlwaysSucceeds.payToAlwaysSucceeds vhash
awaitTxConfirmed txId
logInfo' "Try to spend locked values"

scriptAddress <- mkAddress (wrap $ ScriptHashCredential vhash)
Nothing
utxos <- utxosAt scriptAddress
scriptUtxo <-
liftM
( error
( "The id "
<> show txId
<> " does not have output locked at: "
<> show scriptAddress
)
)
$ head (lookupTxHash txId utxos)

unbalancedTx <- buildTx
[ SpendOutput scriptUtxo $ Just $ PlutusScriptOutput
(ScriptValue validator)
RedeemerDatum.unit
(Just $ DatumValue PlutusData.unit)
]

collUtxos <- getWalletCollateral
let
balancerConstraints =
maybe
mempty
(mustNotSpendUtxosWithOutRefs <<< Map.keys <<< toUtxoMap)
collUtxos

balancedTx <- balanceTx unbalancedTx (toUtxoMap [ scriptUtxo ])
balancerConstraints
balancedSignedTx <- signTransaction balancedTx
submitAndLog balancedSignedTx

test "#1480 - test that does nothing but fails" do
let
someUtxos =
Expand Down

0 comments on commit 7987528

Please sign in to comment.