diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 358b4d284..90ede6c0e 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -34,6 +34,7 @@ library Cooked.MockChain.BlockChain Cooked.MockChain.Direct Cooked.MockChain.GenerateTx + Cooked.MockChain.MinAda Cooked.MockChain.Staged Cooked.MockChain.Testing Cooked.MockChain.UtxoSearch diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index 155bc3752..78ba59c79 100644 --- a/src/Cooked/MockChain.hs +++ b/src/Cooked/MockChain.hs @@ -5,6 +5,7 @@ module Cooked.MockChain (module X) where import Cooked.MockChain.Balancing as X import Cooked.MockChain.BlockChain as X import Cooked.MockChain.Direct as X +import Cooked.MockChain.MinAda as X import Cooked.MockChain.Staged as X hiding ( MockChainLog, MockChainLogEntry, diff --git a/src/Cooked/MockChain/Balancing.hs b/src/Cooked/MockChain/Balancing.hs index c15c1783d..64ce78f0a 100644 --- a/src/Cooked/MockChain/Balancing.hs +++ b/src/Cooked/MockChain/Balancing.hs @@ -5,7 +5,6 @@ module Cooked.MockChain.Balancing (balanceTxSkel) where import Cardano.Api.Shelley qualified as Cardano -import Cardano.Ledger.Shelley.Core qualified as Shelley import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Cardano.Node.Emulator.Internal.Node.Validation qualified as Emulator import Control.Monad.Except @@ -33,12 +32,11 @@ balanceTxSkel :: (MonadBlockChainBalancing m) => TxSkel -> m (TxSkel, Fee, Set A balanceTxSkel skel = do -- We retrieve the balancing wallet, who is central in the balancing -- process. Any missing asset will be searched within its utxos. - let balancingWallet = - case txOptBalanceWallet . txSkelOpts $ skel of - BalanceWithFirstSigner -> case txSkelSigners skel of - [] -> error "Can't select balancing wallet: There has to be at least one wallet in txSkelSigners" - bw : _ -> bw - BalanceWith bWallet -> bWallet + balancingWallet <- case txOptBalanceWallet . txSkelOpts $ skel of + BalanceWithFirstSigner -> case txSkelSigners skel of + [] -> fail "Can't select balancing wallet: There has to be at least one wallet in txSkelSigners" + bw : _ -> return bw + BalanceWith bWallet -> return bWallet -- We collect collateral inputs. They might be directly provided in the -- skeleton, or should be retrieved from a given wallet @@ -47,53 +45,16 @@ balanceTxSkel skel = do CollateralUtxosFromWallet cWallet -> getCollateralInputs cWallet CollateralUtxosFromSet utxos -> return utxos - -- We do the min Ada adjustment if it's requested - skelMinAda <- - if txOptEnsureMinAda . txSkelOpts $ skel - then ensureTxSkelOutsMinAda skel - else return skel - - -- We compute the balanced skeleton with the associated fees + -- We compute the balanced skeleton with the associated fees when requested + -- we start with a fee of 10 an increase it a maximum of 5 times (skelBalanced, fees) <- - if txOptBalance . txSkelOpts $ skelMinAda - then -- We start with a small fee and then increase it - calcFee balancingWallet 5 (Fee 10) collateralInputs skelMinAda - else return (skelMinAda, Fee 0) + if txOptBalance . txSkelOpts $ skel + then calcFee balancingWallet 5 (Fee 10) collateralInputs skel + else return (skel, Fee 0) -- We return the new skeleton, the fees and the collateral inputs return (skelBalanced, fees, collateralInputs) --- | Ensure that the transaction outputs have the necessary minimum amount of --- Ada on them. This will only be applied if the 'txOptEnsureMinAda' is set to --- @True@. -ensureTxSkelOutsMinAda :: (MonadBlockChainBalancing m) => TxSkel -> m TxSkel -ensureTxSkelOutsMinAda skel = do - theParams <- getParams - case mapM (ensureTxSkelOutHasMinAda theParams) $ skel ^. txSkelOutsL of - Left err -> throwError $ MCEGenerationError err - Right newTxSkelOuts -> return $ skel & txSkelOutsL .~ newTxSkelOuts - where - ensureTxSkelOutHasMinAda :: Emulator.Params -> TxSkelOut -> Either GenerateTxError TxSkelOut - ensureTxSkelOutHasMinAda theParams txSkelOut@(Pays output) = do - cardanoTxOut <- generateTxOut (Emulator.pNetworkId theParams) txSkelOut - let Script.Lovelace oldAda = output ^. outputValueL % adaL - Emulator.Coin requiredAda = - Shelley.getMinCoinTxOut - (Emulator.emulatorPParams theParams) - . Cardano.toShelleyTxOut Cardano.ShelleyBasedEraConway - . Cardano.toCtxUTxOTxOut - $ cardanoTxOut - updatedTxSkelOut = Pays $ output & outputValueL % adaL .~ Script.Lovelace (max oldAda requiredAda) - -- The following iterative approach to calculate the minimum Ada amount of - -- a TxOut is necessary, because the additional value might make the TxOut - -- heavier. - -- - -- It is inspired by - -- https://github.com/input-output-hk/plutus-apps/blob/8706e6c7c525b4973a7b6d2ed7c9d0ef9cd4ef46/plutus-ledger/src/Ledger/Index.hs#L124 - if oldAda < requiredAda - then ensureTxSkelOutHasMinAda theParams updatedTxSkelOut - else return txSkelOut - -- ensuring that the equation -- -- > input value + minted value = output value + burned value + fee @@ -151,8 +112,6 @@ estimateTxSkelFee skel fee collateralIns = do Left err -> throwError $ MCEGenerationError (TxBodyError "Error creating body when estimating fees" err) Right txBody | Emulator.Coin fee' <- Cardano.evaluateTransactionFee Cardano.ShelleyBasedEraConway pParams txBody nkeys 0 -> return $ Fee fee' --- TODO: improve our collateral mechanism - -- | Calculates the collateral for a transaction getCollateralInputs :: (MonadBlockChainBalancing m) => Wallet -> m (Set Api.TxOutRef) getCollateralInputs w = do diff --git a/src/Cooked/MockChain/Direct.hs b/src/Cooked/MockChain/Direct.hs index b67ea2d51..8daca2391 100644 --- a/src/Cooked/MockChain/Direct.hs +++ b/src/Cooked/MockChain/Direct.hs @@ -22,6 +22,7 @@ import Cooked.InitialDistribution import Cooked.MockChain.Balancing import Cooked.MockChain.BlockChain import Cooked.MockChain.GenerateTx +import Cooked.MockChain.MinAda import Cooked.MockChain.UtxoState import Cooked.Output import Cooked.Skeleton @@ -330,9 +331,12 @@ instance (Monad m) => MonadBlockChain (MockChainT m) where let newParams = applyEmulatorParamsModification (txOptEmulatorParamsModification . txSkelOpts $ skelUnbal) oldParams -- We change the parameters for the duration of the validation process setParams newParams - -- We balance the skeleton (when requested in the options) and get the - -- associated fees and collateral inputs - (skel, fees, collateralIns) <- balanceTxSkel skelUnbal + -- We ensure that the outputs have the required minimal amount of ada, when + -- requested in the skeleton options + minAdaSkelUnbal <- ensureTxSkelMinAda skelUnbal + -- We balance the skeleton and get the associated fees and collateral + -- inputs, when requested in the skeleton options + (skel, fees, collateralIns) <- balanceTxSkel minAdaSkelUnbal -- We retrieve data that will be used in the transaction generation process: -- datums, validators and various kinds of inputs. This idea is to provide a -- rich-enough context for the transaction generation to succeed. diff --git a/src/Cooked/MockChain/MinAda.hs b/src/Cooked/MockChain/MinAda.hs new file mode 100644 index 000000000..20d8fa3a1 --- /dev/null +++ b/src/Cooked/MockChain/MinAda.hs @@ -0,0 +1,58 @@ +module Cooked.MockChain.MinAda + ( toTxSkelOutMinAda, + toTxSkelMinAda, + ensureTxSkelMinAda, + ) +where + +import Cardano.Api qualified as Cardano +import Cardano.Api.Ledger qualified as Cardano +import Cardano.Api.Shelley qualified as Cardano +import Cardano.Ledger.Shelley.Core qualified as Shelley +import Cardano.Node.Emulator qualified as Emulator +import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator +import Control.Monad.Except +import Cooked.MockChain.BlockChain +import Cooked.MockChain.GenerateTx +import Cooked.Output +import Cooked.Skeleton +import Cooked.ValueUtils +import Optics.Core +import Plutus.Script.Utils.Ada qualified as Script + +ensureTxSkelMinAda :: (MonadBlockChainBalancing m) => TxSkel -> m TxSkel +ensureTxSkelMinAda skel = + if txOptEnsureMinAda . txSkelOpts $ skel + then toTxSkelMinAda skel + else return skel + +-- | To that the transaction outputs have the necessary minimum amount of +-- Ada on them. This will only be applied if the 'txOptToMinAda' is set to +-- @True@. +toTxSkelMinAda :: (MonadBlockChainBalancing m) => TxSkel -> m TxSkel +toTxSkelMinAda skel = do + theParams <- getParams + case mapM (toTxSkelOutMinAda theParams) $ skel ^. txSkelOutsL of + Left err -> throwError $ MCEGenerationError err + Right newTxSkelOuts -> return $ skel & txSkelOutsL .~ newTxSkelOuts + +toTxSkelOutMinAda :: Emulator.Params -> TxSkelOut -> Either GenerateTxError TxSkelOut +toTxSkelOutMinAda theParams txSkelOut@(Pays output) = do + cardanoTxOut <- generateTxOut (Emulator.pNetworkId theParams) txSkelOut + let Script.Lovelace oldAda = output ^. outputValueL % adaL + Cardano.Coin requiredAda = + Shelley.getMinCoinTxOut + (Emulator.emulatorPParams theParams) + . Cardano.toShelleyTxOut Cardano.ShelleyBasedEraConway + . Cardano.toCtxUTxOTxOut + $ cardanoTxOut + updatedTxSkelOut = Pays $ output & outputValueL % adaL .~ Script.Lovelace (max oldAda requiredAda) + -- The following iterative approach to calculate the minimum Ada amount of + -- a TxOut is necessary, because the additional value might make the TxOut + -- heavier. + -- + -- It is inspired by + -- https://github.com/input-output-hk/plutus-apps/blob/8706e6c7c525b4973a7b6d2ed7c9d0ef9cd4ef46/plutus-ledger/src/Ledger/Index.hs#L124 + if oldAda < requiredAda + then toTxSkelOutMinAda theParams updatedTxSkelOut + else return txSkelOut diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/MockChain/UtxoSearch.hs index cf945a08e..b87b45e37 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/src/Cooked/MockChain/UtxoSearch.hs @@ -16,6 +16,7 @@ module Cooked.MockChain.UtxoSearch filterWithValuePred, filterWithOnlyAda, filterWithNotOnlyAda, + onlyValueOutputsAtSearch, vanillaOutputsAtSearch, filterWithAlways, scriptOutputsSearch, @@ -117,6 +118,17 @@ filterWithOnlyAda as = filterWithValuePred as $ (1 ==) . length . Script.flatten filterWithNotOnlyAda :: (Monad m) => UtxoSearch m Api.TxOut -> UtxoSearch m Api.Value filterWithNotOnlyAda as = filterWithValuePred as $ (1 <) . length . Script.flattenValue +onlyValueOutputsAtSearch :: + (MonadBlockChainBalancing m, ToAddress addr) => + addr -> + UtxoSearch m (ConcreteOutput Api.Credential () Api.Value Api.ScriptHash) +onlyValueOutputsAtSearch addr = + utxosAtSearch addr + `filterWithAlways` fromAbstractOutput + `filterWithPure` isOutputWithoutDatum + `filterWithPure` isEmptyStakingCredentialOutput + `filterWithPred` (isNothing . view outputReferenceScriptL) + -- A vanilla output only possesses an ada-only value and does not have a staking -- credential, a datum or a reference script. A vanilla UTxO is a perfect -- candidate to be used for fee, balancing or collateral. @@ -125,12 +137,8 @@ vanillaOutputsAtSearch :: addr -> UtxoSearch m (ConcreteOutput Api.Credential () Script.Ada Api.ScriptHash) vanillaOutputsAtSearch addr = - utxosAtSearch addr - `filterWithAlways` fromAbstractOutput + onlyValueOutputsAtSearch addr `filterWithPure` isOnlyAdaOutput - `filterWithPure` isOutputWithoutDatum - `filterWithPure` isEmptyStakingCredentialOutput - `filterWithPred` (isNothing . view outputReferenceScriptL) scriptOutputsSearch :: (MonadBlockChain m, ToScriptHash s) =>