From e9c0f0404472c82038d1f1509bc0864376c5dede Mon Sep 17 00:00:00 2001 From: Dzmitry Shuysky Date: Thu, 28 Sep 2023 16:11:12 +0200 Subject: [PATCH] Merge branch 'dshuiski/blockfrost-additional-utxos' into dshuiski/purs15/blockfrost-additional-utxos --- CHANGELOG.md | 4 + README.md | 14 +- examples/AdditionalUtxos.purs | 133 +++++++++++++++++++ examples/ByUrl.purs | 11 +- examples/ChangeGeneration.purs | 77 +++++++++++ packages.dhall | 2 +- spago-packages.nix | 8 +- src/Internal/BalanceTx/BalanceTx.purs | 107 +++++++++------ src/Internal/BalanceTx/Error.purs | 4 +- src/Internal/BalanceTx/ExUnitsAndMinFee.purs | 47 ++++--- src/Internal/BalanceTx/Types.purs | 18 ++- src/Internal/Cardano/Types/Transaction.purs | 52 +++++++- src/Internal/Cardano/Types/Value.purs | 25 ++++ src/Internal/Contract/QueryHandle.purs | 9 +- src/Internal/QueryM/Ogmios.purs | 13 +- src/Internal/Service/Blockfrost.purs | 33 +++-- src/Internal/Types/PlutusData.purs | 29 +++- src/Internal/Types/TokenName.purs | 1 + test/BalanceTx/ChangeGeneration.purs | 45 +++++++ test/Plutip.purs | 2 + test/Plutip/Contract.purs | 25 +++- webpack.config.cjs | 3 + 22 files changed, 545 insertions(+), 117 deletions(-) create mode 100644 examples/AdditionalUtxos.purs create mode 100644 examples/ChangeGeneration.purs create mode 100644 test/BalanceTx/ChangeGeneration.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 29e2b6282d..e5af7a2165 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -70,6 +70,7 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) - [HD wallet support](./doc/key-management.md) with mnemonic seed phrases ([#1498](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1498)) - Ogmios-specific functions for Local TX Monitor Ouroboros Mini-Protocol in `Contract.Backend.Ogmios` ([#1508](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1508/)) - New `mustSendChangeWithDatum` balancer constraint that adds datum to all change outputs ([#1510](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1510/)) +- Full additional utxos support for Blockfrost backend ([#1537](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1537)) ### Changed @@ -91,6 +92,7 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) - Do not require light wallet collateral for all interactions ([#1477](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1477)) - Removed re-exports of wallet-related functions from `Contract.Utxos` and `Contract.Address` (use `Contract.Wallet`) ([#1477](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1477)) - `ownPaymentPubKeysHashes` renamed to `ownPaymentPubKeyHashes`, `ownStakePubKeysHashes` renamed to `ownStakePubKeyHashes` and both moved to `Contract.Wallet` ([#1477](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1477)) +- UTxO lists and combined input/output/mint/fee values are now being pretty-printed instead of logged using `Show` instance (in the balancer) ([#1531](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1531)) ### Fixed @@ -107,6 +109,8 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) - Add a single-slot wait at Plutip startup before attempting to query any wallet UTxOs ([#1470](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1470)) - Index `Reward` redeemers properly ([#1419](https://github.com/Plutonomicon/cardano-transaction-lib/issues/1419), [#1462](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1462)) - A problem with collateral selection not respecting `mustNotSpendUtxosWithOutRefs` ([#1509](https://github.com/Plutonomicon/cardano-transaction-lib/issues/1509)) +- A problem with too many change UTxOs being generated ([#1530](https://github.com/Plutonomicon/cardano-transaction-lib/issues/1530)) +- A problem where tx evaluation with additional utxos failed with an Ogmios `AdditionalUtxoOverlap` exception if some additional utxos got confirmed in the meantime ([#1537](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1537)) ### Removed diff --git a/README.md b/README.md index 0852dda31b..6a8fb1ab69 100644 --- a/README.md +++ b/README.md @@ -68,7 +68,7 @@ Support is planned for the following light wallets: - [x] [Lode](https://lodewallet.io/) - [x] [Eternl (formerly CCvault)](https://eternl.io/) - [x] [NuFi](https://nu.fi/) -- [ ] [Lace](https://www.lace.io/) +- [x] [Lace](https://www.lace.io/) - [ ] [Typhon](https://typhonwallet.io/) - [ ] [Yoroi](https://yoroi-wallet.com/) @@ -79,8 +79,8 @@ Support is planned for the following light wallets: - [x] **Stage 3** Once we have a simple working transaction, we will seek to build a Plutus smart contract transaction with datum from scratch - [x] **Stage 4** Once we can construct Plutus smart contract transactions, we will seek to build a library/DSL/interface such that transactions can be built using constraints and lookups - as close as possible to a cut-and-paste solution from Plutus' `Contract` monad code in Haskell (but with no guarantee that code changes are not necessary) - [x] **Stage 4.1** Investigate supporting compatibility with the Vasil hardfork and improvements to our initial `Contract` API -- [ ] **Stage 5** Once we have a basic `Contract`-style API, we will further refine its public interface, expand wallet support (see [below](#light-wallet-support)), expose a test interface (**DONE** - see [here](doc/plutip-testing.md)), provide a more ergonomic JS/TS API, support stake validators (**DONE**), and support CIP workflows on the public testnet (**In progress**) -- [ ] **Stage 6** Once CTL's `Contract` interface has been stabilized, we will add support for even more wallets and attempt to deprecate CTL's currently required Haskell server (**DONE**) +- [x] **Stage 5** Once we have a basic `Contract`-style API, we will further refine its public interface, expand wallet support (see [below](#light-wallet-support)), expose a test interface (**DONE** - see [here](doc/plutip-testing.md)), provide a more ergonomic JS/TS API, support stake validators (**DONE**), and support CIP workflows on the public testnet (**In progress**) +- [x] **Stage 6** Once CTL's `Contract` interface has been stabilized, we will add support for even more wallets and attempt to deprecate CTL's currently required Haskell server (**DONE**) ## Architecture @@ -90,12 +90,10 @@ CTL is directly inspired by the Plutus Application Backend (PAB). Unlike PAB, ho - This is handled by `cardano-serialization-lib`, a Rust library available as WASM 2. How do we query the chain? - This has been solved using Ogmios & Kupo - - We [will support](https://cardano.ideascale.com/c/idea/420791) an alternative [BlockFrost](https://blockfrost.io/) backend as well in the future -3. How do we query for datums (i.e. the datums themselves and not just their hashes)? - - `Kupo` solves this problem -4. How do we get wallet data? + - Thanks to [Catalyst](https://cardano.ideascale.com/c/idea/420791), we now support an alternative [BlockFrost](https://blockfrost.io/) backend as well +3. How do we get wallet data? - This is done via browser-based light wallet integration in the browser based on CIP-30 -5. How closely should we follow Plutus' `Contract` API? +4. How closely should we follow Plutus' `Contract` API? - CTL's `Contract` model is **significantly** less restrictive than Plutus' and allows for arbitrary effects within the `Contract` monad - Certain features cannot be directly translated into Purescript from Haskell due to differences between the two languages - Some of the Plutus conventions do not make sense for us, due to differences between on-chain and off-chain diff --git a/examples/AdditionalUtxos.purs b/examples/AdditionalUtxos.purs new file mode 100644 index 0000000000..18294ed2ae --- /dev/null +++ b/examples/AdditionalUtxos.purs @@ -0,0 +1,133 @@ +module Ctl.Examples.AdditionalUtxos + ( contract + , main + ) where + +import Contract.Prelude + +import Contract.Address (scriptHashAddress) +import Contract.BalanceTxConstraints (BalanceTxConstraintsBuilder) +import Contract.BalanceTxConstraints (mustUseAdditionalUtxos) as BalancerConstraints +import Contract.Config (ContractParams, testnetNamiConfig) +import Contract.Log (logInfo') +import Contract.Monad (Contract, launchAff_, liftedE, runContract) +import Contract.PlutusData (Datum, PlutusData(Integer), unitRedeemer) +import Contract.ScriptLookups (ScriptLookups, UnbalancedTx, mkUnbalancedTx) +import Contract.ScriptLookups (datum, unspentOutputs, validator) as Lookups +import Contract.Scripts (Validator, ValidatorHash, validatorHash) +import Contract.Sync (withoutSync) +import Contract.Transaction + ( ScriptRef(NativeScriptRef) + , TransactionInput + , awaitTxConfirmed + , balanceTxWithConstraints + , createAdditionalUtxos + , signTransaction + , submit + , withBalancedTx + ) +import Contract.TxConstraints + ( DatumPresence(DatumInline, DatumWitness) + , TxConstraints + ) +import Contract.TxConstraints + ( mustPayToScript + , mustPayToScriptWithScriptRef + , mustSpendPubKeyOutput + , mustSpendScriptOutput + ) as Constraints +import Contract.Utxos (UtxoMap) +import Contract.Value (Value) +import Contract.Value (lovelaceValueOf) as Value +import Ctl.Examples.PlutusV2.Scripts.AlwaysSucceeds (alwaysSucceedsScriptV2) +import Data.Array (fromFoldable) as Array +import Data.BigInt (fromInt) as BigInt +import Data.Map (difference, filter, keys) as Map +import Test.QuickCheck (arbitrary) +import Test.QuickCheck.Gen (randomSampleOne) + +main :: Effect Unit +main = example testnetNamiConfig + +example :: ContractParams -> Effect Unit +example contractParams = + launchAff_ $ runContract contractParams $ contract false + +contract :: Boolean -> Contract Unit +contract testAdditionalUtxoOverlap = withoutSync do + logInfo' "Running Examples.AdditionalUtxos" + validator <- alwaysSucceedsScriptV2 + let vhash = validatorHash validator + { unbalancedTx, datum } <- payToValidator vhash + withBalancedTx unbalancedTx \balancedTx -> do + balancedSignedTx <- signTransaction balancedTx + txHash <- submit balancedSignedTx + when testAdditionalUtxoOverlap $ awaitTxConfirmed txHash + logInfo' "Successfully locked two outputs at the validator address." + + additionalUtxos <- createAdditionalUtxos balancedSignedTx + spendFromValidator validator additionalUtxos datum + +payToValidator + :: ValidatorHash -> Contract { unbalancedTx :: UnbalancedTx, datum :: Datum } +payToValidator vhash = do + scriptRef <- liftEffect (NativeScriptRef <$> randomSampleOne arbitrary) + let + value :: Value + value = Value.lovelaceValueOf $ BigInt.fromInt 2_000_000 + + datum :: Datum + datum = wrap $ Integer $ BigInt.fromInt 42 + + constraints :: TxConstraints Unit Unit + constraints = + Constraints.mustPayToScript vhash datum DatumWitness value + <> Constraints.mustPayToScriptWithScriptRef vhash datum DatumInline + scriptRef + value + + lookups :: ScriptLookups PlutusData + lookups = Lookups.datum datum + + unbalancedTx <- liftedE $ mkUnbalancedTx lookups constraints + pure { unbalancedTx, datum } + +spendFromValidator :: Validator -> UtxoMap -> Datum -> Contract Unit +spendFromValidator validator additionalUtxos datum = do + let + scriptUtxos :: UtxoMap + scriptUtxos = + additionalUtxos # Map.filter \out -> + (unwrap (unwrap out).output).address + == scriptHashAddress (validatorHash validator) Nothing + + scriptOrefs :: Array TransactionInput + scriptOrefs = Array.fromFoldable $ Map.keys scriptUtxos + + pubKeyOrefs :: Array TransactionInput + pubKeyOrefs = + Array.fromFoldable $ Map.keys $ Map.difference additionalUtxos scriptUtxos + + constraints :: TxConstraints Unit Unit + constraints = + foldMap (flip Constraints.mustSpendScriptOutput unitRedeemer) scriptOrefs + <> foldMap Constraints.mustSpendPubKeyOutput pubKeyOrefs + + lookups :: ScriptLookups PlutusData + lookups = + Lookups.validator validator + <> Lookups.unspentOutputs additionalUtxos + <> Lookups.datum datum + + balancerConstraints :: BalanceTxConstraintsBuilder + balancerConstraints = + BalancerConstraints.mustUseAdditionalUtxos additionalUtxos + + unbalancedTx <- liftedE $ mkUnbalancedTx lookups constraints + balancedTx <- liftedE $ balanceTxWithConstraints unbalancedTx + balancerConstraints + balancedSignedTx <- signTransaction balancedTx + txHash <- submit balancedSignedTx + + awaitTxConfirmed txHash + logInfo' "Successfully spent additional utxos from the validator address." diff --git a/examples/ByUrl.purs b/examples/ByUrl.purs index e8d06bbdd8..8f00edce06 100644 --- a/examples/ByUrl.purs +++ b/examples/ByUrl.purs @@ -32,8 +32,10 @@ import Contract.Config ) import Contract.Monad (Contract) import Contract.Test.E2E (E2EConfigName, E2ETestName, addLinks, route) +import Ctl.Examples.AdditionalUtxos as AdditionalUtxos import Ctl.Examples.AlwaysMints as AlwaysMints import Ctl.Examples.AlwaysSucceeds as AlwaysSucceeds +import Ctl.Examples.ChangeGeneration as ChangeGeneration import Ctl.Examples.Cip30 as Cip30 import Ctl.Examples.Datums as Datums import Ctl.Examples.DropTokens as DropTokens @@ -191,7 +193,8 @@ mkBlockfrostPreprodConfig apiKey = examples :: Map E2ETestName (Contract Unit) examples = Map.fromFoldable - [ "AlwaysMints" /\ AlwaysMints.contract + [ "AdditionalUtxos" /\ AdditionalUtxos.contract false + , "AlwaysMints" /\ AlwaysMints.contract , "NativeScriptMints" /\ NativeScriptMints.contract , "AlwaysSucceeds" /\ AlwaysSucceeds.contract , "AlwaysSucceedsV2" /\ AlwaysSucceedsV2.contract @@ -214,4 +217,10 @@ examples = Map.fromFoldable , "ECDSA" /\ ECDSA.contract , "PaysWithDatum" /\ PaysWithDatum.contract , "DropTokens" /\ DropTokens.contract + , "ChangeGeneration1-1" /\ + ChangeGeneration.checkChangeOutputsDistribution 1 1 3 + , "ChangeGeneration3-1" /\ + ChangeGeneration.checkChangeOutputsDistribution 3 1 5 + , "ChangeGeneration1-3" /\ + ChangeGeneration.checkChangeOutputsDistribution 1 3 7 ] diff --git a/examples/ChangeGeneration.purs b/examples/ChangeGeneration.purs new file mode 100644 index 0000000000..9e74a98228 --- /dev/null +++ b/examples/ChangeGeneration.purs @@ -0,0 +1,77 @@ +module Ctl.Examples.ChangeGeneration (checkChangeOutputsDistribution) where + +import Prelude + +import Contract.BalanceTxConstraints (mustSendChangeWithDatum) +import Contract.Monad (Contract, liftedE) +import Contract.PlutusData + ( Datum(Datum) + , OutputDatum(OutputDatum) + , PlutusData(Integer) + , unitDatum + ) +import Contract.ScriptLookups as Lookups +import Contract.Scripts (validatorHash) +import Contract.Transaction + ( _body + , _outputs + , awaitTxConfirmed + , balanceTxWithConstraints + , signTransaction + , submit + ) +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, length, replicate, take, zip) +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 1000001 + + constraintsToSelf :: TxConstraints Unit Unit + constraintsToSelf = fold <<< take outputsToSelf <<< 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 $ balanceTxWithConstraints unbalancedTx + -- just to check that attaching datums works + ( mustSendChangeWithDatum $ OutputDatum $ Datum $ Integer $ BigInt.fromInt + 1000 + ) + balancedSignedTx <- signTransaction balancedTx + let outputs = balancedTx ^. to unwrap <<< _body <<< _outputs + length outputs `shouldEqual` expectedOutputs + txHash <- submit balancedSignedTx + awaitTxConfirmed txHash diff --git a/packages.dhall b/packages.dhall index f1adb8dccb..2396b06dad 100644 --- a/packages.dhall +++ b/packages.dhall @@ -233,7 +233,7 @@ let additions = , "node-fs-aff" ] , repo = "https://github.com/mlabs-haskell/purescript-toppokki" - , version = "b043e9342463df76972d05981ac4ec25316834bf" + , version = "f90f92f0ddf0eecc73705c1675db37918d18cbcb" } , noble-secp256k1 = { dependencies = diff --git a/spago-packages.nix b/spago-packages.nix index aab9a94b96..4bf01bebdf 100644 --- a/spago-packages.nix +++ b/spago-packages.nix @@ -1171,11 +1171,11 @@ let "purescript-toppokki" = pkgs.stdenv.mkDerivation { name = "purescript-toppokki"; - version = "b043e9342463df76972d05981ac4ec25316834bf"; + version = "f90f92f0ddf0eecc73705c1675db37918d18cbcb"; src = pkgs.fetchgit { - url = "https://github.com/errfrom/purescript-toppokki"; - rev = "b043e9342463df76972d05981ac4ec25316834bf"; - sha256 = "0kkk4xfnkq6fqr30d95i3x4r6z9479bx7v0ama7xf36pr0y26lk1"; + url = "https://github.com/mlabs-haskell/purescript-toppokki"; + rev = "f90f92f0ddf0eecc73705c1675db37918d18cbcb"; + sha256 = "1kmqajf7n5l9lk4amyma3rhm60llrgamap5hi21kkqs52xm3fr2q"; }; phases = "installPhase"; installPhase = "ln -s $src $out"; diff --git a/src/Internal/BalanceTx/BalanceTx.purs b/src/Internal/BalanceTx/BalanceTx.purs index cd32f07fda..4f924ac5e8 100644 --- a/src/Internal/BalanceTx/BalanceTx.purs +++ b/src/Internal/BalanceTx/BalanceTx.purs @@ -6,10 +6,9 @@ module Ctl.Internal.BalanceTx import Prelude -import Contract.Log (logTrace') import Control.Monad.Error.Class (catchError, liftMaybe, throwError) import Control.Monad.Except.Trans (ExceptT(ExceptT), except, runExceptT) -import Control.Monad.Logger.Class (trace) as Logger +import Control.Monad.Logger.Class (info) as Logger import Control.Monad.Reader (asks) import Control.Parallel (parTraverse) import Ctl.Internal.BalanceTx.CoinSelection @@ -107,6 +106,7 @@ import Ctl.Internal.Cardano.Types.Transaction , _referenceInputs , _withdrawals , _witnessSet + , pprintUtxoMap ) import Ctl.Internal.Cardano.Types.TransactionUnspentOutput ( TransactionUnspentOutput(TransactionUnspentOutput) @@ -122,6 +122,7 @@ import Ctl.Internal.Cardano.Types.Value , minus , mkValue , posNonAdaAsset + , pprintValue , valueToCoin' ) import Ctl.Internal.Cardano.Types.Value as Value @@ -146,8 +147,7 @@ import Ctl.Internal.Types.Transaction (TransactionInput) import Data.Array as Array import Data.Array.NonEmpty (NonEmptyArray) import Data.Array.NonEmpty - ( cons' - , fromArray + ( fromArray , replicate , singleton , sortWith @@ -159,17 +159,19 @@ import Data.Array.NonEmpty import Data.Array.NonEmpty as NEA import Data.Bifunctor (lmap) import Data.BigInt (BigInt) +import Data.BigInt (toString) as BigInt import Data.Either (Either, hush, note) import Data.Foldable (any, fold, foldMap, foldr, length, null, or, sum) import Data.Function (on) import Data.Lens.Getter ((^.)) import Data.Lens.Setter ((%~), (.~), (?~)) -import Data.Log.Tag (TagSet) -import Data.Log.Tag (fromArray, tag) as TagSet +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.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) @@ -237,9 +239,10 @@ balanceTxWithConstraints transaction extraUtxos constraintsBuilder = do utxos `Map.union` extraUtxos availableUtxos <- liftContract $ filterLockedUtxos allUtxos - logTrace' $ "balanceTxWithConstraints: all UTxOs: " <> show allUtxos - logTrace' $ "balanceTxWithConstraints: available UTxOs: " <> show - availableUtxos + + Logger.info (pprintUtxoMap allUtxos) "balanceTxWithConstraints: all UTxOs" + Logger.info (pprintUtxoMap availableUtxos) + "balanceTxWithConstraints: available UTxOs" selectionStrategy <- asksConstraints Constraints._selectionStrategy @@ -454,7 +457,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 @@ -561,14 +567,27 @@ 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 +-- | +-- | 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 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 @@ -591,6 +610,12 @@ makeChange changeAddress changeDatum inputValue certsFee txBody = changeValueOutputCoinPairs = outputCoins # NEArray.zip changeForAssets # NEArray.sortWith (AssetCount <<< fst) + where + outputCoins :: NonEmptyArray BigInt + outputCoins = + NEArray.fromArray + (valueToCoin' <<< _.amount <<< unwrap <$> ownAddressOutputs) + ?? NEArray.singleton zero splitOversizedValues :: NonEmptyArray (Value /\ BigInt) @@ -610,20 +635,19 @@ makeChange changeAddress changeDatum inputValue certsFee txBody = unbundle :: Value -> Value /\ BigInt unbundle (Value coin assets) = mkValue mempty assets /\ unwrap coin + -- outputs belonging to one of the wallet's addresses. + ownAddressOutputs :: Array TransactionOutput + ownAddressOutputs = Array.filter isOwnWalletAddress $ txBody ^. _outputs + where + isOwnWalletAddress = unwrap >>> _.address >>> flip Set.member + ownWalletAddresses + 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 - outputCoins = - NEArray.fromArray (valueToCoin' <<< _.amount <<< unwrap <$> txOutputs) - ?? NEArray.singleton zero - - txOutputs :: Array TransactionOutput - txOutputs = txBody ^. _outputs - excessAssets :: Array (AssetClass /\ BigInt) excessAssets = Value.valueAssets excessValue @@ -653,8 +677,10 @@ 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#L1729 makeChangeForAsset - :: Array TransactionOutput -> (AssetClass /\ BigInt) -> NonEmptyArray Value -makeChangeForAsset txOutputs (assetClass /\ excess) = + :: Array TransactionOutput + -> (AssetClass /\ BigInt) + -> NonEmptyArray Value +makeChangeForAsset ownAddressOutputs (assetClass /\ excess) = Value.assetToValue assetClass <$> partition excess weights ?? equipartition excess (length weights) where @@ -663,7 +689,8 @@ makeChangeForAsset txOutputs (assetClass /\ excess) = assetQuantities :: Array BigInt assetQuantities = - txOutputs <#> Value.getAssetQuantity assetClass <<< _.amount <<< unwrap + ownAddressOutputs <#> Value.getAssetQuantity assetClass <<< _.amount <<< + unwrap -- | Constructs an array of ada change outputs based on the given distribution. -- | @@ -716,22 +743,22 @@ assignCoinsToChangeValues changeAddress adaAvailable pairsAtStart = worker (adaRequiredAtStart changeValues) changeValues where worker :: BigInt -> NonEmptyArray ChangeValue -> Array Value - worker adaRequired = NEArray.uncons >>> case _ of + worker adaRequired changeValues = changeValues # NEArray.uncons >>> case _ of { head: x, tail } | Just xs <- NEA.fromArray tail , adaAvailable < adaRequired && noTokens x -> worker (adaRequired - x.minCoin) xs - { head: x, tail: xs } -> + _ -> let - changeValues :: NonEmptyArray ChangeValue - changeValues = NEArray.cons' x xs - adaRemaining :: BigInt adaRemaining = max zero (adaAvailable - adaRequired) changeValuesForOutputCoins :: NonEmptyArray Value changeValuesForOutputCoins = - makeChangeForCoin (_.outputAda <$> changeValues) adaRemaining + let + weights = _.outputAda <$> changeValues + in + makeChangeForCoin weights adaRemaining changeValuesWithMinCoins :: NonEmptyArray Value changeValuesWithMinCoins = assignMinCoin <$> changeValues @@ -859,24 +886,22 @@ logTransactionWithChange message utxos mChangeOutputs tx = txBody :: TxBody txBody = tx ^. _body - tag :: forall (a :: Type). Show a => String -> a -> TagSet - tag title = TagSet.tag title <<< show - outputValuesTagSet :: Maybe (Array TransactionOutput) -> Array TagSet outputValuesTagSet Nothing = - [ "Output Value" `tag` outputValue txBody ] + [ "Output Value" `tagSetTag` pprintValue (outputValue txBody) ] outputValuesTagSet (Just changeOutputs) = - [ "Output Value without change" `tag` outputValue txBody - , "Change Value" `tag` foldMap getAmount changeOutputs + [ "Output Value without change" `tagSetTag` pprintValue + (outputValue txBody) + , "Change Value" `tagSetTag` pprintValue (foldMap getAmount changeOutputs) ] transactionInfo :: Value -> TagSet transactionInfo inputValue = TagSet.fromArray $ - [ "Input Value" `tag` inputValue - , "Mint Value" `tag` mintValue txBody - , "Fees" `tag` (txBody ^. _fee) + [ "Input Value" `tagSetTag` pprintValue inputValue + , "Mint Value" `tagSetTag` pprintValue (mintValue txBody) + , "Fees" `tag` BigInt.toString (unwrap (txBody ^. _fee)) ] <> outputValuesTagSet mChangeOutputs in except (getInputValue utxos txBody) - >>= (flip Logger.trace (message <> ":") <<< transactionInfo) + >>= (flip Logger.info (message <> ":") <<< transactionInfo) diff --git a/src/Internal/BalanceTx/Error.purs b/src/Internal/BalanceTx/Error.purs index d4678387f2..d2ebd84295 100644 --- a/src/Internal/BalanceTx/Error.purs +++ b/src/Internal/BalanceTx/Error.purs @@ -45,7 +45,7 @@ import Ctl.Internal.QueryM.Ogmios , IllFormedExecutionBudget , NoCostModelForLanguage ) - , TxEvaluationFailure(UnparsedError, ScriptFailures) + , TxEvaluationFailure(UnparsedError, AdditionalUtxoOverlap, ScriptFailures) ) as Ogmios import Ctl.Internal.Types.Natural (toBigInt) as Natural import Ctl.Internal.Types.Transaction (TransactionInput) @@ -173,6 +173,8 @@ printTxEvaluationFailure printTxEvaluationFailure transaction e = runPrettyString $ case e of Ogmios.UnparsedError error -> line $ "Unknown error: " <> error + Ogmios.AdditionalUtxoOverlap utxos -> + line $ "AdditionalUtxoOverlap: " <> show utxos Ogmios.ScriptFailures sf -> line "Script failures:" <> bullet (foldMapWithIndex printScriptFailures sf) where diff --git a/src/Internal/BalanceTx/ExUnitsAndMinFee.purs b/src/Internal/BalanceTx/ExUnitsAndMinFee.purs index ade5c9ac3c..a5f3040fca 100644 --- a/src/Internal/BalanceTx/ExUnitsAndMinFee.purs +++ b/src/Internal/BalanceTx/ExUnitsAndMinFee.purs @@ -45,6 +45,7 @@ import Ctl.Internal.Contract.Monad (getQueryHandle) import Ctl.Internal.Plutus.Conversion (fromPlutusUtxoMap) import Ctl.Internal.QueryM.Ogmios ( AdditionalUtxoSet + , TxEvaluationFailure(AdditionalUtxoOverlap) , TxEvaluationResult(TxEvaluationResult) ) as Ogmios import Ctl.Internal.QueryM.Ogmios (TxEvaluationFailure(UnparsedError)) @@ -58,14 +59,14 @@ import Ctl.Internal.Types.Natural (toBigInt) as Natural import Ctl.Internal.Types.Scripts (Language, PlutusScript) import Ctl.Internal.Types.Transaction (TransactionInput) import Data.Array (catMaybes) -import Data.Array (fromFoldable) as Array +import Data.Array (fromFoldable, notElem) as Array import Data.Bifunctor (bimap) import Data.BigInt (BigInt) import Data.Either (Either(Left, Right), note) import Data.Foldable (foldMap) import Data.Lens.Getter ((^.)) import Data.Lens.Setter ((?~)) -import Data.Map (empty, fromFoldable, lookup, toUnfoldable) as Map +import Data.Map (empty, filterKeys, fromFoldable, lookup, toUnfoldable) as Map import Data.Maybe (Maybe(Just, Nothing), fromMaybe) import Data.Newtype (unwrap, wrap) import Data.Set (Set) @@ -80,29 +81,35 @@ evalTxExecutionUnits :: Transaction -> BalanceTxM Ogmios.TxEvaluationResult evalTxExecutionUnits tx = do - queryHandle <- liftContract getQueryHandle - additionalUtxos <- getOgmiosAdditionalUtxoSet - evalResult <- - unwrap <$> liftContract - (liftAff $ queryHandle.evaluateTx tx additionalUtxos) - - case evalResult of - Right a -> pure a - Left evalFailure | tx ^. _isValid -> - throwError $ ExUnitsEvaluationFailed tx evalFailure - Left _ -> pure $ wrap Map.empty + networkId <- askNetworkId + additionalUtxos <- + fromPlutusUtxoMap networkId <$> asksConstraints Constraints._additionalUtxos + worker $ toOgmiosAdditionalUtxos additionalUtxos where - getOgmiosAdditionalUtxoSet :: BalanceTxM Ogmios.AdditionalUtxoSet - getOgmiosAdditionalUtxoSet = do - networkId <- askNetworkId - additionalUtxos <- - asksConstraints Constraints._additionalUtxos - <#> fromPlutusUtxoMap networkId - pure $ wrap $ Map.fromFoldable + toOgmiosAdditionalUtxos :: UtxoMap -> Ogmios.AdditionalUtxoSet + toOgmiosAdditionalUtxos additionalUtxos = + wrap $ Map.fromFoldable ( bimap transactionInputToTxOutRef transactionOutputToOgmiosTxOut <$> (Map.toUnfoldable :: _ -> Array _) additionalUtxos ) + worker :: Ogmios.AdditionalUtxoSet -> BalanceTxM Ogmios.TxEvaluationResult + worker additionalUtxos = do + queryHandle <- liftContract getQueryHandle + evalResult <- + unwrap <$> liftContract + (liftAff $ queryHandle.evaluateTx tx additionalUtxos) + case evalResult of + Right a -> pure a + Left (Ogmios.AdditionalUtxoOverlap overlappingUtxos) -> + -- Remove overlapping additional utxos and retry evaluation: + worker $ wrap $ Map.filterKeys (flip Array.notElem overlappingUtxos) + (unwrap additionalUtxos) + Left evalFailure | tx ^. _isValid -> + throwError $ ExUnitsEvaluationFailed tx evalFailure + Left _ -> + pure $ wrap Map.empty + -- Calculates the execution units needed for each script in the transaction -- and the minimum fee, including the script fees. -- Returns a tuple consisting of updated `UnbalancedTx` and the minimum fee. 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/src/Internal/Cardano/Types/Transaction.purs b/src/Internal/Cardano/Types/Transaction.purs index 629a943c77..3472465eef 100644 --- a/src/Internal/Cardano/Types/Transaction.purs +++ b/src/Internal/Cardano/Types/Transaction.purs @@ -54,6 +54,7 @@ module Ctl.Internal.Cardano.Types.Transaction , UnitInterval , Update , UtxoMap + , pprintUtxoMap , Vkey(Vkey) , Vkeywitness(Vkeywitness) , _auxiliaryData @@ -100,7 +101,7 @@ import Control.Alternative ((<|>)) import Control.Apply (lift2) import Ctl.Internal.Cardano.Types.NativeScript (NativeScript) import Ctl.Internal.Cardano.Types.ScriptRef (ScriptRef) -import Ctl.Internal.Cardano.Types.Value (Coin, NonAdaAsset, Value) +import Ctl.Internal.Cardano.Types.Value (Coin, NonAdaAsset, Value, pprintValue) import Ctl.Internal.Deserialization.FromBytes (fromBytes) import Ctl.Internal.Deserialization.Keys ( ed25519SignatureFromBech32 @@ -113,6 +114,7 @@ import Ctl.Internal.Serialization.Address , NetworkId , Slot(Slot) , StakeCredential + , addressBech32 ) import Ctl.Internal.Serialization.Hash ( Ed25519KeyHash @@ -130,16 +132,18 @@ import Ctl.Internal.Serialization.Types (Ed25519Signature, PublicKey) as Seriali import Ctl.Internal.ToData (class ToData, toData) import Ctl.Internal.Types.Aliases (Bech32String) import Ctl.Internal.Types.BigNum (BigNum) -import Ctl.Internal.Types.ByteArray (ByteArray) +import Ctl.Internal.Types.ByteArray (ByteArray, byteArrayToHex) import Ctl.Internal.Types.Int as Int -import Ctl.Internal.Types.OutputDatum (OutputDatum) -import Ctl.Internal.Types.PlutusData (PlutusData) +import Ctl.Internal.Types.OutputDatum + ( OutputDatum(NoOutputDatum, OutputDatumHash, OutputDatum) + ) +import Ctl.Internal.Types.PlutusData (PlutusData, pprintPlutusData) import Ctl.Internal.Types.PubKeyHash (PaymentPubKeyHash, PubKeyHash(PubKeyHash)) import Ctl.Internal.Types.RawBytes (RawBytes) import Ctl.Internal.Types.RedeemerTag (RedeemerTag) import Ctl.Internal.Types.RewardAddress (RewardAddress) import Ctl.Internal.Types.Scripts (Language, PlutusScript) -import Ctl.Internal.Types.Transaction (TransactionInput) +import Ctl.Internal.Types.Transaction (TransactionInput(TransactionInput)) import Ctl.Internal.Types.TransactionMetadata (GeneralTransactionMetadata) import Ctl.Internal.Types.VRFKeyHash (VRFKeyHash) import Data.Array (union) @@ -150,8 +154,11 @@ import Data.Lens (lens') import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) import Data.Lens.Types (Lens') +import Data.Log.Tag (TagSet, tag, tagSetTag) +import Data.Log.Tag as TagSet import Data.Map (Map) -import Data.Maybe (Maybe(Nothing), fromJust) +import Data.Map as Map +import Data.Maybe (Maybe(Just, Nothing), fromJust) import Data.Monoid (guard) import Data.Newtype (class Newtype, unwrap, wrap) import Data.Set (Set) @@ -159,8 +166,9 @@ import Data.Set (union) as Set import Data.Show.Generic (genericShow) import Data.String.Utils (startsWith) import Data.Tuple (Tuple(Tuple)) -import Data.Tuple.Nested (type (/\)) +import Data.Tuple.Nested (type (/\), (/\)) import Data.UInt (UInt) +import Data.UInt as UInt import Partial.Unsafe (unsafePartial) import Type.Proxy (Proxy(Proxy)) @@ -965,3 +973,33 @@ instance Show TransactionOutput where show = genericShow type UtxoMap = Map TransactionInput TransactionOutput + +pprintUtxoMap :: UtxoMap -> TagSet +pprintUtxoMap utxos = TagSet.fromArray $ + Map.toUnfoldable utxos <#> + \( TransactionInput { transactionId, index } /\ + TransactionOutput { address, amount, datum, scriptRef } + ) -> + let + datumTagSets = case datum of + NoOutputDatum -> [] + OutputDatumHash datumHash -> + [ TagSet.fromArray + [ "datum hash" `tag` byteArrayToHex (unwrap datumHash) ] + ] + OutputDatum plutusData -> + [ TagSet.fromArray + [ "datum" `tagSetTag` pprintPlutusData (unwrap plutusData) ] + ] + scriptRefTagSets = case scriptRef of + Nothing -> [] + Just ref -> [ "Script Reference" `tag` show ref ] + outputTagSet = + [ "amount" `tagSetTag` pprintValue amount + , "address" `tag` addressBech32 address + ] + <> datumTagSets + <> scriptRefTagSets + in + (byteArrayToHex (unwrap transactionId) <> "#" <> UInt.toString index) + `tagSetTag` TagSet.fromArray outputTagSet diff --git a/src/Internal/Cardano/Types/Value.purs b/src/Internal/Cardano/Types/Value.purs index ace38f6898..1143621e28 100644 --- a/src/Internal/Cardano/Types/Value.purs +++ b/src/Internal/Cardano/Types/Value.purs @@ -43,6 +43,8 @@ module Ctl.Internal.Cardano.Types.Value , numNonAdaCurrencySymbols , numTokenNames , posNonAdaAsset + , pprintNonAdaAsset + , pprintValue , scriptHashAsCurrencySymbol , split , sumTokenNameLengths @@ -90,6 +92,7 @@ import Ctl.Internal.Types.Scripts (MintingPolicyHash(MintingPolicyHash)) import Ctl.Internal.Types.TokenName ( TokenName , adaToken + , fromTokenName , getTokenName , mkTokenName , mkTokenNames @@ -100,6 +103,7 @@ import Data.Array.NonEmpty (NonEmptyArray) import Data.Array.NonEmpty (replicate, singleton, zipWith) as NEArray import Data.Bifunctor (bimap) import Data.BigInt (BigInt, fromInt, toNumber) +import Data.BigInt as BigInt import Data.Bitraversable (bitraverse, ltraverse) import Data.Either (Either(Left), note) import Data.Foldable (any, fold, foldl, length) @@ -110,6 +114,8 @@ import Data.Int (ceil) as Int import Data.Lattice (class JoinSemilattice, class MeetSemilattice, join, meet) import Data.List (List(Nil), all, (:)) import Data.List (nubByEq) as List +import Data.Log.Tag (TagSet, tag, tagSetTag) +import Data.Log.Tag as TagSet import Data.Map (Map, keys, lookup, toUnfoldable, unions, values) import Data.Map as Map import Data.Map.Gen (genMap) @@ -338,6 +344,15 @@ instance Equipartition NonAdaAsset where map (mkSingletonNonAdaAsset cs tn) (equipartition tokenQuantity numParts) +pprintNonAdaAsset :: NonAdaAsset -> TagSet +pprintNonAdaAsset mp = TagSet.fromArray $ + Map.toUnfoldable (unwrapNonAdaAsset mp) <#> \(currency /\ tokens) -> + byteArrayToHex (getCurrencySymbol currency) `tagSetTag` TagSet.fromArray + ( Map.toUnfoldable tokens <#> \(tokenName /\ amount) -> + fromTokenName byteArrayToHex show tokenName `tag` BigInt.toString + amount + ) + -- | Partitions a `NonAdaAsset` into smaller `NonAdaAsset`s, where the -- | quantity of each token is equipartitioned across the resultant -- | `NonAdaAsset`s, with the goal that no token quantity in any of the @@ -483,6 +498,16 @@ instance Equipartition Value where (equipartition coin numParts) (equipartition nonAdaAssets numParts) +pprintValue :: Value -> TagSet +pprintValue value = TagSet.fromArray $ + [ "ADA" `tag` BigInt.toString (unwrap (valueToCoin value)) ] + <> + if nonAdaAssets /= mempty then + [ "Assets" `tagSetTag` pprintNonAdaAsset nonAdaAssets ] + else [] + where + nonAdaAssets = getNonAdaAsset value + -- | Partitions a `Value` into smaller `Value`s, where the Ada amount and the -- | quantity of each token is equipartitioned across the resultant `Value`s, -- | with the goal that no token quantity in any of the resultant `Value`s diff --git a/src/Internal/Contract/QueryHandle.purs b/src/Internal/Contract/QueryHandle.purs index af8d17468d..5531fe5ae4 100644 --- a/src/Internal/Contract/QueryHandle.purs +++ b/src/Internal/Contract/QueryHandle.purs @@ -6,7 +6,7 @@ module Ctl.Internal.Contract.QueryHandle import Prelude -import Contract.Log (logDebug', logWarn') +import Contract.Log (logDebug') import Control.Monad.Error.Class (throwError) import Ctl.Internal.Contract.LogParams (LogParams) import Ctl.Internal.Contract.QueryBackend (BlockfrostBackend, CtlBackend) @@ -40,7 +40,6 @@ import Ctl.Internal.Service.Blockfrost import Ctl.Internal.Service.Blockfrost as Blockfrost import Ctl.Internal.Service.Error (ClientError(ClientOtherError)) import Data.Either (Either(Left, Right)) -import Data.Map as Map import Data.Maybe (fromMaybe, isJust) import Data.Newtype (unwrap, wrap) import Effect.Aff (Aff) @@ -107,10 +106,8 @@ queryHandleForBlockfrostBackend logParams backend = Right epoch -> pure $ wrap epoch Left err -> throwError $ error $ show err , submitTx: runBlockfrostServiceM' <<< Blockfrost.submitTx - , evaluateTx: \tx additionalUtxos -> runBlockfrostServiceM' do - unless (Map.isEmpty $ unwrap additionalUtxos) do - logWarn' "Blockfrost does not support explicit additional utxos" - Blockfrost.evaluateTx tx + , evaluateTx: \tx additionalUtxos -> + runBlockfrostServiceM' $ Blockfrost.evaluateTx tx additionalUtxos , getEraSummaries: runBlockfrostServiceM' Blockfrost.getEraSummaries , getPoolIds: runBlockfrostServiceM' Blockfrost.getPoolIds , getPubKeyHashDelegationsAndRewards: \networkId stakePubKeyHash -> diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 89e4f338c5..2f2a898ebb 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -38,7 +38,7 @@ module Ctl.Internal.QueryM.Ogmios , OgmiosTxIn , OgmiosTxId , SubmitTxR(SubmitTxSuccess, SubmitFail) - , TxEvaluationFailure(UnparsedError, ScriptFailures) + , TxEvaluationFailure(UnparsedError, AdditionalUtxoOverlap, ScriptFailures) , TxEvaluationResult(TxEvaluationResult) , TxEvaluationR(TxEvaluationR) , PoolIdsR @@ -180,6 +180,7 @@ import Ctl.Internal.Types.SystemStart , sysStartToOgmiosTimestamp ) import Ctl.Internal.Types.TokenName (TokenName, getTokenName, mkTokenName) +import Ctl.Internal.Types.Transaction (TransactionInput) import Ctl.Internal.Types.VRFKeyHash (VRFKeyHash(VRFKeyHash)) import Data.Array (catMaybes, index) import Data.Array (head, length, replicate) as Array @@ -768,11 +769,11 @@ instance Show ScriptFailure where -- The following cases are fine to fall through into unparsed error: -- IncompatibleEra --- AdditionalUtxoOverlap -- NotEnoughSynced -- CannotCreateEvaluationContext data TxEvaluationFailure = UnparsedError String + | AdditionalUtxoOverlap (Array OgmiosTxOutRef) | ScriptFailures (Map RedeemerPointer (Array ScriptFailure)) derive instance Generic TxEvaluationFailure _ @@ -852,7 +853,7 @@ instance DecodeAeson TxEvaluationFailure where decodeAeson = aesonObject $ runReaderT cases where cases :: ObjectParser TxEvaluationFailure - cases = decodeScriptFailures <|> defaultCase + cases = decodeScriptFailures <|> decodeAdditionalUtxoOverlap <|> defaultCase defaultCase :: ObjectParser TxEvaluationFailure defaultCase = ReaderT \o -> @@ -868,6 +869,12 @@ instance DecodeAeson TxEvaluationFailure where (_ /\ v') <$> decodeRedeemerPointer k pure $ ScriptFailures scriptFailures + decodeAdditionalUtxoOverlap :: ObjectParser TxEvaluationFailure + decodeAdditionalUtxoOverlap = ReaderT \o -> do + ogmiosOrefs <- + flip getField "AdditionalUtxoOverlap" =<< getField o "EvaluationFailure" + pure $ AdditionalUtxoOverlap ogmiosOrefs + ---------------- PROTOCOL PARAMETERS QUERY RESPONSE & PARSING -- | A version of `Rational` with Aeson instance that decodes from `x/y` diff --git a/src/Internal/Service/Blockfrost.purs b/src/Internal/Service/Blockfrost.purs index 2cafe33393..987d8db14c 100644 --- a/src/Internal/Service/Blockfrost.purs +++ b/src/Internal/Service/Blockfrost.purs @@ -67,6 +67,7 @@ import Aeson , JsonDecodeError(TypeMismatch, MissingValue, AtKey) , decodeAeson , decodeJsonString + , encodeAeson , getField , getFieldOptional , getFieldOptional' @@ -137,7 +138,7 @@ import Ctl.Internal.Deserialization.PlutusData (deserializeData) import Ctl.Internal.Deserialization.Transaction ( convertGeneralTransactionMetadata ) -import Ctl.Internal.QueryM.Ogmios (TxEvaluationR) +import Ctl.Internal.QueryM.Ogmios (AdditionalUtxoSet, TxEvaluationR) import Ctl.Internal.QueryM.Pools (DelegationsAndRewards) import Ctl.Internal.Serialization as Serialization import Ctl.Internal.Serialization.Address @@ -225,6 +226,7 @@ import Data.Log.Message (Message) import Data.Map (empty, fromFoldable, isEmpty, unions) as Map import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe) import Data.MediaType (MediaType(MediaType)) +import Data.MediaType.Common (applicationJSON) as MediaType import Data.Newtype (class Newtype, unwrap, wrap) import Data.Number (infinity) import Data.Show.Generic (genericShow) @@ -315,7 +317,7 @@ data BlockfrostEndpoint | DatumCbor DataHash -- /network/eras | EraSummaries - -- /utils/txs/evaluate + -- /utils/txs/evaluate/utxos | EvaluateTransaction -- /blocks/latest | LatestBlock @@ -363,7 +365,7 @@ realizeEndpoint endpoint = EraSummaries -> "/network/eras" EvaluateTransaction -> - "/utils/txs/evaluate" + "/utils/txs/evaluate/utxos" LatestBlock -> "/blocks/latest" LatestEpoch -> @@ -638,10 +640,10 @@ submitTx tx = do blockfrostPostRequest SubmitTransaction (MediaType "application/cbor") (Just $ Affjax.arrayView $ unwrap $ unwrap cbor) -evaluateTx :: Transaction -> BlockfrostServiceM TxEvaluationR -evaluateTx tx = do - cslTx <- liftEffect $ Serialization.convertTransaction tx - resp <- handleBlockfrostResponse <$> request (Serialization.toBytes cslTx) +evaluateTx + :: Transaction -> AdditionalUtxoSet -> BlockfrostServiceM TxEvaluationR +evaluateTx tx additionalUtxos = do + resp <- handleBlockfrostResponse <$> request case unwrapBlockfrostEvaluateTx <$> resp of Left err -> throwError $ error $ show err Right (Left err) -> @@ -650,13 +652,16 @@ evaluateTx tx = do err Right (Right eval) -> pure eval where - -- Hex encoded, not binary like submission - request - :: CborBytes - -> BlockfrostServiceM (Either Affjax.Error (Affjax.Response String)) - request cbor = - blockfrostPostRequest EvaluateTransaction (MediaType "application/cbor") - (Just $ Affjax.string $ cborBytesToHex cbor) + request :: BlockfrostServiceM (Either Affjax.Error (Affjax.Response String)) + request = do + cslTx <- liftEffect $ Serialization.convertTransaction tx + blockfrostPostRequest EvaluateTransaction MediaType.applicationJSON + ( Just $ Affjax.string $ stringifyAeson $ + encodeAeson + { cbor: cborBytesToHex $ Serialization.toBytes cslTx + , additionalUtxoSet: additionalUtxos + } + ) -------------------------------------------------------------------------------- -- Check transaction confirmation status diff --git a/src/Internal/Types/PlutusData.purs b/src/Internal/Types/PlutusData.purs index f366f470be..6283b6b2f9 100644 --- a/src/Internal/Types/PlutusData.purs +++ b/src/Internal/Types/PlutusData.purs @@ -6,6 +6,7 @@ module Ctl.Internal.Types.PlutusData , Integer , Bytes ) + , pprintPlutusData ) where import Prelude @@ -21,10 +22,14 @@ import Aeson ) import Control.Alt ((<|>)) import Ctl.Internal.Types.BigNum (BigNum) -import Ctl.Internal.Types.ByteArray (ByteArray, hexToByteArray) +import Ctl.Internal.Types.BigNum as BigNum +import Ctl.Internal.Types.ByteArray (ByteArray, byteArrayToHex, hexToByteArray) import Data.BigInt (BigInt) +import Data.BigInt as BigInt import Data.Either (Either(Left)) import Data.Generic.Rep (class Generic) +import Data.Log.Tag (TagSet, tag, tagSetTag) +import Data.Log.Tag as TagSet import Data.Maybe (Maybe(Just, Nothing)) import Data.Show.Generic (genericShow) import Data.Traversable (for) @@ -104,3 +109,25 @@ instance EncodeAeson PlutusData where encodeAeson (List elems) = encodeAeson elems encodeAeson (Integer bi) = encodeAeson bi encodeAeson (Bytes ba) = encodeAeson ba + +pprintPlutusData :: PlutusData -> TagSet +pprintPlutusData (Constr n children) = TagSet.fromArray + [ ("Constr " <> BigInt.toString (BigNum.toBigInt n)) `tagSetTag` + TagSet.fromArray (pprintPlutusData <$> children) + ] +pprintPlutusData (Map entries) = TagSet.fromArray + [ tagSetTag "Map" $ TagSet.fromArray $ + entries <#> \(key /\ value) -> + TagSet.fromArray + [ "key" `tagSetTag` pprintPlutusData key + , "value" `tagSetTag` pprintPlutusData value + ] + ] +pprintPlutusData (List children) = TagSet.fromArray + [ tagSetTag "List" $ TagSet.fromArray $ + children <#> pprintPlutusData + ] +pprintPlutusData (Integer n) = TagSet.fromArray + [ "Integer" `tag` BigInt.toString n ] +pprintPlutusData (Bytes bytes) = TagSet.fromArray + [ "Bytes" `tag` byteArrayToHex bytes ] diff --git a/src/Internal/Types/TokenName.purs b/src/Internal/Types/TokenName.purs index a68dfe869a..1219262cc2 100644 --- a/src/Internal/Types/TokenName.purs +++ b/src/Internal/Types/TokenName.purs @@ -6,6 +6,7 @@ module Ctl.Internal.Types.TokenName , mkTokenNames , tokenNameFromAssetName , assetNameName + , fromTokenName ) where import Prelude diff --git a/test/BalanceTx/ChangeGeneration.purs b/test/BalanceTx/ChangeGeneration.purs new file mode 100644 index 0000000000..3cced8073a --- /dev/null +++ b/test/BalanceTx/ChangeGeneration.purs @@ -0,0 +1,45 @@ +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 + test "1 / 1" do + mkChangeOutputs 1 1 3 + test "3 / 1" do + mkChangeOutputs 3 1 5 + test "1 / 3" do + mkChangeOutputs 1 3 7 + +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 605d8a9ae8..0f362876e9 100644 --- a/test/Plutip/Contract.purs +++ b/test/Plutip/Contract.purs @@ -16,9 +16,7 @@ import Contract.BalanceTxConstraints ( BalanceTxConstraintsBuilder , mustUseAdditionalUtxos ) as BalanceTxConstraints -import Contract.BalanceTxConstraints - ( mustNotSpendUtxosWithOutRefs - ) +import Contract.BalanceTxConstraints (mustNotSpendUtxosWithOutRefs) import Contract.Chain (currentTime, waitUntilSlot) import Contract.Hashing (datumHash, nativeScriptHash) import Contract.Log (logInfo') @@ -102,6 +100,7 @@ import Contract.Wallet import Control.Monad.Error.Class (try) import Control.Monad.Trans.Class (lift) import Control.Parallel (parallel, sequential) +import Ctl.Examples.AdditionalUtxos (contract) as AdditionalUtxos import Ctl.Examples.AlwaysMints (alwaysMintsPolicy) import Ctl.Examples.AlwaysSucceeds as AlwaysSucceeds import Ctl.Examples.AwaitTxConfirmedWithTimeout as AwaitTxConfirmedWithTimeout @@ -1037,6 +1036,26 @@ suite = do checkUtxoDistribution distribution alice withKeyWallet alice signMultipleContract + test "AdditionalUtxos example" do + let + distribution :: InitialUTxOs + distribution = + [ BigInt.fromInt 10_000_000 + , BigInt.fromInt 50_000_000 + ] + withWallets distribution \alice -> + withKeyWallet alice $ AdditionalUtxos.contract false + + test "Handles AdditionalUtxoOverlap exception (AdditionalUtxos example)" do + let + distribution :: InitialUTxOs + distribution = + [ BigInt.fromInt 10_000_000 + , BigInt.fromInt 50_000_000 + ] + withWallets distribution \alice -> + withKeyWallet alice $ AdditionalUtxos.contract true + test "Locking & unlocking on an always succeeding script (AlwaysSucceeds example)" do diff --git a/webpack.config.cjs b/webpack.config.cjs index 2923bd7619..fcabacdde4 100644 --- a/webpack.config.cjs +++ b/webpack.config.cjs @@ -36,6 +36,9 @@ module.exports = env => { pathRewrite: { "^/kupo": "" }, }, }, + client: { + overlay: false, + }, }, entry: env.entry,