diff --git a/CHANGELOG.md b/CHANGELOG.md index 912d22389..b0bdb2c0b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -39,7 +39,16 @@ - Two filters in `Output.hs`, `isScriptOutput` and `isPKOutput` - A new helper function to get the full output value of a skeleton, `txSkelOutputsValue` - +- Proposal procedures can now be issued and described in transaction + skeletons. If they contain parameter changes or treasury withdrawals, a + witness script can be attached and will be run. +- `TxSkelRedeemer` is now used for all kinds of scripts. +- File [CONWAY](doc/CONWAY.md) to document which Conway features are currently + supported. +- A new option `txOptAnchorResolution` to decide whether to resolve urls + locally or on the web (unsafe). The default is to resolve them locally with a + given map from urls to page content as bytestring. + ### Removed - Extraneous dependencies in package.yaml - File `Cooked.TestUtils`, its content has been added to `Cooked.MockChain.Testing` @@ -49,6 +58,7 @@ - Deprecated use of `*` instead of `Type` - Many unused pragmas - Orphan default instance for `Ledger.Slot` +- `MintsRedeemer` (replaced by `TxSkelRedeemer`) ### Changed - Default era from Babbage to Conway diff --git a/README.md b/README.md index fbb23c28d..cef3fd1d6 100644 --- a/README.md +++ b/README.md @@ -112,6 +112,8 @@ ready-to-use recipes book. automated balancing mechanism and associated options (including options revolving around fees and collaterals). +- The [CONWAY](doc/CONWAY.md) file describes the Conway features that are currently supported by `cooked-validators`. + - We also have a [repository](https://github.com/tweag/cooked-smart-contracts) of example contracts with offchain code and tests written using `cooked-validators`. Note that some examples are not maintained and thus written diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 58c13cdd5..bd92c624b 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -34,6 +34,14 @@ library Cooked.MockChain.BlockChain Cooked.MockChain.Direct Cooked.MockChain.GenerateTx + Cooked.MockChain.GenerateTx.Body + Cooked.MockChain.GenerateTx.Collateral + Cooked.MockChain.GenerateTx.Common + Cooked.MockChain.GenerateTx.Input + Cooked.MockChain.GenerateTx.Mint + Cooked.MockChain.GenerateTx.Output + Cooked.MockChain.GenerateTx.Proposal + Cooked.MockChain.GenerateTx.Witness Cooked.MockChain.MinAda Cooked.MockChain.Staged Cooked.MockChain.Testing @@ -101,13 +109,21 @@ library , bytestring , cardano-api , cardano-crypto + , cardano-data + , cardano-ledger-conway + , cardano-ledger-core , cardano-ledger-shelley , cardano-node-emulator + , cardano-strict-containers , containers , data-default , either + , exceptions , flat + , http-conduit + , lens , list-t + , microlens , monad-control , mtl , nonempty-containers @@ -146,6 +162,7 @@ test-suite spec Cooked.MinAdaSpec Cooked.MockChain.BlockChainSpec Cooked.MockChainSpec + Cooked.ProposingScriptSpec Cooked.ReferenceInputsSpec Cooked.ReferenceScriptsSpec Cooked.ShowBSSpec @@ -185,14 +202,22 @@ test-suite spec , bytestring , cardano-api , cardano-crypto + , cardano-data + , cardano-ledger-conway + , cardano-ledger-core , cardano-ledger-shelley , cardano-node-emulator + , cardano-strict-containers , containers , cooked-validators , data-default , either + , exceptions , flat + , http-conduit + , lens , list-t + , microlens , monad-control , mtl , nonempty-containers diff --git a/doc/CHEATSHEET.md b/doc/CHEATSHEET.md index f343f9f3e..f54525bab 100644 --- a/doc/CHEATSHEET.md +++ b/doc/CHEATSHEET.md @@ -167,7 +167,7 @@ txSkelTemplate ### Spend some UTxOs -* No redeemer: `TxSkelNoRedeemerForPK` +* No redeemer: `TxSkelNoRedeemer` * With redeemer: * Regular script: `TxSkelRedeemerForScript typedRedeemer` * Reference script: `TxSkelRedeemerForReferencedScript txOutRefCarryingReferenceScript typedRedeemer` @@ -218,8 +218,9 @@ foo txOutRef = do ### Mint or burn tokens -* No redeemer: `(Script.Versioned fooPolicy Script.PlutusV3, NoMintsRedeemer, "fooName", 3)` -* With redeemer: `(Script.Versioned barPolicy Script.PlutusV3, SomeMintsRedeemer typedRedeemer, "barName", 12)` +* No redeemer: `(Script.Versioned fooPolicy Script.PlutusV3, TxSkelNoRedeemer, "fooName", 3)` +* With redeemer: `(Script.Versioned barPolicy Script.PlutusV3, TxSkelRedeemerForScript typedRedeemer, "barName", 12)` +* With a reference script: `(Script.Versioned barPolicy Script.PlutusV3, TxSkelRedeemerForReferenceScript txOutRef typedRedeemer, "barName", 12)` * Burn tokens (negative amount): `(Script.Versioned bazPolicy Script.PlutusV3, ..., "bazName", -7)` ```haskell @@ -242,7 +243,6 @@ txSkelTemplate ... } ``` - ### Have pre-existing non-Ada tokens that cannot be minted or burnt * `distributionFromList [..., (... <> permanentValue "customToken" 1000), ...]` @@ -446,7 +446,7 @@ foo = do bar `withTweak` ( do addOutputTweak $ paysScript bazValidator bazDatum bazValue removeOutputTweak (\(Pays out) -> somePredicate out) - addInputTweak somePkTxOutRef C.TxSkelNoRedeemerForPK + addInputTweak somePkTxOutRef C.TxSkelNoRedeemer removeInputTweak (\txOutRef redeemer -> somePredicate txOutRef redeemer) ) ``` @@ -474,3 +474,64 @@ foo = do (<> assetClassValue bazAssetClass 10) -- Add 10 baz tokens ) ``` + +## Proposal procedures + +### Attach a Proposal Procedure to a transaction + +* Using the builtin constructor for proposals. + +```haskell +txSkelTemplate + { ... + txSkelProposals = + [ TxSkelProposal + { txSkelProposalAddress = walletAddress (wallet 1), + txSkelProposalAction = + TxGovActionTreasuryWithdrawals $ + Map.fromList + [ (toCredential $ wallet 1, Api.Lovelace 100), + (toCredential $ wallet 2, Api.Lovelace 10_000) + ], + txSkelProposalWitness = (toScript myScript, myRedeemer), + txSkelProposalAnchor = Nothing + } + ] + ... + } +``` + +* Using smart constructors and (optional) helpers. + +```haskell +txSkelTemplate + { ... + txSkelProposals = + [ simpleTxSkelProposal + (wallet 1) + (TxGovActionParameterChange [FeePerByte 100, FeeFixed 1_000]) + `withWitness` (myScript, myRedeemer) + `withAnchor` "https://www.tweag.io/" + ] + ... + } +``` + +### Anchor resolution policy + +* Auto resolution using a given map with resolved page content as bytestrings + (default behavior) + +```haskell + txSkelOpts = def + { txOptAnchorResolution = AnchorResolutionLocal $ Map.singleton "https://www.tweag.io/" someByteString + } +``` + +* Auto resolution using web requests (very unsafe, prevents reproducibility) + +```haskell + txSkelOpts = def + { txOptAnchorResolution = AnchorResolutionHttp + } +``` diff --git a/doc/CONWAY.md b/doc/CONWAY.md new file mode 100644 index 000000000..902f806e3 --- /dev/null +++ b/doc/CONWAY.md @@ -0,0 +1,34 @@ +# Supported Conway features + +With the arrival of the Conway era, the Cardano blockchain is being enriched +with a significant set of features revolving around governance. Governance can +be defined as the ability for ada holders to take part in various on-chain +decisions as described in +[CIP-1694](https://github.com/cardano-foundation/CIPs/tree/master/CIP-1694). These +new features have brought a substantial set of changes, such as new script +purposes, new centralized data like committee, and new transaction +features. This documents describes which of those features are currently being +supported by cooked-validators, and to which extent. Each of the following items +describes a feature that is currently supported. The reader can assume that +everything that is not directly mentioned here about Conway is not yet +supported. + +## Proposal procedures + +It is currently possible to describe proposal procedures and attach an arbitrary +number of those in transaction skeletons. The balancing mechanism will take into +account the required deposit for each of these procedures. + +### Parameter changes + +It is possible to issue proposal procedures with a request for changes in +parameters. If a script witness is attached to this proposal (typically the +constitution script), it will be ran against the proposal. All kinds of +parameter changes are supported, except for the cost models, which contain too +many values and are not even yet taken into account by the current constitution. + +### Treasury withdrawals + +It is possible to issue proposal procedures with a request for treasury +withdrawals. If a script witness is attached to this proposal (typically the +constitution script), it will be ran against the proposal. diff --git a/doc/IMPORTS.md b/doc/IMPORTS.md index 21973d971..c0ebeeb27 100644 --- a/doc/IMPORTS.md +++ b/doc/IMPORTS.md @@ -12,7 +12,7 @@ a challenge. This is why this file exists. We detail here the two main keys to have a standardized way of importing definition in cooked-validators: qualified modules and preferred import locations. -## Names of qualified modules +## Names of qualified modules related to Cardano Here is the correspondance between package and prefix for each of our main dependencies: @@ -39,6 +39,7 @@ dependencies: ### [`cardano-ledger`](https://github.com/IntersectMBO/cardano-ledger) - package `cardano-ledger-shelley`, prefix `Shelley` +- package `cardano-ledger-conway`, prefix `Conway` ### Exception @@ -47,6 +48,15 @@ When using `PlutusTx.Prelude` (from `plutus-tx`) in conjunction with the functions coming from the usual prelude should be prefixed `Haskell` in those modules instead. +## Names of qualifed modules unrelated to Cardano + +`cooked-validators` uses optics in various places of the codebase. These optics +come from the module `Optics.Core` of the `optics` package and are used +unqualified in the code. Some of our dependencies however use optics coming from +the `lens` or `microlens` packages. When using those, we should make very clear +that they do not come from our default optics library, and thus prefix them with +`Lens` or `Microlens` respectively. + ## Preferred import locations rules Here is a list of preferred rules to ensure each definition always comes from a diff --git a/package.yaml b/package.yaml index 2b4f382bd..36d89324e 100644 --- a/package.yaml +++ b/package.yaml @@ -10,13 +10,21 @@ dependencies: - bytestring - cardano-api - cardano-crypto + - cardano-data + - cardano-ledger-core - cardano-ledger-shelley + - cardano-ledger-conway - cardano-node-emulator + - cardano-strict-containers - containers - data-default - either + - exceptions - flat + - http-conduit + - lens - list-t + - microlens - monad-control - mtl - nonempty-containers diff --git a/src/Cooked/Conversion/ToCredential.hs b/src/Cooked/Conversion/ToCredential.hs index dd26b218c..d5c1c1808 100644 --- a/src/Cooked/Conversion/ToCredential.hs +++ b/src/Cooked/Conversion/ToCredential.hs @@ -13,6 +13,9 @@ class ToCredential a where instance ToCredential Api.Credential where toCredential = id +instance ToCredential Api.Address where + toCredential (Api.Address cred _) = cred + instance ToCredential Api.PubKeyHash where toCredential = Api.PubKeyCredential diff --git a/src/Cooked/Conversion/ToScriptHash.hs b/src/Cooked/Conversion/ToScriptHash.hs index b6890b15c..22407a92c 100644 --- a/src/Cooked/Conversion/ToScriptHash.hs +++ b/src/Cooked/Conversion/ToScriptHash.hs @@ -2,8 +2,9 @@ module Cooked.Conversion.ToScriptHash where import Cooked.Conversion.ToScript -import Plutus.Script.Utils.Scripts qualified as Script +import Plutus.Script.Utils.Scripts qualified as Script hiding (scriptHash) import Plutus.Script.Utils.Typed qualified as Script +import Plutus.Script.Utils.V3.Scripts qualified as Script (scriptHash) import PlutusLedgerApi.V3 qualified as Api class ToScriptHash a where @@ -12,11 +13,17 @@ class ToScriptHash a where instance ToScriptHash Api.ScriptHash where toScriptHash = id +instance ToScriptHash Script.Script where + toScriptHash = Script.scriptHash + +instance ToScriptHash Api.SerialisedScript where + toScriptHash = toScriptHash . Script.Script + instance ToScriptHash Script.ValidatorHash where toScriptHash (Script.ValidatorHash h) = Script.ScriptHash h instance ToScriptHash (Script.Versioned Script.Script) where - toScriptHash = Script.scriptHash + toScriptHash (Script.Versioned s _) = toScriptHash s instance ToScriptHash (Script.Versioned Script.Validator) where toScriptHash = toScriptHash . toScript diff --git a/src/Cooked/Conversion/ToValue.hs b/src/Cooked/Conversion/ToValue.hs index c3cc78a6f..a827fa59a 100644 --- a/src/Cooked/Conversion/ToValue.hs +++ b/src/Cooked/Conversion/ToValue.hs @@ -16,3 +16,6 @@ instance ToValue Script.Ada where instance ToValue Cardano.Coin where toValue (Cardano.Coin x) = toValue (Script.Lovelace x) + +instance ToValue Api.Lovelace where + toValue (Api.Lovelace lv) = toValue (Script.Lovelace lv) diff --git a/src/Cooked/MockChain/Balancing.hs b/src/Cooked/MockChain/Balancing.hs index 66082330a..c6a4bca1e 100644 --- a/src/Cooked/MockChain/Balancing.hs +++ b/src/Cooked/MockChain/Balancing.hs @@ -276,9 +276,9 @@ estimateTxSkelFee skel fee collateralIns returnCollateralWallet = do -- We return an accurate estimate of the resulting transaction fee return $ Emulator.unCoin $ Cardano.evaluateTransactionFee Cardano.ShelleyBasedEraConway (Emulator.pEmulatorPParams params) txBody nkeys 0 --- | This creates a balanced skeleton from a given skeleton and fee --- In other words, this ensures that the following equation holds: --- input value + minted value = output value + burned value + fee +-- | This creates a balanced skeleton from a given skeleton and fee. In other +-- words, this ensures that the following equation holds: input value + minted +-- value = output value + burned value + fee + deposits computeBalancedTxSkel :: (MonadBlockChainBalancing m) => Wallet -> BalancingOutputs -> TxSkel -> Fee -> m TxSkel computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (lovelace -> feeValue) = do -- We compute the necessary values from the skeleton that are part of the @@ -286,8 +286,9 @@ computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (lovelac let (burnedValue, mintedValue) = Api.split $ txSkelMintsValue txSkelMints outValue = txSkelValueInOutputs txSkel inValue <- txSkelInputValue txSkel + depositedValue <- toValue <$> txSkelProposalsDeposit txSkel -- We compute the values missing in the left and right side of the equation - let (missingRight, missingLeft) = Api.split $ outValue <> burnedValue <> feeValue <> PlutusTx.negate (inValue <> mintedValue) + let (missingRight, missingLeft) = Api.split $ outValue <> burnedValue <> feeValue <> depositedValue <> PlutusTx.negate (inValue <> mintedValue) -- This gives us what we need to run our `reachValue` algorithm and append to -- the resulting values whatever payment was missing in the initial skeleton let candidatesRaw = second (<> missingRight) <$> reachValue balancingUtxos missingLeft (toInteger $ length balancingUtxos) @@ -324,5 +325,5 @@ computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (lovelac -- a new output at the end of the list, to keep the order intact. (txOutRefs, val) <- getOptimalCandidate candidatesRaw balancingWallet balancingError return (txOutRefs, txSkelOuts ++ [paysPK balancingWallet val]) - let newTxSkelIns = txSkelIns <> Map.fromList ((,TxSkelNoRedeemerForPK) <$> additionalInsTxOutRefs) + let newTxSkelIns = txSkelIns <> Map.fromList ((,TxSkelNoRedeemer) <$> additionalInsTxOutRefs) return $ (txSkel & txSkelOutsL .~ newTxSkelOuts) & txSkelInsL .~ newTxSkelIns diff --git a/src/Cooked/MockChain/BlockChain.hs b/src/Cooked/MockChain/BlockChain.hs index cf87657d7..243b964a3 100644 --- a/src/Cooked/MockChain/BlockChain.hs +++ b/src/Cooked/MockChain/BlockChain.hs @@ -49,12 +49,17 @@ module Cooked.MockChain.BlockChain lookupUtxos, lookupUtxosPl, validateTxSkel', + txSkelProposalsDeposit, + govActionDeposit, ) where +import Cardano.Api.Ledger qualified as Cardano +import Cardano.Ledger.Conway.PParams qualified as Conway import Cardano.Node.Emulator qualified as Emulator import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Arrow +import Control.Lens qualified as Lens import Control.Monad import Control.Monad.Except import Control.Monad.Reader @@ -317,6 +322,15 @@ txSkelReferenceInputUtxos :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Ap txSkelReferenceInputUtxos TxSkel {..} = lookupUtxos $ mapMaybe txSkelReferenceScript (Map.elems txSkelIns) ++ Set.toList txSkelInsReference +-- | Retrieves the required deposit amount for issuing governance actions. +govActionDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace +govActionDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppGovActionDepositL . Emulator.emulatorPParams <$> getParams + +-- | Retrieves the total amount of lovelace deposited in proposals in this +-- skeleton (equal to `govActionDeposit` times the number of proposals). +txSkelProposalsDeposit :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace +txSkelProposalsDeposit TxSkel {..} = Api.Lovelace . (toInteger (length txSkelProposals) *) . Api.getLovelace <$> govActionDeposit + -- | Helper to convert Nothing to an error maybeErrM :: (MonadBlockChainBalancing m) => MockChainError -> (a -> b) -> m (Maybe a) -> m b maybeErrM err f = (maybe (throwError err) (return . f) =<<) diff --git a/src/Cooked/MockChain/GenerateTx.hs b/src/Cooked/MockChain/GenerateTx.hs index 36db63651..2220f486d 100644 --- a/src/Cooked/MockChain/GenerateTx.hs +++ b/src/Cooked/MockChain/GenerateTx.hs @@ -11,386 +11,68 @@ module Cooked.MockChain.GenerateTx where import Cardano.Api qualified as Cardano -import Cardano.Api.Shelley qualified as Cardano import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Control.Monad import Control.Monad.Reader -import Cooked.Conversion -import Cooked.Output +import Cooked.MockChain.GenerateTx.Body +import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.GenerateTx.Output import Cooked.Skeleton import Cooked.Wallet -import Data.Bifunctor -import Data.Default import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe import Data.Set (Set) -import Data.Set qualified as Set -import Ledger.Address qualified as Ledger -import Ledger.Tx qualified as Ledger -import Ledger.Tx.CardanoAPI qualified as Ledger -import Optics.Core import Plutus.Script.Utils.Scripts qualified as Script -import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api -import PlutusTx.Numeric qualified as PlutusTx --- * Domain for transaction generation and associated types - -data GenerateTxError - = ToCardanoError String Ledger.ToCardanoError - | TxBodyError String Cardano.TxBodyError - | GenerateTxErrorGeneral String - deriving (Show, Eq) - --- | Context in which various parts of transactions will be built -data Context where - Context :: - { -- | fee to apply to body generation - fee :: Integer, - -- | collaterals to add to body generation - collateralIns :: Set Api.TxOutRef, - -- | wallet to return collaterals to - returnCollateralWallet :: Maybe Wallet, - -- | parameters of the emulator - params :: Emulator.Params, - -- | datums present in our environment - managedData :: Map Api.DatumHash Api.Datum, - -- | txouts present in our environment - managedTxOuts :: Map Api.TxOutRef Api.TxOut, - -- | validators present in our environment - managedValidators :: Map Script.ValidatorHash (Script.Versioned Script.Validator) - } -> - Context - -instance Default Context where - def = Context 0 mempty Nothing def Map.empty Map.empty Map.empty - --- The domain in which transactions are generated. -type TxGen a = ReaderT Context (Either GenerateTxError) a - --- * Helpers to throw errors in 'TxGen' - --- Looks up a key in a map. Throws a 'GenerateTxErrorGeneral' error with a given --- message when the key is absent, returns the associated value otherwise. -throwOnLookup :: (Ord k) => String -> k -> Map k a -> TxGen a -throwOnLookup errorMsg key = maybe (throwOnString errorMsg) return . Map.lookup key - --- Throws a general error from a String -throwOnString :: String -> TxGen a -throwOnString = lift . Left . GenerateTxErrorGeneral - --- Lifts a 'ToCardanoError' with an associated error message, or apply a --- function if a value exists -throwOnToCardanoErrorOrApply :: String -> (a -> b) -> Either Ledger.ToCardanoError a -> TxGen b -throwOnToCardanoErrorOrApply errorMsg f = lift . bimap (ToCardanoError errorMsg) f - --- Lifts a 'ToCardanoError' with an associated error message, or leaves the --- value unchanged if it exists -throwOnToCardanoError :: String -> Either Ledger.ToCardanoError a -> TxGen a -throwOnToCardanoError = flip throwOnToCardanoErrorOrApply id - --- * Generation functions - -txSkelToBodyContent :: TxSkel -> TxGen (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra) -txSkelToBodyContent TxSkel {..} = do - txIns <- mapM txSkelInToTxIn $ Map.toList txSkelIns - txInsReference <- txOutRefsToTxInsReference $ mapMaybe txSkelReferenceScript (Map.elems txSkelIns) ++ Set.toList txSkelInsReference - (txInsCollateral, txTotalCollateral, txReturnCollateral) <- toCollateralTriplet - txOuts <- mapM txSkelOutToCardanoTxOut txSkelOuts - (txValidityLowerBound, txValidityUpperBound) <- - throwOnToCardanoError "translating the transaction validity range" $ Ledger.toCardanoValidityRange txSkelValidityRange - txMintValue <- txSkelMintsToTxMintValue txSkelMints - txExtraKeyWits <- - if null txSkelSigners - then return Cardano.TxExtraKeyWitnessesNone - else - throwOnToCardanoErrorOrApply - "translating the required signers" - (Cardano.TxExtraKeyWitnesses Cardano.AlonzoEraOnwardsConway) - $ mapM (Ledger.toCardanoPaymentKeyHash . Ledger.PaymentPubKeyHash . walletPKHash) txSkelSigners - txProtocolParams <- asks (Cardano.BuildTxWith . Just . Emulator.ledgerProtocolParameters . params) - txFee <- asks (Cardano.TxFeeExplicit Cardano.ShelleyBasedEraConway . Emulator.Coin . fee) - let txMetadata = Cardano.TxMetadataNone -- That's what plutus-apps does as well - txAuxScripts = Cardano.TxAuxScriptsNone -- That's what plutus-apps does as well - txWithdrawals = Cardano.TxWithdrawalsNone -- That's what plutus-apps does as well - txCertificates = Cardano.TxCertificatesNone -- That's what plutus-apps does as well - txUpdateProposal = Cardano.TxUpdateProposalNone -- That's what plutus-apps does as well - txScriptValidity = Cardano.TxScriptValidityNone -- That's what plutus-apps does as well - txProposalProcedures = Nothing -- TODO, should appear in our skeleton? - txVotingProcedures = Nothing -- TODO, same as above - return Cardano.TxBodyContent {..} +-- | Generates a Cardano `TxOut` from a `TxSkelOut` +generateTxOut :: + -- | The network Id + Cardano.NetworkId -> + -- | The output to translate + TxSkelOut -> + Either GenerateTxError (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) +generateTxOut networkId txSkelOut = runReaderT (toCardanoTxOut txSkelOut) networkId +-- | Generates a transaction body for a skeleton generateBodyContent :: + -- | fee to apply to body generation Integer -> + -- | wallet to return collaterals to Wallet -> + -- | collaterals to add to body generation Set Api.TxOutRef -> + -- | parameters of the emulator Emulator.Params -> + -- | datums present in our environment Map Api.DatumHash Api.Datum -> + -- | txouts present in our environment Map Api.TxOutRef Api.TxOut -> + -- | validators present in our environment Map Script.ValidatorHash (Script.Versioned Script.Validator) -> + -- | The skeleton to translate TxSkel -> Either GenerateTxError (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra) -generateBodyContent fee (Just -> returnCollateralWallet) collateralIns params managedData managedTxOuts managedValidators = - flip runReaderT Context {..} . txSkelToBodyContent - --- Convert a 'TxSkel' input, which consists of a 'Api.TxOutRef' and a --- 'TxSkelIn', into a 'Cardano.TxIn', together with the appropriate witness. If --- you add reference inputs, don't forget to also update the 'txInsReference'! -txSkelInToTxIn :: - (Api.TxOutRef, TxSkelRedeemer) -> - TxGen (Cardano.TxIn, Cardano.BuildTxWith Cardano.BuildTx (Cardano.Witness Cardano.WitCtxTxIn Cardano.ConwayEra)) -txSkelInToTxIn (txOutRef, txSkelRedeemer) = do - witness <- txSkelRedeemerToWitness txOutRef txSkelRedeemer - throwOnToCardanoErrorOrApply - "txSkelIntoTxIn, translating TxOutRef" - (,Cardano.BuildTxWith witness) - $ Ledger.toCardanoTxIn txOutRef - -resolveScriptOutputOwnerAndDatum :: - Api.TxOutRef -> - TxGen (Script.ValidatorHash, Script.Versioned Script.Validator, Cardano.ScriptDatum Cardano.WitCtxTxIn) -resolveScriptOutputOwnerAndDatum txOutRef = do - txOut <- throwOnLookup "txSkelInToTxIn: Unknown txOutRef" txOutRef =<< asks managedTxOuts - validatorHash <- - case outputAddress txOut of - (Api.Address (Api.ScriptCredential (Api.ScriptHash validatorHash)) _) -> return $ Script.ValidatorHash validatorHash - _ -> throwOnString $ "txSkelInToTxIn: Output is not a script output" <> show txOut - validator <- throwOnLookup "txSkelInToTxIn: Unknown validator" validatorHash =<< asks managedValidators - datum <- - case outputOutputDatum txOut of - Api.NoOutputDatum -> throwOnString "txSkelInToTxIn: No datum found on script output" - Api.OutputDatum _ -> return Cardano.InlineScriptDatum - Api.OutputDatumHash datumHash -> do - datum <- throwOnLookup "txSkelInToTxIn: Datum hash could not be resolved" datumHash =<< asks managedData - return $ Cardano.ScriptDatumForTxIn $ Ledger.toCardanoScriptData $ Api.getDatum datum - return (validatorHash, validator, datum) - -txSkelRedeemerToWitness :: Api.TxOutRef -> TxSkelRedeemer -> TxGen (Cardano.Witness Cardano.WitCtxTxIn Cardano.ConwayEra) -txSkelRedeemerToWitness _ TxSkelNoRedeemerForPK = return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending -txSkelRedeemerToWitness txOutRef (TxSkelRedeemerForReferencedScript validatorOref redeemer) = do - (Script.ValidatorHash validatorHash, Script.Versioned _ version, datum) <- resolveScriptOutputOwnerAndDatum txOutRef - Api.ScriptHash scriptHashAtOref <- - -- In our own MockChainT implementation, this error should never been - -- thrown, because we collect the 'managedTxOuts' using (eventually) - -- 'lookupUtxos', which will already fail on un-resolvable 'TxOutRef's. - throwOnLookup - "txSkelRedeemerToWitness: Can't resolve reference script outref. This might mean that you either never created or accidentally consumed the UTxO where the reference script is stored" - validatorOref - =<< asks (Map.mapMaybe (^. outputReferenceScriptL) . managedTxOuts) - when (scriptHashAtOref /= validatorHash) $ - throwOnString "txSkelRedeemerToWitness: Wrong reference script hash. Are you using the correct TxOutRef on your TxSkelRedeemerForReferencedScript?" - validatorTxIn <- - throwOnToCardanoError "txSkelRedeemerToWitness: translating TxOutRef where the reference script sits" $ Ledger.toCardanoTxIn validatorOref - scriptHash <- - throwOnToCardanoError "txSkelRedeemerToWitness: could not convert script hash of referenced script" $ Ledger.toCardanoScriptHash $ Api.ScriptHash validatorHash - let scriptWitnessBuilder = case version of - Script.PlutusV1 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV1InConway Cardano.PlutusScriptV1 (Cardano.PReferenceScript validatorTxIn (Just scriptHash)) - Script.PlutusV2 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV2InConway Cardano.PlutusScriptV2 (Cardano.PReferenceScript validatorTxIn (Just scriptHash)) - Script.PlutusV3 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV3InConway Cardano.PlutusScriptV3 (Cardano.PReferenceScript validatorTxIn (Just scriptHash)) - return $ - Cardano.ScriptWitness Cardano.ScriptWitnessForSpending $ - scriptWitnessBuilder - datum - (Ledger.toCardanoScriptData $ Api.toBuiltinData redeemer) - Ledger.zeroExecutionUnits -- We can't guess that yet, no? -txSkelRedeemerToWitness txOutRef (TxSkelRedeemerForScript redeemer) = do - (_validatorHash, Script.Versioned (Script.Validator (Script.Script script)) version, datum) <- resolveScriptOutputOwnerAndDatum txOutRef - let scriptWitnessBuilder = case version of - Script.PlutusV1 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV1InConway Cardano.PlutusScriptV1 $ Cardano.PScript $ Cardano.PlutusScriptSerialised script - Script.PlutusV2 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV2InConway Cardano.PlutusScriptV2 $ Cardano.PScript $ Cardano.PlutusScriptSerialised script - Script.PlutusV3 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV3InConway Cardano.PlutusScriptV3 $ Cardano.PScript $ Cardano.PlutusScriptSerialised script - return $ - Cardano.ScriptWitness Cardano.ScriptWitnessForSpending $ - scriptWitnessBuilder - datum - (Ledger.toCardanoScriptData $ Api.toBuiltinData redeemer) - Ledger.zeroExecutionUnits -- We can't guess that yet, no? - --- Convert a list of 'Api.TxOutRef' into a 'Cardano.TxInsReference' -txOutRefsToTxInsReference :: [Api.TxOutRef] -> TxGen (Cardano.TxInsReference Cardano.BuildTx Cardano.ConwayEra) -txOutRefsToTxInsReference = - throwOnToCardanoErrorOrApply - "txOutRefsToTxInsReference" - ( \case - [] -> Cardano.TxInsReferenceNone - txIns -> Cardano.TxInsReference Cardano.BabbageEraOnwardsConway txIns - ) - . mapM Ledger.toCardanoTxIn - --- | Computes the collateral triplet from the fees and the collateral inputs in --- the context. What we call a collateral triplet is composed of: --- * The set of collateral inputs --- * The total collateral paid by the transaction in case of phase 2 failure --- * An output returning excess collateral value when collaterals are used --- These quantity should satisfy the equation (in terms of their values): --- collateral inputs = total collateral + return collateral -toCollateralTriplet :: - TxGen - ( Cardano.TxInsCollateral Cardano.ConwayEra, - Cardano.TxTotalCollateral Cardano.ConwayEra, - Cardano.TxReturnCollateral Cardano.CtxTx Cardano.ConwayEra - ) -toCollateralTriplet = do - -- Retrieving know outputs - knownTxOuts <- asks managedTxOuts - -- Retrieving the outputs to be used as collateral inputs - collateralInsList <- asks (Set.toList . collateralIns) - -- We build the collateral inputs from this list - txInsCollateral <- - case collateralInsList of - [] -> return Cardano.TxInsCollateralNone - l -> throwOnToCardanoError "txOutRefsToTxInCollateral" (Cardano.TxInsCollateral Cardano.AlonzoEraOnwardsConway <$> mapM Ledger.toCardanoTxIn l) - -- Retrieving the total value in collateral inputs. This fails if one of the - -- collaterals has been been successfully resolved. - collateralInsValue <- do - let collateralInsResolved = mapMaybe (`Map.lookup` knownTxOuts) collateralInsList - when (length collateralInsResolved /= length collateralInsList) $ throwOnString "toCollateralTriplet: unresolved txOutRefs" - return $ mconcat (Api.txOutValue <$> collateralInsResolved) - -- We retrieve the collateral percentage compared to fees. By default, we use - -- 150% which is the current value in the parameters, although the default - -- value should never be used here, as the call is supposed to always succeed. - collateralPercentage <- asks (toInteger . fromMaybe 150 . Cardano.protocolParamCollateralPercent . Emulator.pProtocolParams . params) - -- The total collateral corresponds to the fees multiplied by the collateral - -- percentage. We add 1 because the ledger apparently rounds up this value. - coinTotalCollateral <- asks (Emulator.Coin . (+ 1) . (`div` 100) . (* collateralPercentage) . fee) - -- We create the total collateral based on the computed value - let txTotalCollateral = Cardano.TxTotalCollateral Cardano.BabbageEraOnwardsConway coinTotalCollateral - -- We compute a return collateral value by subtracting the total collateral to - -- the value in collateral inputs - let returnCollateralValue = collateralInsValue <> PlutusTx.negate (toValue coinTotalCollateral) - -- This should never happen, as we always compute the collaterals for the - -- user, but we guard against having some negative elements in the value in - -- case we give more freedom to the users in the future - when (fst (Api.split returnCollateralValue) /= mempty) $ throwOnString "toCollateralTriplet: negative parts in return collateral value" - -- The return collateral is then computed - txReturnCollateral <- - -- If the total collateral equal what the inputs provide, we return `None` - if returnCollateralValue == mempty - then return Cardano.TxReturnCollateralNone - else -- Otherwise, we compute the elements of a new output - do - -- The value is a translation of the remaining value - txReturnCollateralValue <- - Ledger.toCardanoTxOutValue - <$> throwOnToCardanoError - "toCollateralTriplet: cannot build return collateral value" - (Ledger.toCardanoValue returnCollateralValue) - -- The address is the one from the return collateral wallet, which is - -- required to exist here. - address <- do - mReturnCollateralWallet <- asks returnCollateralWallet - case mReturnCollateralWallet of - Nothing -> throwOnString "toCollateralTriplet: unable to find a return collateral wallet" - Just returnCollateralWallet -> do - networkId <- asks (Emulator.pNetworkId . params) - throwOnToCardanoError "toCollateralTriplet: cannot build return collateral address" $ - Ledger.toCardanoAddressInEra networkId (walletAddress returnCollateralWallet) - -- The return collateral is built up from those elements - return $ - Cardano.TxReturnCollateral Cardano.BabbageEraOnwardsConway $ - Cardano.TxOut address txReturnCollateralValue Cardano.TxOutDatumNone Cardano.ReferenceScriptNone - return (txInsCollateral, txTotalCollateral, txReturnCollateral) - --- Convert the 'TxSkelMints' into a 'TxMintValue' -txSkelMintsToTxMintValue :: TxSkelMints -> TxGen (Cardano.TxMintValue Cardano.BuildTx Cardano.ConwayEra) -txSkelMintsToTxMintValue mints = - if mints == Map.empty - then return Cardano.TxMintNone - else do - mintVal <- - throwOnToCardanoError "txSkelMintsToTxMintValue, translating minted value" $ Ledger.toCardanoValue $ txSkelMintsValue mints - witnessMap <- - foldM - ( \acc (policy, redeemer, _tName, _amount) -> do - policyId <- - throwOnToCardanoError - "txSkelMintsToTxMintValue, calculating the witness map" - (Ledger.toCardanoPolicyId (Script.mintingPolicyHash policy)) - mintWitness <- mintingPolicyToMintWitness policy redeemer - return $ Map.insert policyId mintWitness acc - ) - Map.empty - (txSkelMintsToList mints) - return $ Cardano.TxMintValue Cardano.MaryEraOnwardsConway mintVal (Cardano.BuildTxWith witnessMap) - -mintingPolicyToMintWitness :: Script.Versioned Script.MintingPolicy -> MintsRedeemer -> TxGen (Cardano.ScriptWitness Cardano.WitCtxMint Cardano.ConwayEra) -mintingPolicyToMintWitness (Script.Versioned (Script.MintingPolicy (Script.Script script)) version) redeemer = do - let scriptWitnessBuilder = case version of - Script.PlutusV1 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV1InConway Cardano.PlutusScriptV1 $ Cardano.PScript $ Cardano.PlutusScriptSerialised script - Script.PlutusV2 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV2InConway Cardano.PlutusScriptV2 $ Cardano.PScript $ Cardano.PlutusScriptSerialised script - Script.PlutusV3 -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV3InConway Cardano.PlutusScriptV3 $ Cardano.PScript $ Cardano.PlutusScriptSerialised script - return $ - scriptWitnessBuilder - Cardano.NoScriptDatumForMint -- This seems to be the only well-typed option (?) - ( case redeemer of - NoMintsRedeemer -> Ledger.toCardanoScriptData $ Api.toBuiltinData () - SomeMintsRedeemer red -> Ledger.toCardanoScriptData $ Api.toBuiltinData red - ) - Ledger.zeroExecutionUnits -- This is what plutus-apps does as well, we can't know this yet, no? - --- Convert a 'TxSkelOut' to the corresponding 'Cardano.TxOut'. -txSkelOutToCardanoTxOut :: TxSkelOut -> TxGen (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) -txSkelOutToCardanoTxOut (Pays output) = do - networkId <- asks $ Emulator.pNetworkId . params - address <- throwOnToCardanoError "txSkelOutToCardanoTxOut: wrong address" $ Ledger.toCardanoAddressInEra networkId (outputAddress output) - value <- Ledger.toCardanoTxOutValue <$> throwOnToCardanoError "txSkelOutToCardanoTxOut: cannot build value" (Ledger.toCardanoValue $ outputValue output) - datum <- case output ^. outputDatumL of - TxSkelOutNoDatum -> return Cardano.TxOutDatumNone - TxSkelOutDatumHash datum -> - throwOnToCardanoError "txSkelOutToTxOut: unresolved datum hash" $ - Cardano.TxOutDatumHash Cardano.AlonzoEraOnwardsConway - <$> Ledger.toCardanoScriptDataHash (Script.datumHash $ Api.Datum $ Api.toBuiltinData datum) - TxSkelOutDatum datum -> - return - $ Cardano.TxOutDatumInTx Cardano.AlonzoEraOnwardsConway - . Cardano.unsafeHashableScriptData - . Cardano.fromPlutusData - . Api.builtinDataToData - . Api.toBuiltinData - $ datum - TxSkelOutInlineDatum datum -> - return - $ Cardano.TxOutDatumInline Cardano.BabbageEraOnwardsConway - . Cardano.unsafeHashableScriptData - . Cardano.fromPlutusData - . Api.builtinDataToData - . Api.toBuiltinData - $ datum - let refScript = Ledger.toCardanoReferenceScript (toScript <$> output ^. outputReferenceScriptL) - return $ Cardano.TxOut address value datum refScript - -generateTxOut :: Cardano.NetworkId -> TxSkelOut -> Either GenerateTxError (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) -generateTxOut networkId = - flip runReaderT (def {params = def {Emulator.pNetworkId = networkId}}) . txSkelOutToCardanoTxOut - -txSkelToCardanoTx :: TxSkel -> TxGen (Cardano.Tx Cardano.ConwayEra) -txSkelToCardanoTx txSkel = do - txBodyContent <- txSkelToBodyContent txSkel - cardanoTxUnsigned <- - lift $ - bimap - (TxBodyError "generateTx: ") - (`Cardano.Tx` []) - (Cardano.createAndValidateTransactionBody Cardano.ShelleyBasedEraConway txBodyContent) - foldM - ( \tx wal -> - case Ledger.addCardanoTxWitness (Ledger.toWitness $ Ledger.PaymentPrivateKey $ walletSK wal) (Ledger.CardanoTx tx Cardano.ShelleyBasedEraConway) of - Ledger.CardanoTx tx' Cardano.ShelleyBasedEraConway -> return tx' - _ -> throwOnString "txSkelToCardanoTx: Wrong output era" - ) - cardanoTxUnsigned - (txSkelSigners txSkel) +generateBodyContent fee returnCollateralWallet collateralIns params managedData managedTxOuts managedValidators = + flip runReaderT TxContext {..} . txSkelToBodyContent +-- | Generates a transaction from a skeleton. Shares the same parameters as +-- `generateTxOut`. It consists of generating the body and then signing it. generateTx :: + -- | fee to apply to body generation Integer -> + -- | wallet to return collaterals to Wallet -> + -- | collaterals to add to body generation Set Api.TxOutRef -> + -- | parameters of the emulator Emulator.Params -> - Map Script.DatumHash Script.Datum -> + -- | datums present in our environment + Map Api.DatumHash Api.Datum -> + -- | txouts present in our environment Map Api.TxOutRef Api.TxOut -> + -- | validators present in our environment Map Script.ValidatorHash (Script.Versioned Script.Validator) -> + -- | The skeleton to translate TxSkel -> Either GenerateTxError (Cardano.Tx Cardano.ConwayEra) -generateTx fee (Just -> returnCollateralWallet) collateralIns params managedData managedTxOuts managedValidators = - flip runReaderT Context {..} . txSkelToCardanoTx +generateTx fee returnCollateralWallet collateralIns params managedData managedTxOuts managedValidators = + flip runReaderT TxContext {..} . txSkelToCardanoTx diff --git a/src/Cooked/MockChain/GenerateTx/Body.hs b/src/Cooked/MockChain/GenerateTx/Body.hs new file mode 100644 index 000000000..bbfb958be --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Body.hs @@ -0,0 +1,113 @@ +module Cooked.MockChain.GenerateTx.Body where + +import Cardano.Api qualified as Cardano +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Control.Monad +import Control.Monad.Reader +import Cooked.MockChain.GenerateTx.Collateral qualified as Collateral +import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.GenerateTx.Input qualified as Input +import Cooked.MockChain.GenerateTx.Mint qualified as Mint +import Cooked.MockChain.GenerateTx.Output qualified as Output +import Cooked.MockChain.GenerateTx.Proposal qualified as Proposal +import Cooked.Skeleton +import Cooked.Wallet +import Data.Bifunctor +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Set (Set) +import Ledger.Address qualified as Ledger +import Ledger.Tx qualified as Ledger +import Ledger.Tx.CardanoAPI qualified as Ledger +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V3 qualified as Api + +data TxContext where + TxContext :: + { fee :: Integer, + collateralIns :: Set Api.TxOutRef, + returnCollateralWallet :: Wallet, + params :: Emulator.Params, + managedData :: Map Api.DatumHash Api.Datum, + managedTxOuts :: Map Api.TxOutRef Api.TxOut, + managedValidators :: Map Script.ValidatorHash (Script.Versioned Script.Validator) + } -> + TxContext + +type BodyGen a = TxGen TxContext a + +instance Transform TxContext Cardano.NetworkId where + transform = Emulator.pNetworkId . params + +instance Transform TxContext (Map Api.TxOutRef Api.TxOut) where + transform = managedTxOuts + +instance Transform TxContext (Emulator.PParams, Map Api.TxOutRef Api.TxOut) where + transform ctx = (Emulator.pEmulatorPParams $ params ctx, transform ctx) + +instance Transform TxContext Input.InputContext where + transform TxContext {..} = Input.InputContext {..} + +instance Transform TxContext Collateral.CollateralContext where + transform TxContext {..} = Collateral.CollateralContext {..} + +-- | Generates a body content from a skeleton +txSkelToBodyContent :: TxSkel -> BodyGen (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra) +txSkelToBodyContent skel@TxSkel {..} | txSkelReferenceInputs <- txSkelReferenceTxOutRefs skel = do + txIns <- mapM (liftTxGen . Input.toTxInAndWitness) $ Map.toList txSkelIns + txInsReference <- + if null txSkelReferenceInputs + then return Cardano.TxInsReferenceNone + else + throwOnToCardanoErrorOrApply + "txSkelToBodyContent: Unable to translate reference inputs." + (Cardano.TxInsReference Cardano.BabbageEraOnwardsConway) + $ mapM Ledger.toCardanoTxIn txSkelReferenceInputs + (txInsCollateral, txTotalCollateral, txReturnCollateral) <- liftTxGen Collateral.toCollateralTriplet + txOuts <- mapM (liftTxGen . Output.toCardanoTxOut) txSkelOuts + (txValidityLowerBound, txValidityUpperBound) <- + throwOnToCardanoError + "txSkelToBodyContent: Unable to translate transaction validity range" + $ Ledger.toCardanoValidityRange txSkelValidityRange + txMintValue <- liftTxGen $ Mint.toMintValue txSkelMints + txExtraKeyWits <- + if null txSkelSigners + then return Cardano.TxExtraKeyWitnessesNone + else + throwOnToCardanoErrorOrApply + "txSkelToBodyContent: Unable to translate the required signers" + (Cardano.TxExtraKeyWitnesses Cardano.AlonzoEraOnwardsConway) + $ mapM (Ledger.toCardanoPaymentKeyHash . Ledger.PaymentPubKeyHash . walletPKHash) txSkelSigners + txProtocolParams <- asks (Cardano.BuildTxWith . Just . Emulator.ledgerProtocolParameters . params) + txFee <- asks (Cardano.TxFeeExplicit Cardano.ShelleyBasedEraConway . Emulator.Coin . fee) + txProposalProcedures <- + Just . Cardano.Featured Cardano.ConwayEraOnwardsConway + <$> liftTxGen (Proposal.toProposalProcedures txSkelProposals (txOptAnchorResolution txSkelOpts)) + let txMetadata = Cardano.TxMetadataNone -- That's what plutus-apps does as well + txAuxScripts = Cardano.TxAuxScriptsNone -- That's what plutus-apps does as well + txWithdrawals = Cardano.TxWithdrawalsNone -- That's what plutus-apps does as well + txCertificates = Cardano.TxCertificatesNone -- That's what plutus-apps does as well + txUpdateProposal = Cardano.TxUpdateProposalNone -- That's what plutus-apps does as well + txScriptValidity = Cardano.TxScriptValidityNone -- That's what plutus-apps does as well + txVotingProcedures = Nothing -- TODO, same as above + return Cardano.TxBodyContent {..} + +-- | Generates a transaction for a skeleton. We first generate a body and we +-- sign it with the required signers. +txSkelToCardanoTx :: TxSkel -> BodyGen (Cardano.Tx Cardano.ConwayEra) +txSkelToCardanoTx txSkel = do + txBodyContent <- txSkelToBodyContent txSkel + cardanoTxUnsigned <- + lift $ + bimap + (TxBodyError "generateTx: ") + (`Cardano.Tx` []) + (Cardano.createAndValidateTransactionBody Cardano.ShelleyBasedEraConway txBodyContent) + foldM + ( \tx wal -> + case Ledger.addCardanoTxWitness (Ledger.toWitness $ Ledger.PaymentPrivateKey $ walletSK wal) (Ledger.CardanoTx tx Cardano.ShelleyBasedEraConway) of + Ledger.CardanoTx tx' Cardano.ShelleyBasedEraConway -> return tx' + _ -> throwOnString "txSkelToCardanoTx: Wrong output era" + ) + cardanoTxUnsigned + (txSkelSigners txSkel) diff --git a/src/Cooked/MockChain/GenerateTx/Collateral.hs b/src/Cooked/MockChain/GenerateTx/Collateral.hs new file mode 100644 index 000000000..b7df81534 --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Collateral.hs @@ -0,0 +1,102 @@ +module Cooked.MockChain.GenerateTx.Collateral where + +import Cardano.Api qualified as Cardano +import Cardano.Api.Shelley qualified as Cardano hiding (Testnet) +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Control.Monad +import Control.Monad.Reader +import Cooked.Conversion +import Cooked.MockChain.GenerateTx.Common +import Cooked.Wallet +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe +import Data.Set (Set) +import Data.Set qualified as Set +import Ledger.Tx.CardanoAPI qualified as Ledger +import PlutusLedgerApi.V1.Value qualified as Api +import PlutusLedgerApi.V3 qualified as Api +import PlutusTx.Numeric qualified as PlutusTx + +data CollateralContext where + CollateralContext :: + { managedTxOuts :: Map Api.TxOutRef Api.TxOut, + collateralIns :: Set Api.TxOutRef, + fee :: Integer, + returnCollateralWallet :: Wallet, + params :: Emulator.Params + } -> + CollateralContext + +type CollateralGen a = TxGen CollateralContext a + +-- | Computes the collateral triplet from the fees and the collateral inputs in +-- the context. What we call a collateral triplet is composed of: +-- * The set of collateral inputs +-- * The total collateral paid by the transaction in case of phase 2 failure +-- * An output returning excess collateral value when collaterals are used +-- These quantity should satisfy the equation (in terms of their values): +-- collateral inputs = total collateral + return collateral +toCollateralTriplet :: + CollateralGen + ( Cardano.TxInsCollateral Cardano.ConwayEra, + Cardano.TxTotalCollateral Cardano.ConwayEra, + Cardano.TxReturnCollateral Cardano.CtxTx Cardano.ConwayEra + ) +toCollateralTriplet = do + -- Retrieving know outputs + knownTxOuts <- asks managedTxOuts + -- Retrieving the outputs to be used as collateral inputs + collateralInsList <- asks (Set.toList . collateralIns) + -- We build the collateral inputs from this list + txInsCollateral <- + case collateralInsList of + [] -> return Cardano.TxInsCollateralNone + l -> throwOnToCardanoError "txOutRefsToTxInCollateral" (Cardano.TxInsCollateral Cardano.AlonzoEraOnwardsConway <$> mapM Ledger.toCardanoTxIn l) + -- Retrieving the total value in collateral inputs. This fails if one of the + -- collaterals has been been successfully resolved. + collateralInsValue <- do + let collateralInsResolved = mapMaybe (`Map.lookup` knownTxOuts) collateralInsList + when (length collateralInsResolved /= length collateralInsList) $ throwOnString "toCollateralTriplet: unresolved txOutRefs" + return $ mconcat (Api.txOutValue <$> collateralInsResolved) + -- We retrieve the collateral percentage compared to fees. By default, we use + -- 150% which is the current value in the parameters, although the default + -- value should never be used here, as the call is supposed to always succeed. + collateralPercentage <- asks (toInteger . fromMaybe 150 . Cardano.protocolParamCollateralPercent . Emulator.pProtocolParams . params) + -- The total collateral corresponds to the fees multiplied by the collateral + -- percentage. We add 1 because the ledger apparently rounds up this value. + coinTotalCollateral <- asks (Emulator.Coin . (+ 1) . (`div` 100) . (* collateralPercentage) . fee) + -- We create the total collateral based on the computed value + let txTotalCollateral = Cardano.TxTotalCollateral Cardano.BabbageEraOnwardsConway coinTotalCollateral + -- We compute a return collateral value by subtracting the total collateral to + -- the value in collateral inputs + let returnCollateralValue = collateralInsValue <> PlutusTx.negate (toValue coinTotalCollateral) + -- This should never happen, as we always compute the collaterals for the + -- user, but we guard against having some negative elements in the value in + -- case we give more freedom to the users in the future + when (fst (Api.split returnCollateralValue) /= mempty) $ throwOnString "toCollateralTriplet: negative parts in return collateral value" + -- The return collateral is then computed + txReturnCollateral <- + -- If the total collateral equal what the inputs provide, we return `None` + if returnCollateralValue == mempty + then return Cardano.TxReturnCollateralNone + else -- Otherwise, we compute the elements of a new output + do + -- The value is a translation of the remaining value + txReturnCollateralValue <- + Ledger.toCardanoTxOutValue + <$> throwOnToCardanoError + "toCollateralTriplet: cannot build return collateral value" + (Ledger.toCardanoValue returnCollateralValue) + -- The address is the one from the return collateral wallet, which is + -- required to exist here. + address <- do + returnCollateralWallet <- asks returnCollateralWallet + networkId <- asks (Emulator.pNetworkId . params) + throwOnToCardanoError "toCollateralTriplet: cannot build return collateral address" $ + Ledger.toCardanoAddressInEra networkId (walletAddress returnCollateralWallet) + -- The return collateral is built up from those elements + return $ + Cardano.TxReturnCollateral Cardano.BabbageEraOnwardsConway $ + Cardano.TxOut address txReturnCollateralValue Cardano.TxOutDatumNone Cardano.ReferenceScriptNone + return (txInsCollateral, txTotalCollateral, txReturnCollateral) diff --git a/src/Cooked/MockChain/GenerateTx/Common.hs b/src/Cooked/MockChain/GenerateTx/Common.hs new file mode 100644 index 000000000..829daa689 --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Common.hs @@ -0,0 +1,60 @@ +module Cooked.MockChain.GenerateTx.Common + ( GenerateTxError (..), + TxGen, + Transform (..), + throwOnLookup, + throwOnString, + throwOnToCardanoErrorOrApply, + throwOnToCardanoError, + liftTxGen, + ) +where + +import Cardano.Api.Shelley qualified as Cardano +import Control.Monad.Reader +import Data.Bifunctor +import Data.Map (Map) +import Data.Map qualified as Map +import Ledger.Tx qualified as Ledger + +-- | Errors that can arise during transaction generation +data GenerateTxError + = ToCardanoError String Ledger.ToCardanoError + | TxBodyError String Cardano.TxBodyError + | GenerateTxErrorGeneral String + deriving (Show, Eq) + +-- | The domain in which transaction parts are generated. +type TxGen context a = ReaderT context (Either GenerateTxError) a + +class Transform a b where + transform :: a -> b + +instance Transform (a, b) b where + transform = snd + +instance Transform (a, b) a where + transform = fst + +-- | Lifts a computation from a smaller context +liftTxGen :: (Transform context' context) => TxGen context a -> TxGen context' a +liftTxGen comp = (lift . runReaderT comp) =<< asks transform + +-- | Looks up a key in a map. Throws a 'GenerateTxErrorGeneral' error with a given +-- message when the key is absent, returns the associated value otherwise. +throwOnLookup :: (Ord k) => String -> k -> Map k a -> TxGen context a +throwOnLookup errorMsg key = maybe (throwOnString errorMsg) return . Map.lookup key + +-- | Throws a general error from a String. +throwOnString :: String -> TxGen context a +throwOnString = lift . Left . GenerateTxErrorGeneral + +-- | Lifts a 'ToCardanoError' with an associated error message, or apply a +-- function if a value exists. +throwOnToCardanoErrorOrApply :: String -> (a -> b) -> Either Ledger.ToCardanoError a -> TxGen context b +throwOnToCardanoErrorOrApply errorMsg f = lift . bimap (ToCardanoError errorMsg) f + +-- | Lifts a 'ToCardanoError' with an associated error message, or leaves the +-- value unchanged if it exists. +throwOnToCardanoError :: String -> Either Ledger.ToCardanoError a -> TxGen context a +throwOnToCardanoError = flip throwOnToCardanoErrorOrApply id diff --git a/src/Cooked/MockChain/GenerateTx/Input.hs b/src/Cooked/MockChain/GenerateTx/Input.hs new file mode 100644 index 000000000..9ee954920 --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Input.hs @@ -0,0 +1,51 @@ +module Cooked.MockChain.GenerateTx.Input + ( toTxInAndWitness, + InputContext (..), + ) +where + +import Cardano.Api qualified as Cardano +import Control.Monad.Reader +import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.GenerateTx.Witness +import Cooked.Skeleton +import Data.Map (Map) +import Ledger.Tx.CardanoAPI qualified as Ledger +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V3 qualified as Api + +data InputContext where + InputContext :: + { managedData :: Map Api.DatumHash Api.Datum, + managedTxOuts :: Map Api.TxOutRef Api.TxOut, + managedValidators :: Map Script.ValidatorHash (Script.Versioned Script.Validator) + } -> + InputContext + +instance Transform InputContext (Map Api.TxOutRef Api.TxOut) where + transform = managedTxOuts + +type InputGen a = TxGen InputContext a + +-- | Converts a 'TxSkel' input, which consists of a 'Api.TxOutRef' and a +-- 'TxSkelIn', into a 'Cardano.TxIn', together with the appropriate witness. +toTxInAndWitness :: + (Api.TxOutRef, TxSkelRedeemer) -> + InputGen (Cardano.TxIn, Cardano.BuildTxWith Cardano.BuildTx (Cardano.Witness Cardano.WitCtxTxIn Cardano.ConwayEra)) +toTxInAndWitness (txOutRef, txSkelRedeemer) = do + Api.TxOut (Api.Address cred _) _ datum _ <- throwOnLookup "toTxInAndWitness: Unknown txOutRef" txOutRef =<< asks managedTxOuts + witness <- case cred of + Api.PubKeyCredential _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending + Api.ScriptCredential (Api.ScriptHash scriptHash) -> do + validator <- throwOnLookup "toTxInAndWitness: Unknown validator" (Script.ValidatorHash scriptHash) =<< asks managedValidators + scriptDatum <- case datum of + Api.NoOutputDatum -> throwOnString "toTxInAndWitness: No datum found on script output" + Api.OutputDatum _ -> return Cardano.InlineScriptDatum + Api.OutputDatumHash datumHash -> do + sDatum <- throwOnLookup "toTxInAndWitness: Unknown datum hash" datumHash =<< asks managedData + return $ Cardano.ScriptDatumForTxIn $ Ledger.toCardanoScriptData $ Api.getDatum sDatum + Cardano.ScriptWitness Cardano.ScriptWitnessForSpending <$> liftTxGen (toScriptWitness validator txSkelRedeemer scriptDatum) + throwOnToCardanoErrorOrApply + "toTxInAndWitness: Unable to translate TxOutRef" + (,Cardano.BuildTxWith witness) + $ Ledger.toCardanoTxIn txOutRef diff --git a/src/Cooked/MockChain/GenerateTx/Mint.hs b/src/Cooked/MockChain/GenerateTx/Mint.hs new file mode 100644 index 000000000..32c469478 --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Mint.hs @@ -0,0 +1,39 @@ +module Cooked.MockChain.GenerateTx.Mint + ( toMintValue, + ) +where + +import Cardano.Api qualified as Cardano +import Control.Monad +import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.GenerateTx.Witness +import Cooked.Skeleton +import Data.Map (Map) +import Data.Map qualified as Map +import Ledger.Tx.CardanoAPI qualified as Ledger +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V3 qualified as Api + +type MintGen a = TxGen (Map Api.TxOutRef Api.TxOut) a + +-- | Converts the 'TxSkelMints' into a 'TxMintValue' +toMintValue :: TxSkelMints -> MintGen (Cardano.TxMintValue Cardano.BuildTx Cardano.ConwayEra) +toMintValue mints = + if null mints + then return Cardano.TxMintNone + else do + let mintValue = txSkelMintsValue mints + mintVal <- + throwOnToCardanoError + ("toMintValue: Unable to translate minted value " <> show mintValue) + (Ledger.toCardanoValue mintValue) + (Map.fromList -> witnessMap) <- + forM (txSkelMintsToList mints) $ + \(policy, redeemer, _, _) -> do + policyId <- + throwOnToCardanoError + "toMintValue: Unable to translate minting policy hash" + (Ledger.toCardanoPolicyId (Script.mintingPolicyHash policy)) + mintWitness <- toScriptWitness policy redeemer Cardano.NoScriptDatumForMint + return (policyId, mintWitness) + return $ Cardano.TxMintValue Cardano.MaryEraOnwardsConway mintVal (Cardano.BuildTxWith witnessMap) diff --git a/src/Cooked/MockChain/GenerateTx/Output.hs b/src/Cooked/MockChain/GenerateTx/Output.hs new file mode 100644 index 000000000..3e86b1aed --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Output.hs @@ -0,0 +1,48 @@ +module Cooked.MockChain.GenerateTx.Output + ( toCardanoTxOut, + ) +where + +import Cardano.Api.Shelley qualified as Cardano +import Control.Monad.Reader +import Cooked.Conversion +import Cooked.MockChain.GenerateTx.Common +import Cooked.Output +import Cooked.Skeleton +import Ledger.Tx.CardanoAPI qualified as Ledger +import Optics.Core +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V3 qualified as Api + +type OutputGen a = TxGen Cardano.NetworkId a + +-- | Convert a plutus data to a cardano data +toHashableScriptData :: (Api.ToData a) => a -> Cardano.HashableScriptData +toHashableScriptData = Cardano.unsafeHashableScriptData . Cardano.fromPlutusData . Api.builtinDataToData . Api.toBuiltinData + +-- | Converts a 'TxSkelOut' to the corresponding 'Cardano.TxOut' +toCardanoTxOut :: TxSkelOut -> OutputGen (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) +toCardanoTxOut (Pays output) = do + let oAddress = outputAddress output + oValue = outputValue output + oDatum = output ^. outputDatumL + oRefScript = output ^. outputReferenceScriptL + networkId <- ask + address <- + throwOnToCardanoError + ("toCardanoTxOut: Unable to translate the following address: " <> show oAddress) + (Ledger.toCardanoAddressInEra networkId oAddress) + (Ledger.toCardanoTxOutValue -> value) <- + throwOnToCardanoError + ("toCardanoTxOut: Unable to translate the following value:" <> show oValue) + (Ledger.toCardanoValue oValue) + datum <- case oDatum of + TxSkelOutNoDatum -> return Cardano.TxOutDatumNone + TxSkelOutDatumHash datum -> + throwOnToCardanoError + "toCardanoTxOut: Unable to resolve/transate a datum hash." + $ Cardano.TxOutDatumHash Cardano.AlonzoEraOnwardsConway + <$> Ledger.toCardanoScriptDataHash (Script.datumHash $ Api.Datum $ Api.toBuiltinData datum) + TxSkelOutDatum datum -> return $ Cardano.TxOutDatumInTx Cardano.AlonzoEraOnwardsConway $ toHashableScriptData datum + TxSkelOutInlineDatum datum -> return $ Cardano.TxOutDatumInline Cardano.BabbageEraOnwardsConway $ toHashableScriptData datum + return $ Cardano.TxOut address value datum $ Ledger.toCardanoReferenceScript (toScript <$> oRefScript) diff --git a/src/Cooked/MockChain/GenerateTx/Proposal.hs b/src/Cooked/MockChain/GenerateTx/Proposal.hs new file mode 100644 index 000000000..d1a927558 --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Proposal.hs @@ -0,0 +1,154 @@ +module Cooked.MockChain.GenerateTx.Proposal + ( toProposalProcedures, + ) +where + +import Cardano.Api qualified as Cardano +import Cardano.Ledger.BaseTypes qualified as Cardano +import Cardano.Ledger.Conway.Core qualified as Conway +import Cardano.Ledger.Conway.Governance qualified as Conway +import Cardano.Ledger.Core qualified as Cardano (emptyPParamsStrictMaybe) +import Cardano.Ledger.Plutus.ExUnits qualified as Cardano +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Control.Lens qualified as Lens +import Control.Monad.Catch +import Control.Monad.Reader +import Cooked.Conversion +import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.GenerateTx.Witness +import Cooked.Skeleton +import Data.Default +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Map.Strict qualified as SMap +import Data.Maybe +import Data.Maybe.Strict +import Data.OSet.Strict qualified as OSet +import Data.Set qualified as Set +import Data.Text qualified as Text +import GHC.IO.Unsafe +import Ledger.Tx.CardanoAPI qualified as Ledger +import Lens.Micro qualified as MicroLens +import Network.HTTP.Simple qualified as Network +import Optics.Core +import PlutusLedgerApi.V1.Value qualified as Api +import PlutusLedgerApi.V3 qualified as Api + +type ProposalGen a = TxGen (Emulator.PParams, Map Api.TxOutRef Api.TxOut) a + +-- | Transorms a `TxParameterChange` into an actual change over a Cardano +-- parameter update +toPParamsUpdate :: TxParameterChange -> Conway.PParamsUpdate Emulator.EmulatorEra -> Conway.PParamsUpdate Emulator.EmulatorEra +toPParamsUpdate pChange = + -- From rational to bounded rational + let toBR :: (Cardano.BoundedRational r) => Rational -> r + toBR = fromMaybe minBound . Cardano.boundRational + -- Helper to set one of the param update with a lens + setL l = MicroLens.set l . SJust + in case pChange of + -- will exist later on: MinFeeRefScriptCostPerByte n -> setL Conway.ppuMinFeeRefScriptCostPerByteL $ fromIntegral n + FeePerByte n -> setL Conway.ppuMinFeeAL $ fromIntegral n + FeeFixed n -> setL Conway.ppuMinFeeBL $ fromIntegral n + MaxBlockBodySize n -> setL Conway.ppuMaxBBSizeL $ fromIntegral n + MaxTxSize n -> setL Conway.ppuMaxTxSizeL $ fromIntegral n + MaxBlockHeaderSize n -> setL Conway.ppuMaxBHSizeL $ fromIntegral n + KeyDeposit n -> setL Conway.ppuKeyDepositL $ fromIntegral n + PoolDeposit n -> setL Conway.ppuPoolDepositL $ fromIntegral n + PoolRetirementMaxEpoch n -> setL Conway.ppuEMaxL $ Cardano.EpochInterval $ fromIntegral n + PoolNumber n -> setL Conway.ppuNOptL $ fromIntegral n + PoolInfluence q -> setL Conway.ppuA0L $ fromMaybe minBound $ Cardano.boundRational q + MonetaryExpansion q -> setL Conway.ppuRhoL $ fromMaybe minBound $ Cardano.boundRational q + TreasuryCut q -> setL Conway.ppuTauL $ toBR q + MinPoolCost n -> setL Conway.ppuMinPoolCostL $ fromIntegral n + CoinsPerUTxOByte n -> setL Conway.ppuCoinsPerUTxOByteL $ Conway.CoinPerByte $ fromIntegral n + CostModels _pv1 _pv2 _pv3 -> id -- TODO unsupported for now + Prices q r -> setL Conway.ppuPricesL $ Cardano.Prices (toBR q) (toBR r) + MaxTxExUnits n m -> setL Conway.ppuMaxTxExUnitsL $ Cardano.ExUnits (fromIntegral n) (fromIntegral m) + MaxBlockExUnits n m -> setL Conway.ppuMaxBlockExUnitsL $ Cardano.ExUnits (fromIntegral n) (fromIntegral m) + MaxValSize n -> setL Conway.ppuMaxValSizeL $ fromIntegral n + CollateralPercentage n -> setL Conway.ppuCollateralPercentageL $ fromIntegral n + MaxCollateralInputs n -> setL Conway.ppuMaxCollateralInputsL $ fromIntegral n + PoolVotingThresholds a b c d e -> + setL Conway.ppuPoolVotingThresholdsL $ + Conway.PoolVotingThresholds (toBR a) (toBR b) (toBR c) (toBR d) (toBR e) + DRepVotingThresholds a b c d e f g h i j -> + setL Conway.ppuDRepVotingThresholdsL $ + Conway.DRepVotingThresholds (toBR a) (toBR b) (toBR c) (toBR d) (toBR e) (toBR f) (toBR g) (toBR h) (toBR i) (toBR j) + CommitteeMinSize n -> setL Conway.ppuCommitteeMinSizeL $ fromIntegral n + CommitteeMaxTermLength n -> setL Conway.ppuCommitteeMaxTermLengthL $ Cardano.EpochInterval $ fromIntegral n + GovActionLifetime n -> setL Conway.ppuGovActionLifetimeL $ Cardano.EpochInterval $ fromIntegral n + GovActionDeposit n -> setL Conway.ppuGovActionDepositL $ fromIntegral n + DRepRegistrationDeposit n -> setL Conway.ppuDRepDepositL $ fromIntegral n + DRepActivity n -> setL Conway.ppuDRepActivityL $ Cardano.EpochInterval $ fromIntegral n + +-- | Translates a given skeleton proposal into a governance action +toGovAction :: TxSkelProposal -> ProposalGen (Conway.GovAction Emulator.EmulatorEra) +toGovAction TxSkelProposal {..} = do + sHash <- case txSkelProposalWitness of + Nothing -> return SNothing + Just (script, _) -> do + Cardano.ScriptHash sHash <- + throwOnToCardanoError + "Unable to convert script hash" + (Ledger.toCardanoScriptHash (toScriptHash script)) + return $ SJust sHash + case txSkelProposalAction of + TxGovActionParameterChange changes -> + return $ + Conway.ParameterChange + SNothing -- TODO, should not be Nothing later on + (foldl (flip toPParamsUpdate) (Conway.PParamsUpdate Cardano.emptyPParamsStrictMaybe) changes) + sHash + TxGovActionHardForkInitiation _ -> throwOnString "TxGovActionHardForkInitiation unsupported" + TxGovActionTreasuryWithdrawals mapCredentialLovelace -> do + cardanoMap <- SMap.fromList <$> mapM (\(cred, Api.Lovelace lv) -> (,Emulator.Coin lv) <$> liftTxGen (toRewardAccount cred)) (Map.toList mapCredentialLovelace) + return $ Conway.TreasuryWithdrawals cardanoMap sHash + TxGovActionNoConfidence -> return $ Conway.NoConfidence SNothing -- TODO, should not be Nothing later on + TxGovActionUpdateCommittee {} -> throwOnString "TxGovActionUpdateCommittee unsupported" + TxGovActionNewConstitution _ -> throwOnString "TxGovActionNewConstitution unsupported" + +-- | Translates a skeleton proposal into a proposal procedure alongside a +-- possible witness +toProposalProcedureAndWitness :: TxSkelProposal -> AnchorResolution -> ProposalGen (Conway.ProposalProcedure Emulator.EmulatorEra, Maybe (Cardano.ScriptWitness Cardano.WitCtxStake Cardano.ConwayEra)) +toProposalProcedureAndWitness txSkelProposal@TxSkelProposal {..} anchorResolution = do + minDeposit <- asks (Emulator.unCoin . Lens.view Conway.ppGovActionDepositL . fst) + cred <- liftTxGen $ toRewardAccount $ toCredential txSkelProposalAddress + govAction <- toGovAction txSkelProposal + let proposalAnchor = do + anchor <- txSkelProposalAnchor + anchorUrl <- Cardano.textToUrl (length anchor) (Text.pack anchor) + let anchorDataHash = + case anchorResolution of + AnchorResolutionHttp -> + -- WARNING: very unsafe and unreproducible + unsafePerformIO + ( handle + (return . throwOnString . (("Error when parsing anchor " ++ show anchor ++ " with error: ") ++) . (show @Network.HttpException)) + ((Network.parseRequest anchor >>= Network.httpBS) <&> return . Network.getResponseBody) + ) + AnchorResolutionLocal urls -> + throwOnLookup "Error when attempting to retrieve anchor url in the local anchor resolution map" anchor urls + return $ Cardano.Anchor anchorUrl . Cardano.hashAnchorData . Cardano.AnchorData <$> anchorDataHash + anchor <- fromMaybe (return def) proposalAnchor + let conwayProposalProcedure = Conway.ProposalProcedure (Emulator.Coin minDeposit) cred govAction anchor + (conwayProposalProcedure,) <$> case txSkelProposalWitness of + Nothing -> return Nothing + Just (script, redeemer) -> Just <$> liftTxGen (toScriptWitness (toScript script) redeemer Cardano.NoScriptDatumForStake) + +-- | Translates a list of skeleton proposals into a proposal procedures +toProposalProcedures :: [TxSkelProposal] -> AnchorResolution -> ProposalGen (Cardano.TxProposalProcedures Cardano.BuildTx Cardano.ConwayEra) +toProposalProcedures props anchorResolution = do + (OSet.fromSet -> ppSet, Cardano.BuildTxWith -> ppMap) <- go props + return $ + if null ppSet + then Cardano.TxProposalProceduresNone + else Cardano.TxProposalProcedures ppSet ppMap + where + go [] = return (Set.empty, Map.empty) + go (h : t) = do + (proposals, mapWitnesses) <- go t + (proposal, maybeWitness) <- toProposalProcedureAndWitness h anchorResolution + let outputMap = case maybeWitness of + Nothing -> mapWitnesses + Just newWitness -> Map.insert proposal newWitness mapWitnesses + return (Set.insert proposal proposals, outputMap) diff --git a/src/Cooked/MockChain/GenerateTx/Witness.hs b/src/Cooked/MockChain/GenerateTx/Witness.hs new file mode 100644 index 000000000..dccde72cf --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Witness.hs @@ -0,0 +1,86 @@ +module Cooked.MockChain.GenerateTx.Witness + ( toRewardAccount, + toScriptWitness, + ) +where + +import Cardano.Api.Shelley qualified as Cardano hiding (Testnet) +import Cardano.Ledger.Address qualified as Cardano +import Cardano.Ledger.BaseTypes qualified as Cardano +import Cardano.Ledger.Credential qualified as Cardano +import Cardano.Ledger.Crypto qualified as Crypto +import Control.Monad +import Control.Monad.Reader +import Cooked.Conversion +import Cooked.MockChain.GenerateTx.Common +import Cooked.Output +import Cooked.Skeleton +import Data.Map (Map) +import Data.Map qualified as Map +import Ledger.Tx.CardanoAPI qualified as Ledger +import Optics.Core +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V3 qualified as Api + +type WitnessGen a = TxGen (Map Api.TxOutRef Api.TxOut) a + +-- | Translates a given credential to a reward account. +toRewardAccount :: Api.Credential -> WitnessGen (Cardano.RewardAcnt Crypto.StandardCrypto) +toRewardAccount cred = + Cardano.RewardAcnt Cardano.Testnet <$> case cred of + Api.ScriptCredential scriptHash -> do + Cardano.ScriptHash cHash <- + throwOnToCardanoError + "toRewardAccount: Unable to convert script hash." + (Ledger.toCardanoScriptHash scriptHash) + return $ Cardano.ScriptHashObj cHash + Api.PubKeyCredential pubkeyHash -> do + Cardano.StakeKeyHash pkHash <- + throwOnToCardanoError + "toRewardAccount: Unable to convert private key hash." + -- TODO: we take the pubkeyHash, maybe we should take the stakehash if + -- any exists. The nature of the stake address can be confusing. + (Ledger.toCardanoStakeKeyHash pubkeyHash) + return $ Cardano.KeyHashObj pkHash + +-- | Translates a serialised script and a redeemer to their Cardano +-- counterparts. They cannot be uncoupled because of the possible presence of a +-- reference script utxo in the redeemer. +toScriptAndRedeemerData :: Api.SerialisedScript -> TxSkelRedeemer -> WitnessGen (Cardano.PlutusScriptOrReferenceInput lang, Cardano.HashableScriptData) +toScriptAndRedeemerData script TxSkelNoRedeemer = + return (Cardano.PScript $ Cardano.PlutusScriptSerialised script, Ledger.toCardanoScriptData $ Api.toBuiltinData ()) +toScriptAndRedeemerData script (TxSkelRedeemerForScript redeemer) = + return (Cardano.PScript $ Cardano.PlutusScriptSerialised script, Ledger.toCardanoScriptData $ Api.toBuiltinData redeemer) +toScriptAndRedeemerData script (TxSkelRedeemerForReferenceScript validatorOref redeemer) = do + referenceScriptsMap <- asks $ Map.mapMaybe (^. outputReferenceScriptL) + refScriptHash <- + throwOnLookup + "toScriptAndRedeemerData: Can't resolve reference script utxo." + validatorOref + referenceScriptsMap + when (refScriptHash /= toScriptHash script) $ + throwOnString "toScriptAndRedeemerData: Wrong reference script hash." + validatorTxIn <- + throwOnToCardanoError + "toScriptAndRedeemerData: Unable to translate reference script utxo." + (Ledger.toCardanoTxIn validatorOref) + scriptHash <- + throwOnToCardanoError + "toScriptAndRedeemerData: Unable to translate script hash of reference script." + (Ledger.toCardanoScriptHash refScriptHash) + return (Cardano.PReferenceScript validatorTxIn (Just scriptHash), Ledger.toCardanoScriptData $ Api.toBuiltinData redeemer) + +-- | Translates a script with its associated redeemer and datum to a script +-- witness. +toScriptWitness :: (ToScript a) => a -> TxSkelRedeemer -> Cardano.ScriptDatum b -> WitnessGen (Cardano.ScriptWitness b Cardano.ConwayEra) +toScriptWitness (toScript -> (Script.Versioned (Script.Script script) version)) redeemer datum = + case version of + Script.PlutusV1 -> + (\(x, y) -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV1InConway Cardano.PlutusScriptV1 x datum y Ledger.zeroExecutionUnits) + <$> toScriptAndRedeemerData script redeemer + Script.PlutusV2 -> + (\(x, y) -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV2InConway Cardano.PlutusScriptV2 x datum y Ledger.zeroExecutionUnits) + <$> toScriptAndRedeemerData script redeemer + Script.PlutusV3 -> + (\(x, y) -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV3InConway Cardano.PlutusScriptV3 x datum y Ledger.zeroExecutionUnits) + <$> toScriptAndRedeemerData script redeemer diff --git a/src/Cooked/Pretty/Class.hs b/src/Cooked/Pretty/Class.hs index 218e8faef..54d70e0c3 100644 --- a/src/Cooked/Pretty/Class.hs +++ b/src/Cooked/Pretty/Class.hs @@ -17,6 +17,7 @@ import Cooked.Pretty.Common import Cooked.Pretty.Hashable import Cooked.Pretty.Options import Data.Default +import Data.Ratio import Ledger.Index qualified as Ledger import Ledger.Scripts qualified as Ledger import Ledger.Tx.CardanoAPI qualified as Ledger @@ -54,6 +55,9 @@ instance PrettyCooked Api.TxOutRef where instance PrettyCooked (Script.Versioned Script.MintingPolicy) where prettyCookedOpt opts = prettyHash (pcOptHashes opts) . toHash +instance PrettyCooked (Script.Versioned Script.Script) where + prettyCookedOpt opts = prettyHash (pcOptHashes opts) . toHash + instance PrettyCooked Api.Address where prettyCookedOpt opts (Api.Address addrCr Nothing) = prettyCookedOpt opts addrCr prettyCookedOpt opts (Api.Address addrCr (Just (Api.StakingHash stakCr))) = @@ -158,3 +162,6 @@ instance PrettyCooked () where instance PrettyCooked Api.BuiltinData where prettyCookedOpt _ = PP.pretty + +instance PrettyCooked Rational where + prettyCookedOpt opts q = "(" <+> prettyCookedOpt opts (numerator q) <+> "/" <+> prettyCookedOpt opts (denominator q) <+> ")" diff --git a/src/Cooked/Pretty/Cooked.hs b/src/Cooked/Pretty/Cooked.hs index 646c5841e..530d067b7 100644 --- a/src/Cooked/Pretty/Cooked.hs +++ b/src/Cooked/Pretty/Cooked.hs @@ -29,7 +29,7 @@ module Cooked.Pretty.Cooked ) where -import Cooked.Conversion.ToScriptHash +import Cooked.Conversion import Cooked.MockChain.BlockChain import Cooked.MockChain.GenerateTx import Cooked.MockChain.Staged @@ -80,8 +80,8 @@ instance PrettyCooked MockChainError where prettyItemize "No suitable collateral" "-" - [ "Fee was" <+> PP.pretty fee, - "Percentage in params was" <+> PP.pretty percentage, + [ "Fee was" <+> prettyCookedOpt opts fee, + "Percentage in params was" <+> prettyCookedOpt opts percentage, "Resulting minimal collateral value was" <+> prettyCookedOpt opts colVal ] prettyCookedOpt _ (MCEGenerationError (ToCardanoError msg cardanoError)) = @@ -171,7 +171,7 @@ instance PrettyCooked MockChainLog where go acc [] = reverse acc prettyTxSkel :: PrettyCookedOpts -> SkelContext -> TxSkel -> DocCooked -prettyTxSkel opts skelContext (TxSkel lbl txopts mints signers validityRange ins insReference outs) = +prettyTxSkel opts skelContext (TxSkel lbl txopts mints signers validityRange ins insReference outs proposals) = prettyItemize "transaction skeleton:" "-" @@ -183,10 +183,130 @@ prettyTxSkel opts skelContext (TxSkel lbl txopts mints signers validityRange ins prettyItemizeNonEmpty "Signers:" "-" (prettySigners opts txopts signers), prettyItemizeNonEmpty "Inputs:" "-" (prettyTxSkelIn opts skelContext <$> Map.toList ins), prettyItemizeNonEmpty "Reference inputs:" "-" (mapMaybe (prettyTxSkelInReference opts skelContext) $ Set.toList insReference), - prettyItemizeNonEmpty "Outputs:" "-" (prettyTxSkelOut opts <$> outs) + prettyItemizeNonEmpty "Outputs:" "-" (prettyTxSkelOut opts <$> outs), + prettyItemizeNonEmpty "Proposals:" "-" (prettyTxSkelProposal opts <$> proposals) ] ) +prettyTxParameterChange :: PrettyCookedOpts -> TxParameterChange -> DocCooked +prettyTxParameterChange opts (FeePerByte n) = "Fee per byte:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (FeeFixed n) = "Fee fixed:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (MaxBlockBodySize n) = "Max block body size:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (MaxTxSize n) = "Max transaction size:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (MaxBlockHeaderSize n) = "Max block header size:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (KeyDeposit n) = "Key deposit:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (PoolDeposit n) = "Pool deposit:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (PoolRetirementMaxEpoch n) = "Pool retirement max epoch:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (PoolNumber n) = "Pool number:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (PoolInfluence q) = "Pool influence:" <+> prettyCookedOpt opts q +prettyTxParameterChange opts (MonetaryExpansion q) = "Monetary expansion:" <+> prettyCookedOpt opts q +prettyTxParameterChange opts (TreasuryCut q) = "Treasury cut:" <+> prettyCookedOpt opts q +prettyTxParameterChange opts (MinPoolCost n) = "Min pool cost:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (CoinsPerUTxOByte n) = "Lovelace per utxo byte:" <+> prettyCookedOpt opts n +prettyTxParameterChange _opts (CostModels _pv1 _pv2 _pv3) = "Cost models (unsupported)" +prettyTxParameterChange opts (Prices q r) = + prettyItemize + "Prices:" + "-" + [ "Memory cost:" <+> prettyCookedOpt opts q, + "Step cost:" <+> prettyCookedOpt opts r + ] +prettyTxParameterChange opts (MaxTxExUnits n m) = + prettyItemize + "Max transaction execution units:" + "-" + [ "Max memory:" <+> prettyCookedOpt opts n, + "Max steps:" <+> prettyCookedOpt opts m + ] +prettyTxParameterChange opts (MaxBlockExUnits n m) = + prettyItemize + "Max block execution units:" + "-" + [ "Max memory:" <+> prettyCookedOpt opts n, + "Max steps:" <+> prettyCookedOpt opts m + ] +prettyTxParameterChange opts (MaxValSize n) = "Max value size:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (CollateralPercentage n) = "Collateral percentage:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (MaxCollateralInputs n) = "Max number of collateral inputs:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (PoolVotingThresholds a b c d e) = + prettyItemize + "Pool voting thresholds:" + "-" + [ "Motion no confidence:" <+> prettyCookedOpt opts a, + "Committee normal:" <+> prettyCookedOpt opts b, + "Committee no confidence:" <+> prettyCookedOpt opts c, + "Hard fork:" <+> prettyCookedOpt opts d, + "Security group:" <+> prettyCookedOpt opts e + ] +prettyTxParameterChange opts (DRepVotingThresholds a b c d e f g h i j) = + prettyItemize + "DRep voting thresholds:" + "-" + [ "Motion no confidence:" <+> prettyCookedOpt opts a, + "Committee normal:" <+> prettyCookedOpt opts b, + "Committee no confidence:" <+> prettyCookedOpt opts c, + "Update constitution:" <+> prettyCookedOpt opts d, + "Hard fork initialization:" <+> prettyCookedOpt opts e, + "Network group:" <+> prettyCookedOpt opts f, + "Economic group:" <+> prettyCookedOpt opts g, + "Technical group:" <+> prettyCookedOpt opts h, + "Governance group:" <+> prettyCookedOpt opts i, + "Treasury withdrawal:" <+> prettyCookedOpt opts j + ] +prettyTxParameterChange opts (CommitteeMinSize n) = "Committee min size:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (CommitteeMaxTermLength n) = "Committee max term length:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (GovActionLifetime n) = "Governance action life time:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (GovActionDeposit n) = "Governance action deposit:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (DRepRegistrationDeposit n) = "DRep registration deposit:" <+> prettyCookedOpt opts n +prettyTxParameterChange opts (DRepActivity n) = "DRep activity:" <+> prettyCookedOpt opts n + +prettyTxSkelProposal :: PrettyCookedOpts -> TxSkelProposal -> DocCooked +prettyTxSkelProposal opts TxSkelProposal {..} = + prettyItemizeNoTitle "-" $ + catMaybes + [ Just $ "Governance action:" <+> prettyTxSkelGovAction opts txSkelProposalAction, + Just $ "Return address:" <+> prettyCooked txSkelProposalAddress, + ( \(script, redeemer) -> + prettyItemize + "Witness:" + "-" + [ prettyCookedOpt opts script, + case redeemer of + TxSkelNoRedeemer -> "No redeemer" + TxSkelRedeemerForScript red -> "With the following redeemer:" <+> prettyCooked red + TxSkelRedeemerForReferenceScript red txOutRef -> + "With the following redeemer:" + <+> prettyCooked red + <+> "and reference script sitting at:" + <+> prettyCookedOpt opts txOutRef + ] + ) + <$> txSkelProposalWitness, + ("Anchor:" <+>) . PP.pretty <$> txSkelProposalAnchor + ] + +prettyTxSkelGovAction :: PrettyCookedOpts -> TxGovAction -> DocCooked +prettyTxSkelGovAction opts (TxGovActionParameterChange params) = prettyItemize "Parameter changes:" "-" $ prettyTxParameterChange opts <$> params +prettyTxSkelGovAction opts (TxGovActionHardForkInitiation (Api.ProtocolVersion major minor)) = + "Protocol version:" <+> "(" <+> prettyCookedOpt opts major <+> "," <+> prettyCookedOpt opts minor <+> ")" +prettyTxSkelGovAction opts (TxGovActionTreasuryWithdrawals withdrawals) = + prettyItemize "Withdrawals:" "-" $ + (\(cred, lv) -> prettyCookedOpt opts cred <+> "|" <+> prettyCooked (toValue lv)) <$> Map.toList withdrawals +prettyTxSkelGovAction _ TxGovActionNoConfidence = "No confidence" +prettyTxSkelGovAction opts (TxGovActionUpdateCommittee toRemoveCreds toAddCreds quorum) = + prettyItemize + "Updates in committee:" + "-" + [ prettyItemize "Credentials to remove:" "-" $ + (\(Api.ColdCommitteeCredential cred) -> prettyCookedOpt opts cred) <$> toRemoveCreds, + prettyItemize "Credentials to add:" "-" $ + (\(Api.ColdCommitteeCredential cred, i) -> prettyCookedOpt opts cred <+> "->" <+> prettyCookedOpt opts i) <$> Map.toList toAddCreds, + "Quorum:" <+> prettyCookedOpt opts (Api.toGHC quorum) + ] +prettyTxSkelGovAction opts (TxGovActionNewConstitution (Api.Constitution mScriptHash)) = case mScriptHash of + Nothing -> "Empty new constitution" + Just sHash -> "New constitution:" <+> prettyCookedOpt opts sHash + -- | Same as the 'PrettyCooked' instance for 'Wallet' with a suffix mentioning -- this is the balancing wallet prettyBalancingWallet :: PrettyCookedOpts -> Wallet -> DocCooked @@ -214,19 +334,28 @@ prettySigners _ _ [] = [] -- Examples without and with redeemer -- > #abcdef "Foo" -> 500 -- > #123456 "Bar" | Redeemer -> 1000 -prettyMints :: PrettyCookedOpts -> (Script.Versioned Script.MintingPolicy, MintsRedeemer, Api.TokenName, Integer) -> DocCooked -prettyMints opts (policy, NoMintsRedeemer, tokenName, amount) = +prettyMints :: PrettyCookedOpts -> (Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer) -> DocCooked +prettyMints opts (policy, TxSkelNoRedeemer, tokenName, amount) = prettyCookedOpt opts policy <+> PP.viaShow tokenName <+> "->" <+> PP.viaShow amount -prettyMints opts (policy, SomeMintsRedeemer redeemer, tokenName, amount) = +prettyMints opts (policy, TxSkelRedeemerForScript redeemer, tokenName, amount) = prettyCookedOpt opts policy <+> PP.viaShow tokenName <+> "|" <+> prettyCookedOpt opts redeemer <+> "->" <+> PP.viaShow amount +prettyMints opts (policy, TxSkelRedeemerForReferenceScript oref redeemer, tokenName, amount) = + prettyCookedOpt opts policy + <+> PP.viaShow tokenName + <+> "|" + <+> prettyCookedOpt opts redeemer + <+> " (with reference script at " + <+> prettyCookedOpt opts oref + <+> ") ->" + <+> PP.viaShow amount prettyTxSkelOut :: PrettyCookedOpts -> TxSkelOut -> DocCooked prettyTxSkelOut opts (Pays output) = @@ -273,12 +402,12 @@ prettyTxSkelIn opts skelContext (txOutRef, txSkelRedeemer) = do ( Just ("Redeemer:" <+> prettyCookedOpt opts redeemer), prettyCookedOpt opts (outputAddress output) ) - TxSkelRedeemerForReferencedScript refScriptOref redeemer -> + TxSkelRedeemerForReferenceScript refScriptOref redeemer -> ( Just ("Redeemer:" <+> prettyCookedOpt opts redeemer), prettyCookedOpt opts (outputAddress output) <+> PP.parens ("Reference Script at" <+> prettyCookedOpt opts refScriptOref) ) - TxSkelNoRedeemerForPK -> (Nothing, prettyCookedOpt opts (outputAddress output)) + TxSkelNoRedeemer -> (Nothing, prettyCookedOpt opts (outputAddress output)) in prettyItemize ("Spends from" <+> ownerDoc) "-" @@ -333,7 +462,8 @@ mPrettyTxOpts txOptBalancingPolicy, txOptBalancingUtxos, txOptEmulatorParamsModification, - txOptCollateralUtxos + txOptCollateralUtxos, + txOptAnchorResolution } = prettyItemizeNonEmpty "Options:" "-" $ catMaybes @@ -345,7 +475,8 @@ mPrettyTxOpts prettyIfNot def prettyBalancingUtxos txOptBalancingUtxos, prettyIfNot [] prettyUnsafeModTx txOptUnsafeModTx, prettyIfNot def prettyEmulatorParamsModification txOptEmulatorParamsModification, - prettyIfNot def prettyCollateralUtxos txOptCollateralUtxos + prettyIfNot def prettyCollateralUtxos txOptCollateralUtxos, + prettyIfNot def prettyAnchorResolution txOptAnchorResolution ] where prettyIfNot :: (Eq a) => a -> (a -> DocCooked) -> a -> Maybe DocCooked @@ -367,7 +498,7 @@ mPrettyTxOpts prettyBalancingPolicy DoNotBalance = "Do not balance" prettyUnsafeModTx :: [RawModTx] -> DocCooked prettyUnsafeModTx [] = "No transaction modifications" - prettyUnsafeModTx (length -> n) = PP.pretty n <+> "transaction" <+> PP.plural "modification" "modifications" n + prettyUnsafeModTx (length -> n) = prettyCookedOpt opts n <+> "transaction" <+> PP.plural "modification" "modifications" n prettyEmulatorParamsModification :: Maybe EmulatorParamsModification -> DocCooked prettyEmulatorParamsModification Nothing = "No modifications of protocol paramters" prettyEmulatorParamsModification Just {} = "With modifications of protocol parameters" @@ -389,9 +520,10 @@ mPrettyTxOpts prettyBalancingUtxos (BalancingUtxosFromSet utxos) = prettyItemize "Balance with the following utxos:" "-" (prettyCookedOpt opts <$> Set.toList utxos) prettyBalanceFeePolicy :: FeePolicy -> DocCooked prettyBalanceFeePolicy AutoFeeComputation = "Use automatically computed fee" - prettyBalanceFeePolicy (ManualFee fee) = "Use the following fee:" <+> PP.pretty fee - --- * Pretty-printing + prettyBalanceFeePolicy (ManualFee fee) = "Use the following fee:" <+> prettyCookedOpt opts fee + prettyAnchorResolution :: AnchorResolution -> DocCooked + prettyAnchorResolution AnchorResolutionHttp = "Resolve anchor url with an (unsafe) http connection" + prettyAnchorResolution (AnchorResolutionLocal urlMap) = prettyItemize "Resolve anchor url with the following table keys" "-" (PP.pretty <$> Map.keys urlMap) -- | Pretty print a 'UtxoState'. Print the known wallets first, then unknown -- pubkeys, then scripts. diff --git a/src/Cooked/Pretty/Hashable.hs b/src/Cooked/Pretty/Hashable.hs index ee2c69f70..7d84fcfb0 100644 --- a/src/Cooked/Pretty/Hashable.hs +++ b/src/Cooked/Pretty/Hashable.hs @@ -3,6 +3,7 @@ -- those elements. module Cooked.Pretty.Hashable where +import Cooked.Conversion import Cooked.Wallet import Plutus.Script.Utils.Scripts qualified as Script import Plutus.Script.Utils.Typed qualified as Script @@ -23,6 +24,9 @@ instance Hashable Wallet where instance Hashable (Script.Versioned Script.MintingPolicy) where toHash = Script.getMintingPolicyHash . Script.mintingPolicyHash +instance Hashable (Script.Versioned Script.Script) where + toHash = toHash . toScriptHash + instance Hashable Script.ScriptHash where toHash = Script.getScriptHash diff --git a/src/Cooked/ShowBS.hs b/src/Cooked/ShowBS.hs index 68e3e94dc..ba9b3ea9e 100644 --- a/src/Cooked/ShowBS.hs +++ b/src/Cooked/ShowBS.hs @@ -341,7 +341,7 @@ instance ShowBS Api.GovernanceAction where showBS (Api.NoConfidence maybeActionId) = application1 "NoConfidence" maybeActionId showBS (Api.UpdateCommittee maybeActionId toRemoveCreds toAddCreds quorum) = application4 "Info action" maybeActionId toRemoveCreds toAddCreds quorum showBS (Api.NewConstitution maybeActionId constitution) = application2 "NewConstitution" maybeActionId constitution - showBS Api.InfoAction = "InfoAction" -- + showBS Api.InfoAction = "InfoAction" instance ShowBS Api.ProposalProcedure where {-# INLINEABLE showBS #-} diff --git a/src/Cooked/Skeleton.hs b/src/Cooked/Skeleton.hs index 11f46c572..e14e77d47 100644 --- a/src/Cooked/Skeleton.hs +++ b/src/Cooked/Skeleton.hs @@ -17,6 +17,7 @@ module Cooked.Skeleton RawModTx (..), EmulatorParamsModification (..), CollateralUtxos (..), + AnchorResolution (..), applyEmulatorParamsModification, applyRawModOnBalancedTx, TxOpts (..), @@ -29,8 +30,7 @@ module Cooked.Skeleton txOptBalancingUtxosL, txOptEmulatorParamsModificationL, txOptCollateralUtxosL, - MintsConstrs, - MintsRedeemer (..), + txOptAnchorResolutionL, TxSkelMints, addToTxSkelMints, txSkelMintsToList, @@ -57,6 +57,14 @@ module Cooked.Skeleton withStakingCredential, TxSkelRedeemer (..), txSkelTypedRedeemer, + TxParameterChange (..), + TxGovAction (..), + TxSkelProposal (..), + txSkelProposalsL, + txSkelProposalAddressL, + txSkelProposalActionL, + txSkelProposalWitnessL, + txSkelProposalAnchorL, TxSkel (..), txSkelLabelL, txSkelOptsL, @@ -74,22 +82,23 @@ module Cooked.Skeleton SkelContext (..), txSkelReferenceScript, txSkelKnownTxOutRefs, + simpleTxSkelProposal, + withWitness, + withAnchor, txSkelValueInOutputs, txSkelReferenceScripts, + txSkelReferenceTxOutRefs, ) where import Cardano.Api qualified as Cardano import Cardano.Node.Emulator qualified as Emulator import Control.Monad -import Cooked.Conversion.ToCredential -import Cooked.Conversion.ToOutputDatum -import Cooked.Conversion.ToPubKeyHash -import Cooked.Conversion.ToScript -import Cooked.Conversion.ToScriptHash +import Cooked.Conversion import Cooked.Output import Cooked.Pretty.Class import Cooked.Wallet +import Data.ByteString (ByteString) import Data.Default import Data.Either.Combinators import Data.Function @@ -246,6 +255,19 @@ data CollateralUtxos instance Default CollateralUtxos where def = CollateralUtxosFromBalancingWallet +-- | Describes how to resolve anchors in proposal procedures +data AnchorResolution + = -- | Provide a map between urls and page content as Bytestring + AnchorResolutionLocal (Map String ByteString) + | -- | Allow online fetch of pages from a given URL. Important note: using + -- this option is unsafe, as it requires a web connection and inherently + -- prevents guarantees of reproducibily. Use at your own discretion. + AnchorResolutionHttp + deriving (Eq, Show) + +instance Default AnchorResolution where + def = AnchorResolutionLocal Map.empty + -- | Set of options to modify the behavior of generating and validating some -- transaction. data TxOpts = TxOpts @@ -319,7 +341,11 @@ data TxOpts = TxOpts -- computed automatically from a given, or the balancing, wallet. -- -- Default is 'CollateralUtxosFromBalancingWallet' - txOptCollateralUtxos :: CollateralUtxos + txOptCollateralUtxos :: CollateralUtxos, + -- | How to resolve anchor in proposal procedures + -- + -- Default is 'AnchorResolutionLocal Map.Empty' + txOptAnchorResolution :: AnchorResolution } deriving (Eq, Show) @@ -332,7 +358,8 @@ makeLensesFor ("txOptBalanceOutputPolicy", "txOptBalanceOutputPolicyL"), ("txOptBalancingUtxos", "txOptBalancingUtxosL"), ("txOptEmulatorParamsModification", "txOptEmulatorParamsModificationL"), - ("txOptCollateralUtxos", "txOptCollateralUtxosL") + ("txOptCollateralUtxos", "txOptCollateralUtxosL"), + ("txOptAnchorResolution", "txOptAnchorResolutionL") ] ''TxOpts @@ -347,52 +374,213 @@ instance Default TxOpts where txOptFeePolicy = def, txOptBalancingUtxos = def, txOptEmulatorParamsModification = Nothing, - txOptCollateralUtxos = def + txOptCollateralUtxos = def, + txOptAnchorResolution = def } --- * Description of the Minting +-- * Redeemers for transaction inputs -type MintsConstrs redeemer = +type RedeemerConstrs redeemer = ( Api.ToData redeemer, Show redeemer, PrettyCooked redeemer, + PlutusTx.Eq redeemer, Typeable redeemer ) --- | Which redeemer to use for minting. Note that using 'NoMintsRedeemer' --- corresponds to the redeemer @()@ on-chain. -data MintsRedeemer where - NoMintsRedeemer :: MintsRedeemer - SomeMintsRedeemer :: (MintsConstrs redeemer) => redeemer -> MintsRedeemer - -instance Show MintsRedeemer where - show NoMintsRedeemer = "NoMintsRedeemer" - show (SomeMintsRedeemer x) = "(SomeMintsRedeemer " ++ show x ++ ")" - -instance Eq MintsRedeemer where - a == b = compare a b == EQ - -instance Ord MintsRedeemer where - compare NoMintsRedeemer NoMintsRedeemer = EQ - compare NoMintsRedeemer SomeMintsRedeemer {} = LT - compare SomeMintsRedeemer {} NoMintsRedeemer = GT - compare (SomeMintsRedeemer a) (SomeMintsRedeemer b) = - case compare (SomeTypeRep $ typeOf a) (SomeTypeRep $ typeOf b) of - LT -> LT - GT -> GT - EQ -> case typeOf a `eqTypeRep` typeOf b of - Just HRefl -> compare (Api.toData a) (Api.toData b) - Nothing -> error "Type representations compare as EQ, but are not eqTypeRep" +data TxSkelRedeemer where + TxSkelNoRedeemer :: TxSkelRedeemer + TxSkelRedeemerForScript :: (RedeemerConstrs redeemer) => redeemer -> TxSkelRedeemer + -- | The first argument is a reference to the output where the reference + -- script is stored. + TxSkelRedeemerForReferenceScript :: (RedeemerConstrs redeemer) => Api.TxOutRef -> redeemer -> TxSkelRedeemer + +deriving instance (Show TxSkelRedeemer) + +txSkelTypedRedeemer :: (Api.FromData (Script.RedeemerType a)) => TxSkelRedeemer -> Maybe (Script.RedeemerType a) +txSkelTypedRedeemer (TxSkelRedeemerForScript redeemer) = Api.fromData . Api.toData $ redeemer +txSkelTypedRedeemer (TxSkelRedeemerForReferenceScript _ redeemer) = Api.fromData . Api.toData $ redeemer +txSkelTypedRedeemer _ = Nothing + +txSkelReferenceScript :: TxSkelRedeemer -> Maybe Api.TxOutRef +txSkelReferenceScript (TxSkelRedeemerForReferenceScript refScript _) = Just refScript +txSkelReferenceScript _ = Nothing + +instance Eq TxSkelRedeemer where + TxSkelNoRedeemer == TxSkelNoRedeemer = True + (TxSkelRedeemerForScript r1) == (TxSkelRedeemerForScript r2) = + case typeOf r1 `eqTypeRep` typeOf r2 of + Just HRefl -> r1 PlutusTx.== r2 + Nothing -> False + (TxSkelRedeemerForReferenceScript o1 r1) == (TxSkelRedeemerForReferenceScript o2 r2) = + TxSkelRedeemerForScript r1 == TxSkelRedeemerForScript r2 + && o1 == o2 + _ == _ = False + +-- * Description of the Governance actions (or proposal procedures) + +-- These are all the protocol parameters. They are taken from +-- https://github.com/IntersectMBO/cardano-ledger/blob/c4fbc05999866fea7c0cb1b211fd5288f286b95d/eras/conway/impl/cddl-files/conway.cddl#L381-L412 +-- and will most likely change in future eras. +data TxParameterChange where + -- | The linear factor for the minimum fee calculation + FeePerByte :: Integer -> TxParameterChange + -- | The constant factor for the minimum fee calculation + FeeFixed :: Integer -> TxParameterChange + -- | Maximal block body size + MaxBlockBodySize :: Integer -> TxParameterChange + -- | Maximal transaction size + MaxTxSize :: Integer -> TxParameterChange + -- | Maximal block header size + MaxBlockHeaderSize :: Integer -> TxParameterChange + -- | The amount of a key registration deposit + KeyDeposit :: Integer -> TxParameterChange + -- | The amount of a pool registration deposit + PoolDeposit :: Integer -> TxParameterChange + -- | Maximum number of epochs in the future a pool retirement is allowed to + -- be scheduled future for. + PoolRetirementMaxEpoch :: Integer -> TxParameterChange + -- | Desired number of pools + PoolNumber :: Integer -> TxParameterChange + -- | Pool influence + PoolInfluence :: Rational -> TxParameterChange + -- | Monetary expansion + MonetaryExpansion :: Rational -> TxParameterChange + -- | Treasury expansion + TreasuryCut :: Rational -> TxParameterChange + -- | Minimum Stake Pool Cost + MinPoolCost :: Integer -> TxParameterChange + -- | Cost in lovelace per byte of UTxO storage + CoinsPerUTxOByte :: Integer -> TxParameterChange + -- | Cost models for non-native script languages + CostModels :: + { cmPlutusV1Costs :: [Integer], + cmPlutusV2Costs :: [Integer], + cmPlutusV3Costs :: [Integer] + } -> + TxParameterChange + -- | Prices of execution units + Prices :: + { pMemoryCost :: Rational, + pStepCost :: Rational + } -> + TxParameterChange + -- | Max total script execution resources units allowed per tx + MaxTxExUnits :: + { mteuMemory :: Integer, + mteuSteps :: Integer + } -> + TxParameterChange + -- | Max total script execution resources units allowed per block + MaxBlockExUnits :: + { mbeuMemory :: Integer, + mbeuSteps :: Integer + } -> + TxParameterChange + -- | Max size of a Value in an output + MaxValSize :: Integer -> TxParameterChange + -- | Percentage of the txfee which must be provided as collateral when + -- including non-native scripts. + CollateralPercentage :: Integer -> TxParameterChange + -- | Maximum number of collateral inputs allowed in a transaction + MaxCollateralInputs :: Integer -> TxParameterChange + -- | Thresholds for pool votes + PoolVotingThresholds :: + { pvtMotionNoConfidence :: Rational, + pvtCommitteeNormal :: Rational, + pvtCommitteeNoConfidence :: Rational, + pvtHardFork :: Rational, + pvtSecurityGroup :: Rational + } -> + TxParameterChange + -- | Thresholds for DRep votes + DRepVotingThresholds :: + { drvtMotionNoConfidence :: Rational, + drvtCommitteeNormal :: Rational, + drvtCommitteeNoConfidence :: Rational, + drvtUpdateConstitution :: Rational, + drvtHardForkInitialization :: Rational, + drvtNetworkGroup :: Rational, + drvtEconomicGroup :: Rational, + drvtTechnicalGroup :: Rational, + drvtGovernanceGroup :: Rational, + drvtTreasuryWithdrawal :: Rational + } -> + TxParameterChange + -- | Minimum size of the Constitutional Committee + CommitteeMinSize :: Integer -> TxParameterChange + -- | The Constitutional Committee Term limit in number of Slots + CommitteeMaxTermLength :: Integer -> TxParameterChange + -- | Gov action lifetime in number of Epochs + GovActionLifetime :: Integer -> TxParameterChange + -- | The amount of the Gov Action deposit + GovActionDeposit :: Integer -> TxParameterChange + -- | The amount of a DRep registration deposit + DRepRegistrationDeposit :: Integer -> TxParameterChange + -- | The number of Epochs that a DRep can perform no activity without losing + -- their @Active@ status. + DRepActivity :: Integer -> TxParameterChange + -- Reference scripts fee for the minimum fee calculation + -- will exist later on MinFeeRefScriptCostPerByte :: Integer -> TxParameterChange + deriving (Show, Eq) + +data TxGovAction where + -- If several parameter changes are of the same kind, only the last + -- one will take effect + TxGovActionParameterChange :: [TxParameterChange] -> TxGovAction + TxGovActionHardForkInitiation :: Api.ProtocolVersion -> TxGovAction + TxGovActionTreasuryWithdrawals :: Map Api.Credential Api.Lovelace -> TxGovAction + TxGovActionNoConfidence :: TxGovAction + TxGovActionUpdateCommittee :: [Api.ColdCommitteeCredential] -> Map Api.ColdCommitteeCredential Integer -> PlutusTx.Rational -> TxGovAction + TxGovActionNewConstitution :: Api.Constitution -> TxGovAction + deriving (Show, Eq) + +data TxSkelProposal where + TxSkelProposal :: + { -- | Whatever credential will get back the deposit + txSkelProposalAddress :: Api.Address, + -- | The proposed action + txSkelProposalAction :: TxGovAction, + -- | An optional script (typically the constitution script) to witness the + -- proposal and validate it. Only parameter changes and treasury + -- withdrawals can be subject to such a validation and transactions will + -- not pass validation phase 1 if other actions are given a witness. + txSkelProposalWitness :: Maybe (Script.Versioned Script.Script, TxSkelRedeemer), + -- | An optional anchor to be given as additional data. It should + -- correspond to the URL of a web page + txSkelProposalAnchor :: Maybe String + } -> + TxSkelProposal + deriving (Show, Eq) + +makeLensesFor + [ ("txSkelProposalAddress", "txSkelProposalAddressL"), + ("txSkelProposalAction", "txSkelProposalActionL"), + ("txSkelProposalWitness", "txSkelProposalWitnessL"), + ("txSkelProposalAnchor", "txSkelProposalAnchorL") + ] + ''TxSkelProposal + +simpleTxSkelProposal :: (ToAddress a) => a -> TxGovAction -> TxSkelProposal +simpleTxSkelProposal a govAction = TxSkelProposal (toAddress a) govAction Nothing Nothing + +withWitness :: (ToScript a) => TxSkelProposal -> (a, TxSkelRedeemer) -> TxSkelProposal +withWitness prop (s, red) = prop {txSkelProposalWitness = Just (toScript s, red)} + +withAnchor :: TxSkelProposal -> String -> TxSkelProposal +withAnchor prop url = prop {txSkelProposalAnchor = Just url} + +-- * Description of the Minting -- | A description of what a transaction mints. For every policy, there can only --- be one 'MintsRedeemer', and if there is, there must be some token names, each +-- be one 'TxSkelRedeemer', and if there is, there must be some token names, each -- with a non-zero amount of tokens. -- -- You'll probably not construct this by hand, but use 'txSkelMintsFromList'. type TxSkelMints = Map (Script.Versioned Script.MintingPolicy) - (MintsRedeemer, NEMap Api.TokenName (NonZero Integer)) + (TxSkelRedeemer, NEMap Api.TokenName (NonZero Integer)) -- | Combining 'TxSkelMints' in a sensible way. In particular, this means that -- @@ -444,7 +632,7 @@ instance {-# OVERLAPPING #-} Monoid TxSkelMints where -- redeemer per minting policy, and no conflicting mints of the same asset -- class, since they'll just cancel. addToTxSkelMints :: - (Script.Versioned Script.MintingPolicy, MintsRedeemer, Api.TokenName, Integer) -> + (Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer) -> TxSkelMints -> TxSkelMints addToTxSkelMints (pol, red, tName, amount) mints @@ -479,7 +667,7 @@ addToTxSkelMints (pol, red, tName, amount) mints -- | Convert from 'TxSkelMints' to a list of tuples describing eveything that's -- being minted. -txSkelMintsToList :: TxSkelMints -> [(Script.Versioned Script.MintingPolicy, MintsRedeemer, Api.TokenName, Integer)] +txSkelMintsToList :: TxSkelMints -> [(Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer)] txSkelMintsToList = concatMap ( \(p, (r, m)) -> @@ -492,7 +680,7 @@ txSkelMintsToList = -- 'addToTxSkelMints'. So, some non-empty lists (where all amounts for a given -- asset class an redeemer add up to zero) might be translated into the empty -- 'TxSkelMints'. -txSkelMintsFromList :: [(Script.Versioned Script.MintingPolicy, MintsRedeemer, Api.TokenName, Integer)] -> TxSkelMints +txSkelMintsFromList :: [(Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer)] -> TxSkelMints txSkelMintsFromList = foldr addToTxSkelMints mempty -- | The value described by a 'TxSkelMints' @@ -780,45 +968,6 @@ withReferenceScript (Pays output) script = Pays $ (fromAbstractOutput output) {c withStakingCredential :: TxSkelOut -> Api.StakingCredential -> TxSkelOut withStakingCredential (Pays output) stakingCredential = Pays $ (fromAbstractOutput output) {concreteOutputStakingCredential = Just stakingCredential} --- * Redeemers for transaction inputs - -type SpendsScriptConstrs redeemer = - ( Api.ToData redeemer, - Show redeemer, - PrettyCooked redeemer, - PlutusTx.Eq redeemer, - Typeable redeemer - ) - -data TxSkelRedeemer where - TxSkelNoRedeemerForPK :: TxSkelRedeemer - TxSkelRedeemerForScript :: (SpendsScriptConstrs redeemer) => redeemer -> TxSkelRedeemer - -- | The first argument is a reference to the output where the referenced - -- script is stored. - TxSkelRedeemerForReferencedScript :: (SpendsScriptConstrs redeemer) => Api.TxOutRef -> redeemer -> TxSkelRedeemer - -txSkelTypedRedeemer :: (Api.FromData (Script.RedeemerType a)) => TxSkelRedeemer -> Maybe (Script.RedeemerType a) -txSkelTypedRedeemer (TxSkelRedeemerForScript redeemer) = Api.fromData . Api.toData $ redeemer -txSkelTypedRedeemer (TxSkelRedeemerForReferencedScript _ redeemer) = Api.fromData . Api.toData $ redeemer -txSkelTypedRedeemer _ = Nothing - -txSkelReferenceScript :: TxSkelRedeemer -> Maybe Api.TxOutRef -txSkelReferenceScript (TxSkelRedeemerForReferencedScript refScript _) = Just refScript -txSkelReferenceScript _ = Nothing - -deriving instance (Show TxSkelRedeemer) - -instance Eq TxSkelRedeemer where - TxSkelNoRedeemerForPK == TxSkelNoRedeemerForPK = True - (TxSkelRedeemerForScript r1) == (TxSkelRedeemerForScript r2) = - case typeOf r1 `eqTypeRep` typeOf r2 of - Just HRefl -> r1 PlutusTx.== r2 - Nothing -> False - (TxSkelRedeemerForReferencedScript o1 r1) == (TxSkelRedeemerForReferencedScript o2 r2) = - TxSkelRedeemerForScript r1 == TxSkelRedeemerForScript r2 - && o1 == o2 - _ == _ = False - -- * Transaction skeletons data TxSkel where @@ -841,7 +990,7 @@ data TxSkel where -- specifying how to spend it. You must make sure that -- -- - On 'TxOutRef's referencing UTxOs belonging to public keys, you use - -- the 'TxSkelNoRedeemerForPK' constructor. + -- the 'TxSkelNoRedeemer' constructor. -- -- - On 'TxOutRef's referencing UTxOs belonging to scripts, you must make -- sure that the type of the redeemer is appropriate for the script. @@ -850,7 +999,9 @@ data TxSkel where txSkelInsReference :: Set Api.TxOutRef, -- | The outputs of the transaction. These will occur in exactly this -- order on the transaction. - txSkelOuts :: [TxSkelOut] + txSkelOuts :: [TxSkelOut], + -- | Possible proposals issued in this transaction to be voted on and possible enacted later on. + txSkelProposals :: [TxSkelProposal] } -> TxSkel deriving (Show, Eq) @@ -863,7 +1014,8 @@ makeLensesFor ("txSkelSigners", "txSkelSignersL"), ("txSkelIns", "txSkelInsL"), ("txSkelInsReference", "txSkelInsReferenceL"), - ("txSkelOuts", "txSkelOutsL") + ("txSkelOuts", "txSkelOutsL"), + ("txSkelProposals", "txSkelProposalsL") ] ''TxSkel @@ -878,7 +1030,8 @@ txSkelTemplate = txSkelSigners = [], txSkelIns = Map.empty, txSkelInsReference = Set.empty, - txSkelOuts = [] + txSkelOuts = [], + txSkelProposals = [] } -- | The missing information on a 'TxSkel' that can only be resolved by querying @@ -929,16 +1082,17 @@ txSkelReferenceScripts = ) . txSkelOuts +-- | All `TxOutRefs` in reference inputs +txSkelReferenceTxOutRefs :: TxSkel -> [Api.TxOutRef] +txSkelReferenceTxOutRefs TxSkel {..} = mapMaybe txSkelReferenceScript (Map.elems txSkelIns) <> Set.toList txSkelInsReference + -- | All `TxOutRefs` known by a given transaction skeleton. This includes -- TxOutRef`s used as inputs of the skeleton and `TxOutRef`s used as reference -- inputs of the skeleton. This does not include additional possible -- `TxOutRef`s used for balancing and additional `TxOutRef`s used as collateral -- inputs, as they are not part of the skeleton. txSkelKnownTxOutRefs :: TxSkel -> [Api.TxOutRef] -txSkelKnownTxOutRefs TxSkel {..} = - Map.keys txSkelIns - <> mapMaybe txSkelReferenceScript (Map.elems txSkelIns) - <> Set.toList txSkelInsReference +txSkelKnownTxOutRefs skel@TxSkel {..} = txSkelReferenceTxOutRefs skel <> Map.keys txSkelIns -- * Various Optics on 'TxSkels' and all the other types defined here diff --git a/src/Cooked/Tweak/AddInputsAndOutputs.hs b/src/Cooked/Tweak/AddInputsAndOutputs.hs index 55dc409cf..989882e56 100644 --- a/src/Cooked/Tweak/AddInputsAndOutputs.hs +++ b/src/Cooked/Tweak/AddInputsAndOutputs.hs @@ -84,15 +84,15 @@ removeOutputTweak removePred = do -- | Add a new entry to the 'TxSkelMints' of the transaction skeleton under -- modification. As this is implemented in terms of 'addToTxSkelMints', the same -- caveats apply as do to that function! -addMintTweak :: (MonadTweak m) => (Script.Versioned Script.MintingPolicy, MintsRedeemer, Api.TokenName, Integer) -> m () +addMintTweak :: (MonadTweak m) => (Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer) -> m () addMintTweak mint = overTweak txSkelMintsL $ addToTxSkelMints mint -- | Remove some entries from the 'TxSkelMints' of a transaction, according to -- some predicate. The returned list holds the removed entries. removeMintTweak :: (MonadTweak m) => - ((Script.Versioned Script.MintingPolicy, MintsRedeemer, Api.TokenName, Integer) -> Bool) -> - m [(Script.Versioned Script.MintingPolicy, MintsRedeemer, Api.TokenName, Integer)] + ((Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer) -> Bool) -> + m [(Script.Versioned Script.MintingPolicy, TxSkelRedeemer, Api.TokenName, Integer)] removeMintTweak removePred = do presentMints <- viewTweak $ txSkelMintsL % to txSkelMintsToList let (removed, kept) = partition removePred presentMints diff --git a/src/Cooked/Validators.hs b/src/Cooked/Validators.hs index 7d277d6e4..b99ad1423 100644 --- a/src/Cooked/Validators.hs +++ b/src/Cooked/Validators.hs @@ -4,6 +4,9 @@ module Cooked.Validators ( alwaysTrueValidator, alwaysFalseValidator, + alwaysFalseProposingValidator, + alwaysTrueProposingValidator, + mkProposingScript, MockContract, ) where @@ -12,6 +15,8 @@ import Plutus.Script.Utils.Scripts qualified as Script import Plutus.Script.Utils.Typed qualified as Script hiding (validatorHash) import Plutus.Script.Utils.V3.Generators qualified as Script import Plutus.Script.Utils.V3.Typed.Scripts.MonetaryPolicies qualified as Script +import PlutusLedgerApi.V3 qualified as Api +import PlutusTx.Code qualified as PlutusTx import PlutusTx.Prelude qualified as PlutusTx import PlutusTx.TH qualified as PlutusTx @@ -45,3 +50,18 @@ data MockContract instance Script.ValidatorTypes MockContract where type RedeemerType MockContract = () type DatumType MockContract = () + +-- | A dummy false proposing validator +alwaysFalseProposingValidator :: Script.Versioned Script.Script +alwaysFalseProposingValidator = + mkProposingScript $$(PlutusTx.compile [||PlutusTx.traceError "False proposing validator"||]) + +-- | A dummy true proposing validator +alwaysTrueProposingValidator :: Script.Versioned Script.Script +alwaysTrueProposingValidator = + mkProposingScript $$(PlutusTx.compile [||\_ _ -> ()||]) + +-- | Helper to build a proposing script. This should come from +-- plutus-script-utils at some point. +mkProposingScript :: PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> Script.Versioned Script.Script +mkProposingScript code = Script.Versioned (Script.Script $ Api.serialiseCompiledCode code) Script.PlutusV3 diff --git a/tests/Cooked/Attack/DatumHijackingSpec.hs b/tests/Cooked/Attack/DatumHijackingSpec.hs index 272690696..5dab090b7 100644 --- a/tests/Cooked/Attack/DatumHijackingSpec.hs +++ b/tests/Cooked/Attack/DatumHijackingSpec.hs @@ -56,7 +56,7 @@ lockTxSkel :: Api.TxOutRef -> Script.TypedValidator DHContract -> TxSkel lockTxSkel o v = txSkelTemplate { txSkelOpts = def {txOptEnsureMinAda = True}, - txSkelIns = Map.singleton o TxSkelNoRedeemerForPK, + txSkelIns = Map.singleton o TxSkelNoRedeemer, txSkelOuts = [paysScriptInlineDatum v FirstLock lockValue], txSkelSigners = [wallet 1] } diff --git a/tests/Cooked/Attack/DupTokenSpec.hs b/tests/Cooked/Attack/DupTokenSpec.hs index 73ecc55bb..684432b2d 100644 --- a/tests/Cooked/Attack/DupTokenSpec.hs +++ b/tests/Cooked/Attack/DupTokenSpec.hs @@ -49,7 +49,7 @@ dupTokenTrace :: (MonadBlockChain m) => Script.Versioned Script.MintingPolicy -> dupTokenTrace pol tName amount recipient = void $ validateTxSkel skel where skel = - let mints = txSkelMintsFromList [(pol, NoMintsRedeemer, tName, amount)] + let mints = txSkelMintsFromList [(pol, TxSkelNoRedeemer, tName, amount)] mintedValue = txSkelMintsValue mints in txSkelTemplate { txSkelOpts = def {txOptEnsureMinAda = True}, @@ -74,8 +74,8 @@ tests = txSkelTemplate { txSkelMints = txSkelMintsFromList - [ (pol1, NoMintsRedeemer, tName1, 5), - (pol2, NoMintsRedeemer, tName2, 7) + [ (pol1, TxSkelNoRedeemer, tName1, 5), + (pol2, TxSkelNoRedeemer, tName2, 7) ], txSkelOuts = [ paysPK (wallet 1) (Script.assetClassValue ac1 1 <> Script.lovelaceValueOf 1234), @@ -92,8 +92,8 @@ tests = { txSkelLabel = Set.singleton $ TxLabel DupTokenLbl, txSkelMints = txSkelMintsFromList - [ (pol1, NoMintsRedeemer, tName1, v1), - (pol2, NoMintsRedeemer, tName2, v2) + [ (pol1, TxSkelNoRedeemer, tName1, v1), + (pol2, TxSkelNoRedeemer, tName2, v2) ], txSkelOuts = [ paysPK (wallet 1) (Script.assetClassValue ac1 1 <> Script.lovelaceValueOf 1234), @@ -136,7 +136,7 @@ tests = ac2 = quickAssetClass "preExistingToken" skelIn = txSkelTemplate - { txSkelMints = txSkelMintsFromList [(pol, NoMintsRedeemer, tName1, 1)], + { txSkelMints = txSkelMintsFromList [(pol, TxSkelNoRedeemer, tName1, 1)], txSkelOuts = [paysPK (wallet 1) (Script.assetClassValue ac1 1 <> Script.assetClassValue ac2 2)], txSkelSigners = [wallet 2] } @@ -145,7 +145,7 @@ tests = ( Script.assetClassValue ac1 1, txSkelTemplate { txSkelLabel = Set.singleton $ TxLabel DupTokenLbl, - txSkelMints = txSkelMintsFromList [(pol, NoMintsRedeemer, tName1, 2)], + txSkelMints = txSkelMintsFromList [(pol, TxSkelNoRedeemer, tName1, 2)], txSkelOuts = [ paysPK (wallet 1) (Script.assetClassValue ac1 1 <> Script.assetClassValue ac2 2), paysPK attacker (Script.assetClassValue ac1 1) diff --git a/tests/Cooked/BalancingSpec.hs b/tests/Cooked/BalancingSpec.hs index 118e59d43..7942a4796 100644 --- a/tests/Cooked/BalancingSpec.hs +++ b/tests/Cooked/BalancingSpec.hs @@ -66,7 +66,7 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla let skel = txSkelTemplate { txSkelOuts = List.filter ((/= mempty) . (^. txSkelOutValueL)) [paysPK bob toBobValue, paysPK alice toAliceValue], - txSkelIns = Map.fromList $ (,TxSkelNoRedeemerForPK) <$> toSpendUtxos, + txSkelIns = Map.fromList $ (,TxSkelNoRedeemer) <$> toSpendUtxos, txSkelOpts = optionsMod def @@ -124,7 +124,7 @@ noBalanceMaxFee = do validateTxSkel $ txSkelTemplate { txSkelOuts = [paysPK bob (lovelace (30_000_000 - maxFee))], - txSkelIns = Map.singleton txOutRef TxSkelNoRedeemerForPK, + txSkelIns = Map.singleton txOutRef TxSkelNoRedeemer, txSkelOpts = def { txOptBalancingPolicy = DoNotBalance, diff --git a/tests/Cooked/BasicUsageSpec.hs b/tests/Cooked/BasicUsageSpec.hs index edb88b292..1a0bfe720 100644 --- a/tests/Cooked/BasicUsageSpec.hs +++ b/tests/Cooked/BasicUsageSpec.hs @@ -35,7 +35,7 @@ mintingQuickValue = void $ validateTxSkel $ txSkelTemplate - { txSkelMints = txSkelMintsFromList [(Script.Versioned quickCurrencyPolicy Script.PlutusV3, NoMintsRedeemer, "banana", 10)], + { txSkelMints = txSkelMintsFromList [(Script.Versioned quickCurrencyPolicy Script.PlutusV3, TxSkelNoRedeemer, "banana", 10)], txSkelOuts = [paysPK alice (quickValue "banana" 10)], txSkelSigners = [alice], txSkelOpts = def {txOptEnsureMinAda = True} diff --git a/tests/Cooked/InitialDistributionSpec.hs b/tests/Cooked/InitialDistributionSpec.hs index ae2c3fc1d..234a3e128 100644 --- a/tests/Cooked/InitialDistributionSpec.hs +++ b/tests/Cooked/InitialDistributionSpec.hs @@ -44,7 +44,7 @@ spendReferenceAlwaysTrueValidator = do validateTxSkel $ txSkelTemplate { txSkelOuts = [paysPK alice (ada 2)], - txSkelIns = Map.singleton scriptTxOutRef (TxSkelRedeemerForReferencedScript referenceScriptTxOutRef ()), + txSkelIns = Map.singleton scriptTxOutRef (TxSkelRedeemerForReferenceScript referenceScriptTxOutRef ()), txSkelSigners = [bob] } diff --git a/tests/Cooked/ProposingScriptSpec.hs b/tests/Cooked/ProposingScriptSpec.hs new file mode 100644 index 000000000..8fa8c703b --- /dev/null +++ b/tests/Cooked/ProposingScriptSpec.hs @@ -0,0 +1,58 @@ +module Cooked.ProposingScriptSpec where + +import Control.Monad +import Cooked +import Data.Default +import Data.Map qualified as Map +import Ledger.Index qualified as Ledger +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V3 qualified as Api +import PlutusTx.AssocMap qualified as PlutusTx +import PlutusTx.Builtins qualified as PlutusTx hiding (head) +import PlutusTx.Eq qualified as PlutusTx +import PlutusTx.IsData qualified as PlutusTx +import PlutusTx.List qualified as PlutusTx +import PlutusTx.TH qualified as PlutusTx +import PlutusTx.Trace qualified as PlutusTx +import Test.Tasty +import Test.Tasty.HUnit + +checkParameterChangeScript :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> () +checkParameterChangeScript _ ctx = + let scriptContext = PlutusTx.unsafeFromBuiltinData @Api.ScriptContext ctx + proposalProcedure = PlutusTx.head $ Api.txInfoProposalProcedures $ Api.scriptContextTxInfo scriptContext + in case Api.ppGovernanceAction proposalProcedure of + Api.ParameterChange _ (Api.ChangedParameters dat) _ -> + let innerMap = PlutusTx.unsafeFromBuiltinData @(PlutusTx.Map PlutusTx.Integer PlutusTx.Integer) dat + in if innerMap PlutusTx.== PlutusTx.fromList [(0, 100)] then () else PlutusTx.traceError "wrong map" + _ -> PlutusTx.traceError "Wrong proposal procedure" + +checkProposingScript :: Script.Versioned Script.Script +checkProposingScript = mkProposingScript $$(PlutusTx.compile [||checkParameterChangeScript||]) + +testProposingScript :: (MonadBlockChain m) => Script.Versioned Script.Script -> TxGovAction -> m () +testProposingScript script govAction = + void $ + validateTxSkel + txSkelTemplate + { txSkelSigners = [wallet 1], + txSkelProposals = [simpleTxSkelProposal (wallet 1) govAction `withWitness` (script, TxSkelNoRedeemer)] + } + +tests :: TestTree +tests = + testGroup + "Proposing scripts" + [ testCase "The always True proposing script succeeds" $ + testSucceeds def $ + testProposingScript alwaysTrueProposingValidator (TxGovActionTreasuryWithdrawals Map.empty), + testCase "The always False proposing script fails" $ + testFails def (isCekEvaluationFailure def) $ + testProposingScript alwaysFalseProposingValidator (TxGovActionTreasuryWithdrawals Map.empty), + testCase "A more advanced proposing script can succeed" $ + testSucceeds def $ + testProposingScript checkProposingScript (TxGovActionParameterChange [FeePerByte 100]), + testCase "Proposing scripts are restricted to parameter changes or treasury withdrawals" $ + testFails def (\case (MCEValidationError Ledger.Phase1 _) -> testBool True; _ -> testBool False) $ + testProposingScript alwaysFalseProposingValidator TxGovActionNoConfidence + ] diff --git a/tests/Cooked/ReferenceScriptsSpec.hs b/tests/Cooked/ReferenceScriptsSpec.hs index 73db5ecfc..675654c41 100644 --- a/tests/Cooked/ReferenceScriptsSpec.hs +++ b/tests/Cooked/ReferenceScriptsSpec.hs @@ -58,12 +58,12 @@ putRefScriptOnWalletOutput :: Wallet -> Script.TypedValidator MockContract -> m Api.TxOutRef -putRefScriptOnWalletOutput recipient referencedScript = +putRefScriptOnWalletOutput recipient referenceScript = head <$> validateTxSkel' txSkelTemplate { txSkelOpts = def {txOptEnsureMinAda = True}, - txSkelOuts = [paysPK recipient (Script.lovelaceValueOf 1) `withReferenceScript` referencedScript], + txSkelOuts = [paysPK recipient (Script.lovelaceValueOf 1) `withReferenceScript` referenceScript], txSkelSigners = [wallet 1] } @@ -72,12 +72,12 @@ putRefScriptOnScriptOutput :: Script.TypedValidator MockContract -> Script.TypedValidator MockContract -> m Api.TxOutRef -putRefScriptOnScriptOutput recipient referencedScript = +putRefScriptOnScriptOutput recipient referenceScript = head <$> validateTxSkel' txSkelTemplate { txSkelOpts = def {txOptEnsureMinAda = True}, - txSkelOuts = [paysScript recipient () (Script.lovelaceValueOf 1) `withReferenceScript` referencedScript], + txSkelOuts = [paysScript recipient () (Script.lovelaceValueOf 1) `withReferenceScript` referenceScript], txSkelSigners = [wallet 1] } @@ -116,7 +116,7 @@ useReferenceScript spendingSubmitter theScript = do void $ validateTxSkel txSkelTemplate - { txSkelIns = Map.singleton oref $ TxSkelRedeemerForReferencedScript scriptOref (), + { txSkelIns = Map.singleton oref $ TxSkelRedeemerForReferenceScript scriptOref (), txSkelSigners = [spendingSubmitter] } @@ -124,7 +124,7 @@ tests :: TestTree tests = testGroup "Reference scripts" - [ testGroup "putting reference scripts on chain and retreiving them" $ + [ testGroup "putting reference scripts on chain and retrieving them" $ let theRefScript = alwaysFalseValidator theRefScriptHash = toScriptHash theRefScript in [ testCase "on a public key output" @@ -194,38 +194,37 @@ tests = validateTxSkel' txSkelTemplate { txSkelOuts = [paysScript (alwaysTrueValidator @MockContract) () (ada 42)], - txSkelIns = Map.singleton consumedOref TxSkelNoRedeemerForPK, + txSkelIns = Map.singleton consumedOref TxSkelNoRedeemer, txSkelSigners = [wallet 1] } void $ validateTxSkel txSkelTemplate - { txSkelIns = Map.singleton oref (TxSkelRedeemerForReferencedScript consumedOref ()), + { txSkelIns = Map.singleton oref (TxSkelRedeemerForReferenceScript consumedOref ()), + txSkelSigners = [wallet 1] + }, + testCase "fail from transaction generation for mismatching reference scripts" + $ testFailsFrom + def + ( \case + MCEGenerationError err -> err .==. GenerateTxErrorGeneral "toScriptAndRedeemerData: Wrong reference script hash." + _ -> testFailure + ) + def + $ do + scriptOref <- putRefScriptOnWalletOutput (wallet 3) alwaysFalseValidator + oref : _ <- + validateTxSkel' + txSkelTemplate + { txSkelOuts = [paysScript (alwaysTrueValidator @MockContract) () (ada 42)], + txSkelSigners = [wallet 1] + } + void $ + validateTxSkel + txSkelTemplate + { txSkelIns = Map.singleton oref (TxSkelRedeemerForReferenceScript scriptOref ()), txSkelSigners = [wallet 1] }, - testCase "fail from transaction generation for mismatching reference scripts" $ - let expectedError = GenerateTxErrorGeneral "txSkelRedeemerToWitness: Wrong reference script hash. Are you using the correct TxOutRef on your TxSkelRedeemerForReferencedScript?" - in testFailsFrom - def - ( \case - MCEGenerationError err -> err .==. expectedError - _ -> testFailure - ) - def - $ do - scriptOref <- putRefScriptOnWalletOutput (wallet 3) alwaysFalseValidator - oref : _ <- - validateTxSkel' - txSkelTemplate - { txSkelOuts = [paysScript (alwaysTrueValidator @MockContract) () (ada 42)], - txSkelSigners = [wallet 1] - } - void $ - validateTxSkel - txSkelTemplate - { txSkelIns = Map.singleton oref (TxSkelRedeemerForReferencedScript scriptOref ()), - txSkelSigners = [wallet 1] - }, testCase "phase 1 - fail if using a reference script with 'TxSkelRedeemerForScript'" $ testFailsFrom def @@ -250,7 +249,7 @@ tests = txSkelSigners = [wallet 1] }, testCase - "fail if referenced script's requirement is violated" + "fail if reference script's requirement is violated" $ testFailsFrom (def {pcOptPrintTxHashes = True}) ( isCekEvaluationFailureWithMsg @@ -259,7 +258,7 @@ tests = ) def $ useReferenceScript (wallet 1) (requireSignerValidator $ walletPKHash $ wallet 2), - testCase "succeed if referenced script's requirement is met" $ + testCase "succeed if reference script's requirement is met" $ testSucceeds def $ useReferenceScript (wallet 1) (requireSignerValidator $ walletPKHash $ wallet 1) ] diff --git a/tests/Spec.hs b/tests/Spec.hs index 07ee53183..ec6566fc7 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,11 +1,12 @@ import Cooked.AttackSpec qualified as AttackSpec import Cooked.BalancingSpec qualified as BalancingSpec import Cooked.BasicUsageSpec qualified as BasicUsageSpec -import Cooked.InitialDistributionSpec qualified as InitDistrib +import Cooked.InitialDistributionSpec qualified as InitDistribSpec import Cooked.InlineDatumsSpec qualified as InlineDatumsSpec import Cooked.LtlSpec qualified as LtlSpec import Cooked.MinAdaSpec qualified as MinAdaSpec import Cooked.MockChainSpec qualified as MockChainSpec +import Cooked.ProposingScriptSpec qualified as ProposingSpec import Cooked.ReferenceInputsSpec qualified as ReferenceInputsSpec import Cooked.ReferenceScriptsSpec qualified as ReferenceScriptsSpec import Cooked.ShowBSSpec qualified as ShowBSSpec @@ -28,5 +29,6 @@ main = LtlSpec.tests, MockChainSpec.tests, ShowBSSpec.tests, - InitDistrib.tests + InitDistribSpec.tests, + ProposingSpec.tests ]