diff --git a/CHANGELOG.md b/CHANGELOG.md index a2af250cf..cb5ad7308 100644 Binary files a/CHANGELOG.md and b/CHANGELOG.md differ diff --git a/README.md b/README.md index c11a57508..8d861363b 100644 --- a/README.md +++ b/README.md @@ -1,58 +1,46 @@ # [Cooked Validators](https://github.com/tweag/cooked-validators/) -Copyright Tweag I/O 2026 - -`cooked-validators` is a Haskell library for writing reliable, concise, and -expressive off-chain code for Cardano smart contracts, with a primary focus on -testing, auditing, and behavioral exploration. - -It allows you to describe transactions at a high level (via what we call -transaction skeletons) and automatically turn them into complete, valid -transactions by handling all mechanical aspects such UTxO selection, balancing, -minimum-Ada constraints, collaterals or fees. - -The library is designed to: -- drastically reduce off-chain boilerplate, -- make test scenarios more readable and maintainable, -- facilitate adversarial testing and vulnerability discovery. - -Importantly, `cooked-validators` is non-opinionated: everything it automates can -also be done manually if needed, allowing users to retain full control over -transaction construction when desired. - -## Core features - -With `cooked-validators`, you can: -- Interact with smart contracts written in Plutus or any language that compiles -to [UPLC](https://plutonomicon.github.io/plutonomicon/uplc), such as -[Plutarch](https://github.com/Plutonomicon/plutarch-plutus) or -[Aiken](https://aiken-lang.org/), by loading contracts from bytestrings. -- Define transactions using a high-level, type-preserving data structure. -- Submit transactions for validation while the library automatically: - * fills in missing inputs and outputs, - * performs balancing, - * enforces minimum-Ada constraints, - * computes and attaches optimal collaterals and fees, - * automatically adds script witnesses, including from reference inputs. -- Construct sequences of transactions in a clear, implementation-independent - abstraction of the blockchain. -- Run transaction sequences in an emulated blockchain. -- Define modifications aware of the current blockchain state (tweaks), and apply - them to transactions just before submission. -- Compose and deploy tweaks on sequences of transactions using idioms inspired - by linear temporal logic. -- Deploy automated attacks on existing transaction sequences, such as datum - hijacking or double satisfaction attacks, to uncover vulnerabilities. -- Express expected outcomes on the result of running a trace in a precise and - declarative way, for example by: - * specifying the expected number of outcomes in case branching occurred, - * asserting exact error messages in case of failure, - * ensuring a specific event was triggered during the run, - * checking that some specific assets are present at a given address in the - final blockchain state. +Copyright Tweag I/O 2025 + +`cooked-validators` is a Haskell library to conveniently and efficiently write +off-chain code for Cardano smart contracts. This offchain code will be +specifically geared to testing and auditing the smart contract in question with +further builtin capabilities of the library. + +In particular, `cooked-validators` allows the user to: +- interact with smart contracts written in Plutus or any other language that + compiles to [UPLC](https://plutonomicon.github.io/plutonomicon/uplc), like for + example [Plutarch](https://github.com/Plutonomicon/plutarch-plutus) or + [Aiken](https://aiken-lang.org/), by loading contracts from byte strings +- define transactions in a high level, type-retaining data structure +- submit transactions for validation, while automatically taking care of missing + inputs and outputs, balancing, minimum-Ada constraints, collaterals and fees +- construct sequences of transactions in an easy-to-understand abstraction of + "the blockchain", which can be instantiated to different actual + implementations +- run sequences of transactions in a simulated blockchain +- apply "tweaks" to transactions right before submitting them, where "tweaks" + are modifications that are aware of the current state of the simulated + blockchain +- compose and deploy tweaks with flexible idioms inspired by linear temporal + logic, in order to turn one sequence of transactions into many sequences that + might be useful test cases, generalized in + [Graft](https://github.com/tweag/graft) +- deploy automated attacks over existing sequences of transactions, such as + datum hijacking or double satisfaction attacks, in an attempt to uncover + vulnerabilities + +You are free to copy, modify, and distribute `cooked-validators` under the terms +of the MIT license. We provide `cooked-validators` as a research prototype under +active development, and it comes _as is_ with no guarantees whatsoever. Check +the [license](LICENSE) for details. ## How to integrate `cooked-validators` in a project +To use `cooked-validators`, you need +- [GHC](https://www.haskell.org/ghc/download_ghc_9_6_6.html) version 9.6.6 +- [Cabal](https://www.haskell.org/cabal) version 3.10 or later + 1. `cooked-validators` depends on [cardano-haskell-packages](https://github.com/input-output-hk/cardano-haskell-packages) to get cardano-related packages and on @@ -71,84 +59,40 @@ the `packages` stanza. subdir: . ``` - where `myTag` is either a commit hash in the repo, or a tag, such as v8.0.0 + where `myTag` is either a commit hash in the repo, or a tag, such as v7.0.0 (see [available releases](https://github.com/tweag/cooked-validators/releases)). -3. Each release of `cooked-validators` is pinned to a specific version of - [`cardano-api`](https://github.com/IntersectMBO/cardano-api) which in turn - pins the versions of all other Cardano-related dependencies (including - Plutus). Make sure your project relies on the same version. - ## Example -This example shows how to create and validate a simple transaction that -transfers 10 Ada from wallet 1 to wallet 2, without manually handling fees or -balancing. - -1. Enter a Cabal read-eval-print-loop (with `cabal repl`) - -2. Import your required dependencies - ``` haskell +1. Make your project + [depend](https://cabal.readthedocs.io/en/stable/getting-started.html#adding-dependencies) + on `cooked-validators` and `plutus-script-utils` + +2. Enter a Cabal read-eval-print-loop (with `cabal repl`) + and create and validate a transaction which transfers 10 Ada + from wallet 1 to wallet 2: + ```haskell > import Cooked > import qualified Plutus.Script.Utils.Value as Script - ``` - -3. Define a transaction which transfers 10 Ada from wallet 1 to wallet 2 - ``` haskell - let myTransaction = txSkelTemplate {txSkelOuts = [wallet 2 `receives` Value (Script.ada 10)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1]} - ``` - -4. Send the transaction for validation, and request the printing of the run - ``` haskell - printCooked . runMockChain . validateTxSkel_ $ myTransaction - ``` - -5. Observe the log of the run, including: - - The original skeleton, and its balanced counterpart - - The associated fee and collaterals - - The final mockchain state, with every wallet's assets (notice the 10 ADA - payment owned by wallet 2) - - The value returned by the run (here `()` as we used `validateTxSkel_`) - ```haskell - 📖 MockChain run log: - ⁍ New raw skeleton submitted to the adjustment pipeline: - - Validity interval: (-∞ , +∞) - - Signatories: - - wallet 1 [balancing] - - Outputs: - - Pays to pubkey wallet 2 - - Lovelace: 10_000_000 - ⁍ New adjusted skeleton submitted for validation: - - Validity interval: (-∞ , +∞) - - Signatories: - - wallet 1 [balancing] - - Inputs: - - Spends #4480b35!3 from pubkey wallet 1 - - Redeemer () - - Lovelace: 100_000_000 - - Outputs: - - Pays to pubkey wallet 2 - - Lovelace: 10_000_000 - - Pays to pubkey wallet 1 - - Lovelace: 89_828_383 - - Fee: Lovelace: 171_617 - - No collateral required - ⁍ New transaction successfully validated: - - Transaction id: #c095342 - - Number of new outputs: 2 - ✅ UTxO state: - • pubkey wallet 1 - - Lovelace: 89_828_383 - - (×3) Lovelace: 100_000_000 - • pubkey wallet 2 - - Lovelace: 10_000_000 - - (×4) Lovelace: 100_000_000 - • pubkey wallet 3 - - (×4) Lovelace: 100_000_000 - • pubkey wallet 4 - - (×4) Lovelace: 100_000_000 - 🟢 Returned value: () + > printCooked . runMockChain . validateTxSkel $ + txSkelTemplate + { txSkelOuts = [wallet 2 `receives` Value (Script.ada 10)], + txSkelSigners = [wallet 1] + } + [...] + - UTxO state: + • pubkey wallet 1 + - Lovelace: 89_828_471 + - (×4) Lovelace: 100_000_000 + • pubkey wallet 2 + - Lovelace: 10_000_000 + - (×5) Lovelace: 100_000_000 + • pubkey wallet 3 + - (×5) Lovelace: 100_000_000 + • pubkey wallet 4 + - (×5) Lovelace: 100_000_000 + [...] ``` ## Documentation @@ -171,32 +115,6 @@ balancing. - The [OPTICS](doc/OPTICS.md) file describes our usage of optics to navigate our data structures. -## Blog posts - -Several blog posts have been written about `cooked-validators`. As the library -evolves, some code snippets in these posts may have become outdated. However, -the core philosophy remains unchanged, and these articles still provide valuable -insight into how to use the library. - -1. [An article](https://www.tweag.io/blog/2023-05-11-audit-smart-contract/) - explaining how we use `cooked-validators` to conduct smart contract audits. - -2. [An - article](https://www.tweag.io/blog/2025-02-20-transaction-generation-automation-with-cooked-validators/) - describing how transaction skeletons are built in `cooked-validators` and how - the library constructs complete transactions from them. - -3. [An - article](https://www.tweag.io/blog/2022-01-26-property-based-testing-of-monadic-code/) - presenting the original idea of using temporal modalities to modify sequences - of transactions. - - -4. [An article](https://www.tweag.io/blog/2022-10-14-ltl-attacks/) explaining - how [linear temporal - logic](https://en.wikipedia.org/wiki/Linear_temporal_logic) is used in - `cooked-validators` to deploy modifications over time. - ## Additional resources - We have a [repository](https://github.com/tweag/cooked-smart-contracts) of @@ -217,10 +135,3 @@ insight into how to use the library. - `cooked-validators` comes with a [template repository](https://github.com/tweag/cooked-template) which can be used to develop offchain code and/or audit code with the tool. - -## License - -You are free to copy, modify, and distribute `cooked-validators` under the terms -of the MIT license. We provide `cooked-validators` as a research prototype under -active development, and it comes _as is_ with no guarantees whatsoever. Check -the [license](LICENSE) for details. diff --git a/cabal.project b/cabal.project index a1e1374a9..96f8dcdd0 100644 --- a/cabal.project +++ b/cabal.project @@ -46,8 +46,11 @@ package cardano-crypto-praos flags: -external-libsodium-vrf constraints: - cardano-api == 10.18.1.0 - + , cardano-api == 10.18.1.0 + , plutus-ledger-api == 1.45.0.0 + , polysemy == 1.9.2.0 + , polysemy-plugin == 0.4.5.3 + source-repository-package type: git location: https://github.com/intersectMBO/cardano-node-emulator diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 1bbda71cf..1eb38e96a 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -1,11 +1,11 @@ cabal-version: 3.4 --- This file has been generated from package.yaml by hpack version 0.38.2. +-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: cooked-validators -version: 8.0.0 +version: 7.0.0 license: MIT license-file: LICENSE build-type: Simple @@ -17,18 +17,18 @@ library Cooked.Attack.AddToken Cooked.Attack.DatumHijacking Cooked.Attack.DoubleSat - Cooked.InitialDistribution + Cooked.Families Cooked.Ltl Cooked.MockChain Cooked.MockChain.AutoFilling Cooked.MockChain.Balancing - Cooked.MockChain.BlockChain - Cooked.MockChain.Direct + Cooked.MockChain.Common + Cooked.MockChain.Error Cooked.MockChain.GenerateTx.Anchor Cooked.MockChain.GenerateTx.Body Cooked.MockChain.GenerateTx.Certificate Cooked.MockChain.GenerateTx.Collateral - Cooked.MockChain.GenerateTx.Common + Cooked.MockChain.GenerateTx.Credential Cooked.MockChain.GenerateTx.Input Cooked.MockChain.GenerateTx.Mint Cooked.MockChain.GenerateTx.Output @@ -36,11 +36,17 @@ library Cooked.MockChain.GenerateTx.ReferenceInputs Cooked.MockChain.GenerateTx.Withdrawals Cooked.MockChain.GenerateTx.Witness - Cooked.MockChain.MockChainState - Cooked.MockChain.Staged + Cooked.MockChain.Instances + Cooked.MockChain.Journal + Cooked.MockChain.Log + Cooked.MockChain.Misc + Cooked.MockChain.Read + Cooked.MockChain.Runnable + Cooked.MockChain.State Cooked.MockChain.Testing + Cooked.MockChain.Tweak Cooked.MockChain.UtxoSearch - Cooked.MockChain.UtxoState + Cooked.MockChain.Write Cooked.Pretty Cooked.Pretty.Class Cooked.Pretty.Hashable @@ -53,7 +59,6 @@ library Cooked.Skeleton.Anchor Cooked.Skeleton.Certificate Cooked.Skeleton.Datum - Cooked.Skeleton.Families Cooked.Skeleton.Label Cooked.Skeleton.Mint Cooked.Skeleton.Option @@ -64,7 +69,6 @@ library Cooked.Skeleton.User Cooked.Skeleton.Value Cooked.Skeleton.Withdrawal - Cooked.Staged Cooked.Tweak Cooked.Tweak.Common Cooked.Tweak.Inputs @@ -109,7 +113,7 @@ library TypeFamilies TypeOperators ViewPatterns - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-missed-extra-shared-lib -fobject-code -fno-ignore-interface-pragmas -fignore-hpc-changes -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:conservative-optimisation + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-missed-extra-shared-lib -fobject-code -fno-ignore-interface-pragmas -fignore-hpc-changes -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:conservative-optimisation -fplugin=Polysemy.Plugin build-depends: QuickCheck , base >=4.9 && <5 @@ -143,6 +147,8 @@ library , plutus-script-utils , plutus-tx , plutus-tx-plugin + , polysemy + , polysemy-plugin , prettyprinter , random , random-shuffle @@ -183,6 +189,7 @@ test-suite spec Spec.ReferenceInputs Spec.ReferenceScripts Spec.Slot + Spec.StagedRun Spec.Tweak Spec.Tweak.Common Spec.Tweak.Labels @@ -223,7 +230,7 @@ test-suite spec TypeFamilies TypeOperators ViewPatterns - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-missed-extra-shared-lib -fobject-code -fno-ignore-interface-pragmas -fignore-hpc-changes -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:conservative-optimisation + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-missed-extra-shared-lib -fobject-code -fno-ignore-interface-pragmas -fignore-hpc-changes -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:conservative-optimisation -fplugin=Polysemy.Plugin build-depends: QuickCheck , base >=4.9 && <5 @@ -258,6 +265,8 @@ test-suite spec , plutus-script-utils , plutus-tx , plutus-tx-plugin + , polysemy + , polysemy-plugin , prettyprinter , random , random-shuffle diff --git a/flake.lock b/flake.lock index e5a6762f7..0bf532c57 100644 --- a/flake.lock +++ b/flake.lock @@ -3,15 +3,15 @@ "flake-compat": { "flake": false, "locked": { - "lastModified": 1761588595, - "narHash": "sha256-XKUZz9zewJNUj46b4AJdiRZJAvSZ0Dqj2BNfXvFlJC4=", - "owner": "edolstra", + "lastModified": 1767039857, + "narHash": "sha256-vNpUSpF5Nuw8xvDLj2KCwwksIbjua2LZCqhV1LNRDns=", + "owner": "NixOS", "repo": "flake-compat", - "rev": "f387cd2afec9419c8ee37694406ca490c3f34ee5", + "rev": "5edf11c44bc78a0d334f6334cdaf7d60d732daab", "type": "github" }, "original": { - "owner": "edolstra", + "owner": "NixOS", "repo": "flake-compat", "type": "github" } @@ -57,15 +57,16 @@ }, "nixpkgs": { "locked": { - "lastModified": 1766062740, - "narHash": "sha256-U9KVTNs7PvyND7gisDMiluOfwT5hvOlMH2LTYfAYpNk=", + "lastModified": 1769300771, + "narHash": "sha256-MI1YHDj3a4B3Tl4y8xXQUfOMmp1/+89ZAERztmmMCpI=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "6dc87b326cef973e51ed3d2ffbdbe6240917a7be", + "rev": "b2286b474056786a86863bd3efd9f5ab36d030b6", "type": "github" }, "original": { "owner": "NixOS", + "ref": "haskell-updates", "repo": "nixpkgs", "type": "github" } @@ -79,11 +80,11 @@ ] }, "locked": { - "lastModified": 1765911976, - "narHash": "sha256-t3T/xm8zstHRLx+pIHxVpQTiySbKqcQbK+r+01XVKc0=", + "lastModified": 1769069492, + "narHash": "sha256-Efs3VUPelRduf3PpfPP2ovEB4CXT7vHf8W+xc49RL/U=", "owner": "cachix", "repo": "pre-commit-hooks.nix", - "rev": "b68b780b69702a090c8bb1b973bab13756cc7a27", + "rev": "a1ef738813b15cf8ec759bdff5761b027e3e1d23", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 2d743bced..deceda322 100644 --- a/flake.nix +++ b/flake.nix @@ -1,5 +1,5 @@ { - inputs.nixpkgs.url = "github:NixOS/nixpkgs"; + inputs.nixpkgs.url = "github:NixOS/nixpkgs/haskell-updates"; inputs.flake-utils.url = "github:numtide/flake-utils"; inputs.pre-commit-hooks.url = "github:cachix/pre-commit-hooks.nix"; inputs.pre-commit-hooks.inputs.nixpkgs.follows = "nixpkgs"; diff --git a/package.yaml b/package.yaml index a8a98875e..281bba37c 100644 --- a/package.yaml +++ b/package.yaml @@ -2,7 +2,7 @@ verbatim: cabal-version: 3.4 name: cooked-validators -version: 8.0.0 +version: 7.0.0 dependencies: - QuickCheck @@ -37,6 +37,8 @@ dependencies: - plutus-script-utils - plutus-tx - plutus-tx-plugin + - polysemy + - polysemy-plugin - prettyprinter - random - random-shuffle @@ -62,6 +64,7 @@ library: -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:conservative-optimisation + -fplugin=Polysemy.Plugin default-extensions: &default-extensions - ConstraintKinds - DataKinds diff --git a/src/Cooked.hs b/src/Cooked.hs index 8562790ed..bde37fdfb 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -3,12 +3,11 @@ module Cooked (module X) where import Cooked.Attack as X -import Cooked.InitialDistribution as X +import Cooked.Families as X import Cooked.Ltl as X import Cooked.MockChain as X import Cooked.Pretty as X import Cooked.ShowBS as X import Cooked.Skeleton as X -import Cooked.Staged as X import Cooked.Tweak as X import Cooked.Wallet as X diff --git a/src/Cooked/Attack/AddToken.hs b/src/Cooked/Attack/AddToken.hs index a51d7fdf2..39d71f73a 100644 --- a/src/Cooked/Attack/AddToken.hs +++ b/src/Cooked/Attack/AddToken.hs @@ -9,14 +9,18 @@ module Cooked.Attack.AddToken where import Control.Monad -import Cooked.Pretty +import Cooked.Pretty.Class import Cooked.Skeleton -import Cooked.Tweak +import Cooked.Tweak.Common +import Cooked.Tweak.Labels +import Cooked.Tweak.Outputs import Data.Map qualified as Map import Optics.Core import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V3 qualified as Api import PlutusTx.Numeric qualified as PlutusTx +import Polysemy +import Polysemy.NonDet import Prettyprinter qualified as PP -- | This attack adds extra tokens of any kind for minting policies already @@ -25,13 +29,15 @@ import Prettyprinter qualified as PP -- -- This attack adds an 'AddTokenLbl' label. addTokenAttack :: - (MonadTweak m, IsTxSkelOutAllowedOwner o) => + ( Members '[Tweak, NonDet] effs, + IsTxSkelOutAllowedOwner o + ) => -- | For each policy that occurs in some 'Mint' constraint, return a list of -- token names together with how many tokens with that name should be minted. (VScript -> [(Api.TokenName, Integer)]) -> -- | The attacker, who receives the extra tokens. o -> - m Api.Value + Sem effs Api.Value addTokenAttack extraTokens attacker = do currencies <- viewTweak (txSkelMintsL % txSkelMintsAssetClassesG % to (fmap fst)) oldMintsValue <- viewTweak (txSkelMintsL % to Script.toValue) @@ -48,7 +54,9 @@ addTokenAttack extraTokens attacker = do -- -- This attack adds an 'DupTokenLbl' label dupTokenAttack :: - (MonadTweak m, IsTxSkelOutAllowedOwner o) => + ( Members '[Tweak, NonDet] effs, + IsTxSkelOutAllowedOwner o + ) => -- | A function describing how the amount of tokens specified by a 'Mint' -- constraint should be changed, depending on the asset class and the amount -- specified by the constraint. The given function @f@ should probably satisfy @@ -60,7 +68,7 @@ dupTokenAttack :: -- the modified transaction but were not minted by the original transaction -- are paid to this target. o -> - m Api.Value + Sem effs Api.Value dupTokenAttack change attacker = do mints <- viewTweak txSkelMintsL res <- diff --git a/src/Cooked/Attack/DatumHijacking.hs b/src/Cooked/Attack/DatumHijacking.hs index a9fd9016f..e29ac64d5 100644 --- a/src/Cooked/Attack/DatumHijacking.hs +++ b/src/Cooked/Attack/DatumHijacking.hs @@ -12,27 +12,23 @@ module Cooked.Attack.DatumHijacking scriptsDatumHijackingParams, defaultDatumHijackingParams, datumOfDatumHijackingParams, - txSkelOutPredDatumHijackingParams, + outPredDatumHijackingParams, ) where import Control.Monad import Cooked.Pretty.Class +import Cooked.Pretty.Skeleton () import Cooked.Skeleton -import Cooked.Tweak +import Cooked.Tweak.Common +import Cooked.Tweak.Labels import Data.Bifunctor import Data.Kind (Type) import Data.Maybe import Data.Typeable import Optics.Core - --- | The 'DatumHijackingLabel' stores the outputs that have been redirected, --- before their destination were changed. -newtype DatumHijackingLabel = DatumHijackingLabel [TxSkelOut] - deriving (Show, Eq, Ord) - -instance PrettyCooked DatumHijackingLabel where - prettyCookedOpt opts (DatumHijackingLabel txSkelOuts) = prettyItemize opts "Redirected outputs" "-" txSkelOuts +import Polysemy +import Polysemy.NonDet -- | Parameters of the datum hijacking attacks. They state precisely which -- outputs should have their owner changed, wich owner should be assigned, to @@ -58,7 +54,13 @@ data DatumHijackingParams where -- | Targets all the outputs for which the focus of a given optic exists, and -- redirects each of them in a separate transaction. -defaultDatumHijackingParams :: (IsTxSkelOutAllowedOwner owner, Is k An_AffineFold) => Optic' k is TxSkelOut x -> owner -> DatumHijackingParams +defaultDatumHijackingParams :: + ( IsTxSkelOutAllowedOwner owner, + Is k An_AffineFold + ) => + Optic' k is TxSkelOut x -> + owner -> + DatumHijackingParams defaultDatumHijackingParams optic thief = DatumHijackingParams ((thief <$) . preview optic) @@ -67,22 +69,41 @@ defaultDatumHijackingParams optic thief = -- | Targets all the outputs satisfying a given predicate, and redirects each of -- them in a separate transaction. -txSkelOutPredDatumHijackingParams :: (IsTxSkelOutAllowedOwner owner) => (TxSkelOut -> Bool) -> owner -> DatumHijackingParams -txSkelOutPredDatumHijackingParams predicate = defaultDatumHijackingParams (selectP predicate) +outPredDatumHijackingParams :: + (IsTxSkelOutAllowedOwner owner) => + (TxSkelOut -> Bool) -> + owner -> + DatumHijackingParams +outPredDatumHijackingParams = defaultDatumHijackingParams . filtered -- | Datum hijacking parameters targetting all the outputs owned by a certain -- type of owner, and redirecting each of them in a separate transaction. -ownedByDatumHijackingParams :: forall (oldOwner :: Type) owner. (IsTxSkelOutAllowedOwner owner, Typeable oldOwner) => owner -> DatumHijackingParams +ownedByDatumHijackingParams :: + forall (oldOwner :: Type) owner. + ( IsTxSkelOutAllowedOwner owner, + Typeable oldOwner + ) => + owner -> + DatumHijackingParams ownedByDatumHijackingParams = defaultDatumHijackingParams (txSkelOutOwnerL % userTypedAF @oldOwner) -- | Datum hijacking parameters targetting all the outputs owned by a script, -- and redirecting each of them in a separate transaction. -scriptsDatumHijackingParams :: (IsTxSkelOutAllowedOwner owner) => owner -> DatumHijackingParams +scriptsDatumHijackingParams :: + (IsTxSkelOutAllowedOwner owner) => + owner -> + DatumHijackingParams scriptsDatumHijackingParams = defaultDatumHijackingParams (txSkelOutOwnerL % userScriptHashAF) -- | Datum hijacking parameters targetting all the outputs with a certain type -- of datum, and redirecting each of them in a separate transaction. -datumOfDatumHijackingParams :: forall dat owner. (IsTxSkelOutAllowedOwner owner, DatumConstrs dat) => owner -> DatumHijackingParams +datumOfDatumHijackingParams :: + forall dat owner. + ( IsTxSkelOutAllowedOwner owner, + DatumConstrs dat + ) => + owner -> + DatumHijackingParams datumOfDatumHijackingParams = defaultDatumHijackingParams (txSkelOutDatumL % txSkelOutDatumTypedAT @dat) -- | Redirects, in the same transaction, all the outputs targetted by an output @@ -90,10 +111,12 @@ datumOfDatumHijackingParams = defaultDatumHijackingParams (txSkelOutDatumL % txS -- those predicates. Returns the list of outputs that were successfully -- modified, before the modification is applied. redirectOutputTweakAll :: - (MonadTweak m, IsTxSkelOutAllowedOwner owner) => + ( Member Tweak effs, + IsTxSkelOutAllowedOwner owner + ) => (TxSkelOut -> Maybe owner) -> (Integer -> Bool) -> - m [TxSkelOut] + Sem effs [TxSkelOut] redirectOutputTweakAll outputPred indexPred = do outputs <- viewTweak txSkelOutsL let (redirected, newOutputs) = go outputs 0 @@ -111,10 +134,12 @@ redirectOutputTweakAll outputPred indexPred = do -- output and an index predicates. See 'DatumHijackingParams' for more -- information on those predicates. redirectOutputTweakAny :: - (MonadTweak m, IsTxSkelOutAllowedOwner owner) => + ( Members '[Tweak, NonDet] effs, + IsTxSkelOutAllowedOwner owner + ) => (TxSkelOut -> Maybe owner) -> (Integer -> Bool) -> - m [TxSkelOut] + Sem effs [TxSkelOut] redirectOutputTweakAny outputPred indexPred = do outputs <- viewTweak txSkelOutsL (redirected, newOutputs) <- go [] 0 outputs @@ -135,14 +160,24 @@ redirectOutputTweakAny outputPred indexPred = do ) go l' n (out : l) = go (l' ++ [out]) n l --- | A datum hijacking attack, simplified: This attack tries to substitute a --- different recipient on certain outputs based on a 'DatumHijackingParams'. +-- | The 'DatumHijackingLabel' stores the outputs that have been redirected, +-- before their destination were changed. +newtype DatumHijackingLabel = DatumHijackingLabel [TxSkelOut] + deriving (Show, Eq, Ord) + +instance PrettyCooked DatumHijackingLabel where + prettyCookedOpt opts (DatumHijackingLabel txSkelOuts) = prettyItemize opts "Redirected outputs" "-" txSkelOuts + +-- | The datum hijacking tries to substitute a different recipient on certain +-- outputs based on a 'DatumHijackingParams'. -- --- A 'DatumHijackingLabel' is added to the labels of the 'TxSkel' using --- 'addLabelTweak'. It contains the outputs that have been redirected, which --- also corresponds to the returned value of this tweak. The tweak fails if no --- such outputs have been redirected. -datumHijackingAttack :: (MonadTweak m) => DatumHijackingParams -> m [TxSkelOut] +-- A 'DatumHijackingLabel' is added to the labels of the 'TxSkel'. It contains +-- the outputs that have been redirected, which also corresponds to the returned +-- value of this tweak. The tweak fails if no such outputs have been redirected. +datumHijackingAttack :: + (Members '[Tweak, NonDet] effs) => + DatumHijackingParams -> + Sem effs [TxSkelOut] datumHijackingAttack (DatumHijackingParams outputPred indexPred mode) = do redirected <- (if mode then redirectOutputTweakAll else redirectOutputTweakAny) outputPred indexPred guard $ not $ null redirected diff --git a/src/Cooked/Attack/DoubleSat.hs b/src/Cooked/Attack/DoubleSat.hs index 4f7c002e8..6735bf260 100644 --- a/src/Cooked/Attack/DoubleSat.hs +++ b/src/Cooked/Attack/DoubleSat.hs @@ -9,10 +9,15 @@ module Cooked.Attack.DoubleSat ) where -import Cooked.MockChain.BlockChain -import Cooked.Pretty +import Control.Monad +import Cooked.MockChain.Read +import Cooked.Pretty.Class import Cooked.Skeleton -import Cooked.Tweak +import Cooked.Tweak.Common +import Cooked.Tweak.Inputs +import Cooked.Tweak.Labels +import Cooked.Tweak.Mint +import Cooked.Tweak.Outputs import Data.Map (Map) import Data.Map qualified as Map import Optics.Core @@ -20,6 +25,8 @@ import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api import PlutusTx.Numeric qualified as PlutusTx +import Polysemy +import Polysemy.NonDet {- Note: What is a double satisfaction attack? @@ -66,7 +73,12 @@ instance {-# OVERLAPPING #-} Monoid DoubleSatDelta where -- value contained in new inputs to the transaction is then paid to the -- attacker. doubleSatAttack :: - (MonadTweak m, Eq is, Is k A_Traversal, IsTxSkelOutAllowedOwner owner) => + forall effs is k owner a. + ( Members '[Tweak, NonDet, MockChainRead] effs, + Eq is, + Is k A_Traversal, + IsTxSkelOutAllowedOwner owner + ) => -- | how to combine modifications from caused by different foci. See the -- comment at 'combineModsTweak', which uses the same logic. ([is] -> [[is]]) -> @@ -96,13 +108,13 @@ doubleSatAttack :: -- 'Cooked.MockChain.UtxoState.UtxoState' argument. -- -- ################################### - (is -> a -> m [(a, DoubleSatDelta)]) -> + (is -> a -> Sem effs [(a, DoubleSatDelta)]) -> -- | The attacker, who receives any surplus. -- -- In the example, the extra value in the added input will be paid to the -- attacker. owner -> - m () + Sem effs () doubleSatAttack groupings optic change target = do deltas <- combineModsTweak groupings optic change let delta = joinDoubleSatDeltas deltas @@ -110,18 +122,18 @@ doubleSatAttack groupings optic change target = do addedValue <- deltaBalance delta if addedValue `Api.gt` mempty then addOutputTweak $ target `receives` Value addedValue - else failingTweak + else mzero addLabelTweak DoubleSatLbl where -- for each triple of additional inputs, outputs, and mints, -- calculate its balance - deltaBalance :: (MonadTweak m) => DoubleSatDelta -> m Api.Value + deltaBalance :: DoubleSatDelta -> Sem effs Api.Value deltaBalance (inputs, outputs, mints) = do inValue <- foldMap (view txSkelOutValueL . snd) . filter ((`elem` Map.keys inputs) . fst) <$> allUtxos return $ inValue <> PlutusTx.negate (foldOf (traversed % txSkelOutValueL) outputs) <> Script.toValue mints -- Helper tweak to add a 'DoubleSatDelta' to a transaction - addDoubleSatDeltaTweak :: (MonadTweak m) => DoubleSatDelta -> m () + addDoubleSatDeltaTweak :: DoubleSatDelta -> Sem effs () addDoubleSatDeltaTweak (ins, outs, mints) = mapM_ (uncurry addInputTweak) (Map.toList ins) >> mapM_ addOutputTweak outs diff --git a/src/Cooked/Skeleton/Families.hs b/src/Cooked/Families.hs similarity index 78% rename from src/Cooked/Skeleton/Families.hs rename to src/Cooked/Families.hs index 3d3bde63b..9a8bb0a9c 100644 --- a/src/Cooked/Skeleton/Families.hs +++ b/src/Cooked/Families.hs @@ -3,7 +3,7 @@ -- | This module exposes some type families used to either directly constraint -- values within our skeletons, or constrant inputs of smart constructors for -- components of these skeletons. -module Cooked.Skeleton.Families +module Cooked.Families ( -- * Type-level constraints type (∈), type (∉), @@ -18,6 +18,11 @@ module Cooked.Skeleton.Families type RevAux, type Member, type NonMember, + + -- * Heterogeneous lists + HList (..), + hHead, + hTail, ) where @@ -70,3 +75,28 @@ type (∉) el els = NonMember el els '[] type family (⩀) (els :: [a]) (els' :: [a]) :: Constraint where '[] ⩀ _ = () (x ': xs) ⩀ ys = (x ∉ ys, xs ⩀ ys) + +-- | Heterogeneous lists +data HList :: [Type] -> Type where + HEmpty :: HList '[] + HCons :: a -> HList l -> HList (a ': l) + +-- | Head of an heterogeneous list +hHead :: HList (a ': l) -> a +hHead (HCons a _) = a + +-- | Tail of an heterogeneous list +hTail :: HList (a ': l) -> HList l +hTail (HCons _ l) = l + +instance Eq (HList '[]) where + _ == _ = True + +instance (Eq (HList l), Eq a) => Eq (HList (a ': l)) where + HCons h t == HCons h' t' = h == h' && t == t' + +instance Show (HList '[]) where + show _ = "[]" + +instance (Show (HList l), Show a) => Show (HList (a ': l)) where + show (HCons h t) = show h <> " : " <> show t diff --git a/src/Cooked/InitialDistribution.hs b/src/Cooked/InitialDistribution.hs deleted file mode 100644 index a3c058f0e..000000000 --- a/src/Cooked/InitialDistribution.hs +++ /dev/null @@ -1,50 +0,0 @@ --- | This module provides a convenient way to spread assets between wallets and --- scripts at the initialization of the mock chain. These initial assets can be --- accompanied by datums, staking credentials and reference scripts. -module Cooked.InitialDistribution - ( InitialDistribution (..), - distributionFromList, - ) -where - -import Cooked.Skeleton -import Cooked.Wallet -import Data.Default -import Data.List (foldl') -import Plutus.Script.Utils.Value qualified as Script -import PlutusLedgerApi.V3 qualified as Api - --- * Initial distribution of funds - --- | Describes the initial distribution of UTxOs per user. --- --- The following specifies a starting state where @wallet 1@ owns two UTxOs, --- one with 42 Ada and one with 2 Ada and one "TOK" token; @wallet 2@ owns a --- single UTxO with 10 Ada and @wallet 3@ has 10 Ada and a permanent value --- --- > i0 = distributionFromList $ --- > [ (wallet 1 , [ ada 42 , ada 2 <> quickValue "TOK" 1 ] --- > , (wallet 2 , [ ada 10 ]) --- > , (wallet 3 , [ ada 10 <> permanentValue "XYZ" 10]) --- > ] --- --- Note that payment issued through an initial distribution will be attached --- enough ADA to sustain themselves. -data InitialDistribution where - InitialDistribution :: - {unInitialDistribution :: [TxSkelOut]} -> - InitialDistribution - --- | 4 UTxOs with 100 Ada each, for each of the first 4 'knownWallets' -instance Default InitialDistribution where - def = distributionFromList . zip (take 4 knownWallets) . repeat . replicate 4 $ Script.ada 100 - -instance Semigroup InitialDistribution where - i <> j = InitialDistribution (unInitialDistribution i <> unInitialDistribution j) - -instance Monoid InitialDistribution where - mempty = InitialDistribution mempty - --- | Creating a initial distribution with simple values assigned to owners -distributionFromList :: (IsTxSkelOutAllowedOwner owner) => [(owner, [Api.Value])] -> InitialDistribution -distributionFromList = InitialDistribution . foldl' (\x (user, values) -> x <> map (receives user . Value) values) [] diff --git a/src/Cooked/Ltl.hs b/src/Cooked/Ltl.hs index 125fdbda6..61637fa13 100644 --- a/src/Cooked/Ltl.hs +++ b/src/Cooked/Ltl.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | This modules provides the infrastructure to modify sequences of -- transactions using LTL formulaes with atomic modifications. This idea is to -- describe when to apply certain modifications within a trace. module Cooked.Ltl - ( -- * LTL formulas + ( -- * `Ltl` formulas Ltl (..), - -- * LTL combinators + -- * `Ltl` combinators ltlNot', ltlOr', ltlAnd', @@ -29,24 +31,30 @@ module Cooked.Ltl ltlNever, ltlNever', - -- * Using LTL formulas to modify computations + -- * `Ltl` helpers, + nowLaterList, + finished, + + -- * Laying out modifications on time using `Ltl` + ModifyGlobally, + modifyLtl, + runModifyGlobally, + + -- * Locally applying laid out modifications Requirement (..), - LtlOp (..), - StagedLtl, - singletonBuiltin, - MonadLtl (..), - ModInterpBuiltin (..), - interpStagedLtl, + ModifyLocally, + getRequirements, + runModifyLocally, ) where import Control.Monad -import Control.Monad.State -import Cooked.Staged import Data.Functor -import Data.Kind +import Polysemy +import Polysemy.NonDet +import Polysemy.State --- | Type of LTL formulas with atomic formulas of type @a@. Think of @a@ as a +-- | Type of `Ltl` formulas with atomic formulas of type @a@. Think of @a@ as a -- type of "modifications", then a value of type @Ltl a@ describes where to -- apply `Requirement`s in a trace. data Ltl a @@ -191,7 +199,7 @@ ltlImplies f1 f2 = (f2 `LtlAnd` f1) `LtlOr` LtlNot f1 ltlImplies' :: a -> a -> Ltl a ltlImplies' a1 a2 = LtlAtom a1 `ltlImplies` LtlAtom a2 --- | Simplification procedure for LTL formulas. This function knows how +-- | Simplification procedure for `Ltl` formulas. This function knows how -- `LtlTruth` and `LtlFalsity` play with negation, conjunction and disjunction -- and recursively applies this knowledge; it is used to keep the formulas -- `nowLaterList` generates from growing too wildly. While this function does @@ -244,8 +252,9 @@ data Requirement a Apply a | -- | Ensure this modification fails now EnsureFailure a + deriving (Show, Eq) --- | For each LTL formula that describes a modification of a computation in a +-- | For each `Ltl` formula that describes a modification of a computation in a -- list, split it into a list of @(doNow, doLater)@ pairs, and then -- appropriately combine the results. The result of the splitting is bound to -- the following semantics: @@ -254,7 +263,7 @@ data Requirement a -- the current time step (`Apply`), or that should fail at the current time step -- (`EnsureFailure`) -- --- * @doLater@ is an LTL formula describing the modification that should be +-- * @doLater@ is an `Ltl` formula describing the modification that should be -- applied from the next time step onwards. -- -- The return value is a list because a formula might be satisfied in different @@ -301,76 +310,75 @@ finished (LtlUntil _ _) = False finished (LtlRelease _ _) = True finished (LtlNot f) = not $ finished f --- | Operations that either allow to use a builtin, or to modify a computation --- using an `Ltl` formula. -data LtlOp modification builtin :: Type -> Type where - WrapLtl :: Ltl modification -> StagedLtl modification builtin a -> LtlOp modification builtin a - Builtin :: builtin a -> LtlOp modification builtin a +-- | An effect to modify a computation with an `Ltl` formula. The idea is that +-- the formula pinpoints locations where `Requirement`s should be enforced. +data ModifyGlobally a :: Effect where + ModifyLtl :: Ltl a -> m b -> ModifyGlobally a m b --- | An AST of builtins wrapped into an `Ltl` setting -type StagedLtl modification builtin = Staged (LtlOp modification builtin) +makeSem_ ''ModifyGlobally --- | Builds a singleton instruction in a `StagedLtl` monad -singletonBuiltin :: builtin a -> StagedLtl modification builtin a -singletonBuiltin = (`Instr` Return) . Builtin +-- | Lays out an `Ltl` formula to be used for modification within the execution +-- of the wrapped computation. See `ModifyLocally` for how to consume and use +-- the laid out modifications. +modifyLtl :: forall a r b. (Member (ModifyGlobally a) r) => Ltl a -> Sem r b -> Sem r b --- | Depicts the ability to modify a computation with an `Ltl` formula -class (Monad m) => MonadLtl modification m where - modifyLtl :: Ltl modification -> m a -> m a - -instance MonadLtl modification (StagedLtl modification builtin) where - modifyLtl formula comp = Instr (WrapLtl formula comp) Return - --- | Depicts the ability to modify and interpret builtins in a given --- domain. Each builtin can either: --- --- * be interpreted directly through @Left@, in which case it will not be --- considered as a timestep in a trace. +-- | Running the `ModifyGlobally` effect requires to have access of the current +-- list of `Ltl` formulas, and to have access to an empty computation. -- --- * be modified and only then interpreted through @Right@, in which case it --- will be considered as a timestep in a trace. -class ModInterpBuiltin modification builtin m where - modifyAndInterpBuiltin :: builtin a -> Either (m a) ([Requirement modification] -> m a) - --- | Interprets a `StagedLtl` computation based on an interpretation of --- @builtin@ with respect to possible modifications. This unfolds as follows: --- --- * When a builtin is met, which is directly interpreted, we return the --- associated computation, with no changes to the `Ltl` state. --- --- * When a builtin is met, which requires a modification, we return the --- modified interpretation, and consume the current modification requirements. +-- A new formula is appended at the head of the current list of formula. Then, +-- the actual computation is run, after which the newly added formula must be +-- finished, otherwise the empty computation is returned. +runModifyGlobally :: + forall mod effs a. + ( Members + '[ State [Ltl mod], + NonDet + ] + effs + ) => + Sem (ModifyGlobally mod ': effs) a -> + Sem effs a +runModifyGlobally = + interpretH $ \case + ModifyLtl formula comp -> do + modify (formula :) + comp' <- runT comp + res <- raise $ runModifyGlobally comp' + formulas <- get + unless (null formulas) $ do + guard (finished (head formulas)) + put (tail formulas) + return res + +-- | An effect to request and consume the list of requirements that should be +-- enforced at the current time step. +data ModifyLocally a :: Effect where + GetRequirements :: ModifyLocally a m [Requirement a] + +makeSem_ ''ModifyLocally + +-- | Reads and consumes a modification from the context, typically laid out by +-- `ModifyGlobally` further up the stack of effects. +getRequirements :: (Member (ModifyLocally a) effs) => Sem effs [Requirement a] + +-- | Running the `ModifyLocally` effect requires to have access to the current +-- list of `Ltl` formulas, and to be able to branch. -- --- * When a wrapped computation is met, we store the new associated formula, and --- ensure that when the computation ends, the formula is finished. -interpStagedLtl :: - forall modification builtin m. - ( MonadPlus m, - ModInterpBuiltin modification builtin m +-- The function `nowLaterList` is invoked to fetch the various paths implied by +-- the current formulas, and a branching is performed to explore all of +-- them. The new formulas for next steps are stored, and each path is given the +-- requirements to enforce at the current time step. +runModifyLocally :: + forall modification effs a. + ( Members + '[ State [Ltl modification], + NonDet + ] + effs ) => - forall a. - -- | A staged computation `Ltl` compatible - StagedLtl modification builtin a -> - -- | Interpretation of the computation - m a -interpStagedLtl = flip evalStateT [] . go - where - go :: forall a. Staged (LtlOp modification builtin) a -> StateT [Ltl modification] m a - go = interpStaged $ \case - WrapLtl formula comp -> do - modify' (formula :) - res <- go comp - formulas <- get - unless (null formulas) $ do - guard $ finished $ head formulas - put $ tail formulas - return res - Builtin builtin -> - case modifyAndInterpBuiltin builtin of - Left comp -> lift comp - Right applyMod -> do - modifications <- gets nowLaterList - msum . (modifications <&>) $ - \(now, later) -> do - put later - lift $ applyMod now + Sem (ModifyLocally modification : effs) a -> + Sem effs a +runModifyLocally = + interpret $ \GetRequirements -> do + modifications <- gets nowLaterList + msum . (modifications <&>) $ \(now, later) -> put later >> return now diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index 8b266d376..5006c238e 100644 --- a/src/Cooked/MockChain.hs +++ b/src/Cooked/MockChain.hs @@ -4,10 +4,15 @@ module Cooked.MockChain (module X) where import Cooked.MockChain.AutoFilling as X import Cooked.MockChain.Balancing as X -import Cooked.MockChain.BlockChain as X -import Cooked.MockChain.Direct as X -import Cooked.MockChain.MockChainState as X -import Cooked.MockChain.Staged as X +import Cooked.MockChain.Common as X +import Cooked.MockChain.Error as X +import Cooked.MockChain.Instances as X +import Cooked.MockChain.Journal as X +import Cooked.MockChain.Misc as X +import Cooked.MockChain.Read as X +import Cooked.MockChain.Runnable as X +import Cooked.MockChain.State as X import Cooked.MockChain.Testing as X +import Cooked.MockChain.Tweak as X import Cooked.MockChain.UtxoSearch as X -import Cooked.MockChain.UtxoState as X +import Cooked.MockChain.Write as X diff --git a/src/Cooked/MockChain/AutoFilling.hs b/src/Cooked/MockChain/AutoFilling.hs index 9ef2dc9e5..a989aa9b6 100644 --- a/src/Cooked/MockChain/AutoFilling.hs +++ b/src/Cooked/MockChain/AutoFilling.hs @@ -6,17 +6,22 @@ import Cardano.Api qualified as Cardano import Cardano.Ledger.Shelley.Core qualified as Shelley import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad -import Cooked.MockChain.BlockChain import Cooked.MockChain.GenerateTx.Output +import Cooked.MockChain.Log +import Cooked.MockChain.Read import Cooked.MockChain.UtxoSearch import Cooked.Skeleton +import Cooked.Tweak.Common import Data.List (find) import Data.Map qualified as Map import Data.Maybe +import Ledger.Tx qualified as Ledger import Optics.Core import Plutus.Script.Utils.Address qualified as Script import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error -- * Auto filling withdrawal amounts @@ -24,9 +29,11 @@ import PlutusLedgerApi.V3 qualified as Api -- out the withdrawn amount based on the associated user rewards. Does not -- tamper with an existing specified amount in such withdrawals. Logs an event -- when an amount has been successfully auto-filled. -autoFillWithdrawalAmounts :: (MonadBlockChainWithoutValidation m) => TxSkel -> m TxSkel -autoFillWithdrawalAmounts txSkel = do - let withdrawals = view (txSkelWithdrawalsL % txSkelWithdrawalsListI) txSkel +autoFillWithdrawalAmounts :: + (Members '[MockChainRead, Tweak, MockChainLog] effs) => + Sem effs () +autoFillWithdrawalAmounts = do + withdrawals <- viewTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI) newWithdrawals <- forM withdrawals $ \withdrawal -> do currentReward <- getCurrentReward $ view withdrawalUserL withdrawal let (changed, newWithdrawal) = case currentReward of @@ -38,7 +45,7 @@ autoFillWithdrawalAmounts txSkel = do (view (withdrawalUserL % to Script.toCredential) newWithdrawal) (fromJust (preview withdrawalAmountAT newWithdrawal)) return newWithdrawal - return $ txSkel & txSkelWithdrawalsL % txSkelWithdrawalsListI .~ newWithdrawals + setTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI) newWithdrawals -- * Auto filling constitution script @@ -46,84 +53,100 @@ autoFillWithdrawalAmounts txSkel = do -- out the constitution scripts with the current one. Does not tamper with an -- existing specified script in such withdrawals. Logs an event when the -- constitution script has been successfully auto-filled. -autoFillConstitution :: (MonadBlockChainWithoutValidation m) => TxSkel -> m TxSkel -autoFillConstitution txSkel = do +autoFillConstitution :: + (Members '[MockChainRead, Tweak, MockChainLog] effs) => + Sem effs () +autoFillConstitution = do currentConstitution <- getConstitutionScript case currentConstitution of - Nothing -> return txSkel + Nothing -> return () Just constitutionScript -> do - newProposals <- forM (view txSkelProposalsL txSkel) $ \prop -> do + proposals <- viewTweak txSkelProposalsL + newProposals <- forM proposals $ \prop -> do when (isn't txSkelProposalConstitutionAT prop) $ logEvent $ MCLogAutoFilledConstitution $ Script.toScriptHash constitutionScript return (fillConstitution constitutionScript prop) - return $ txSkel & txSkelProposalsL .~ newProposals + setTweak txSkelProposalsL newProposals --- * Auto filling reference scripts +-- -- * Auto filling reference scripts -- | Attempts to find in the index a utxo containing a reference script with the -- given script hash, and attaches it to a redeemer when it does not yet have a -- reference input and when it is allowed, in which case an event is logged. -updateRedeemedScript :: (MonadBlockChain m) => [Api.TxOutRef] -> User IsScript Redemption -> m (User IsScript Redemption) -updateRedeemedScript inputs rs@(UserRedeemedScript (toVScript -> vScript) txSkelRed@(TxSkelRedeemer {txSkelRedeemerAutoFill = True})) = do - oRefsInInputs <- runUtxoSearch (referenceScriptOutputsSearch vScript) - maybe - -- We leave the redeemer unchanged if no reference input was found - (return rs) - -- If a reference input is found, we assign it and log the event - ( \oRef -> do - logEvent $ MCLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash vScript) - return $ over userTxSkelRedeemerAT (fillReferenceInput oRef) rs - ) - $ case oRefsInInputs of - [] -> Nothing - -- If possible, we use a reference input appearing in regular inputs - l | Just (oRefM', _) <- find (\(r, _) -> r `elem` inputs) l -> Just oRefM' - -- If none exist, we use the first one we find elsewhere - ((oRefM', _) : _) -> Just oRefM' +updateRedeemedScript :: + (Members '[MockChainLog, MockChainRead] effs) => + [Api.TxOutRef] -> + User IsScript Redemption -> + Sem effs (User IsScript Redemption) +updateRedeemedScript + inputs + rs@( UserRedeemedScript + (toVScript -> vScript) + txSkelRed@(TxSkelRedeemer {txSkelRedeemerAutoFill = True}) + ) = do + oRefsInInputs <- getTxOutRefs $ allUtxosSearch $ ensureProperReferenceScript vScript + maybe + -- We leave the redeemer unchanged if no reference input was found + (return rs) + -- If a reference input is found, we assign it and log the event + ( \oRef -> do + logEvent $ MCLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash vScript) + return $ over userTxSkelRedeemerAT (fillReferenceInput oRef) rs + ) + $ case oRefsInInputs of + [] -> Nothing + -- If possible, we use a reference input appearing in regular inputs + l | Just oRefM' <- find (`elem` inputs) l -> Just oRefM' + -- If none exist, we use the first one we find elsewhere + (oRefM' : _) -> Just oRefM' updateRedeemedScript _ rs = return rs -- | Goes through the various parts of the skeleton where a redeemer can appear, -- and attempts to attach a reference input to each of them, whenever it is -- allowed and one has not already been set. Logs an event whenever such an -- addition occurs. -autoFillReferenceScripts :: forall m. (MonadBlockChain m) => TxSkel -> m TxSkel -autoFillReferenceScripts txSkel = do - let inputs = view (txSkelInsL % to Map.keys) txSkel - newMints <- forM (view (txSkelMintsL % txSkelMintsListI) txSkel) $ \(Mint rs tks) -> - (`Mint` tks) <$> updateRedeemedScript inputs rs - newInputs <- forM (view (txSkelInsL % to Map.toList) txSkel) $ \(oRef, red) -> +autoFillReferenceScripts :: + (Members '[Tweak, MockChainRead, MockChainLog] effs) => + Sem effs () +autoFillReferenceScripts = do + inputsKeys <- viewTweak $ txSkelInsL % to Map.keys + -- Updating minting redeemers + mints <- viewTweak $ txSkelMintsL % txSkelMintsListI + newMints <- forM mints $ \(Mint rs tks) -> (`Mint` tks) <$> updateRedeemedScript inputsKeys rs + setTweak (txSkelMintsL % txSkelMintsListI) newMints + -- Updating spending redeemers + inputsList <- viewTweak $ txSkelInsL % to Map.toList + newInputs <- forM inputsList $ \(oRef, red) -> (oRef,) <$> do validatorM <- previewByRef (txSkelOutOwnerL % userVScriptAT) oRef case validatorM of Nothing -> return red - Just val -> view userTxSkelRedeemerL <$> updateRedeemedScript inputs (UserRedeemedScript val red) - newProposals <- forM (view txSkelProposalsL txSkel) $ \prop -> + Just val -> view userTxSkelRedeemerL <$> updateRedeemedScript inputsKeys (UserRedeemedScript val red) + setTweak txSkelInsL $ Map.fromList newInputs + -- Updating proposing redeemers + proposals <- viewTweak txSkelProposalsL + newProposals <- forM proposals $ \prop -> case preview (txSkelProposalMConstitutionAT % _Just) prop of Nothing -> return prop - Just rs -> flip (set (txSkelProposalMConstitutionAT % _Just)) prop <$> updateRedeemedScript inputs rs - newWithdrawals <- forM (view (txSkelWithdrawalsL % txSkelWithdrawalsListI) txSkel) $ + Just rs -> flip (set (txSkelProposalMConstitutionAT % _Just)) prop <$> updateRedeemedScript inputsKeys rs + setTweak txSkelProposalsL newProposals + -- Updating widrawing redeemers + withdrawals <- viewTweak $ txSkelWithdrawalsL % txSkelWithdrawalsListI + newWithdrawals <- forM withdrawals $ \withdrawal@(Withdrawal user lv) -> case preview userEitherScriptP user of Nothing -> return withdrawal - Just urs -> (`Withdrawal` lv) . review userEitherScriptP <$> updateRedeemedScript inputs urs - return $ - txSkel - & txSkelMintsL - % txSkelMintsListI - .~ newMints - & txSkelInsL - .~ Map.fromList newInputs - & txSkelProposalsL - .~ newProposals - & txSkelWithdrawalsL - % txSkelWithdrawalsListI - .~ newWithdrawals + Just urs -> (`Withdrawal` lv) . review userEitherScriptP <$> updateRedeemedScript inputsKeys urs + setTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI) newWithdrawals -- * Auto filling min ada amounts -- | Compute the required minimal ADA for a given output -getTxSkelOutMinAda :: (MonadBlockChainBalancing m) => TxSkelOut -> m Integer +getTxSkelOutMinAda :: + (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) => + TxSkelOut -> + Sem effs Integer getTxSkelOutMinAda txSkelOut = do params <- Emulator.pEmulatorPParams <$> getParams Cardano.unCoin @@ -136,7 +159,11 @@ getTxSkelOutMinAda txSkelOut = do -- required ada. If the previous quantity of ADA was sufficient, it remains -- unchanged. This can require a few iterations to converge, as the added ADA -- will increase the size of the UTXO which in turn might need more ADA. -toTxSkelOutWithMinAda :: (MonadBlockChainBalancing m) => TxSkelOut -> m TxSkelOut +toTxSkelOutWithMinAda :: + forall effs. + (Members '[MockChainRead, MockChainLog, Error Ledger.ToCardanoError] effs) => + TxSkelOut -> + Sem effs TxSkelOut -- The auto adjustment is disabled so nothing is done here toTxSkelOutWithMinAda txSkelOut@((^. txSkelOutValueAutoAdjustL) -> False) = return txSkelOut -- The auto adjustment is enabled @@ -147,7 +174,7 @@ toTxSkelOutWithMinAda txSkelOut = do when (originalAda /= updatedAda) $ logEvent $ MCLogAdjustedTxSkelOut txSkelOut updatedAda return txSkelOut' where - go :: (MonadBlockChainBalancing m) => TxSkelOut -> m TxSkelOut + go :: TxSkelOut -> Sem effs TxSkelOut go skelOut = do -- Computing the required minimal amount of ADA in this output requiredAda <- getTxSkelOutMinAda skelOut @@ -160,5 +187,10 @@ toTxSkelOutWithMinAda txSkelOut = do -- | This goes through all the `TxSkelOut`s of the given skeleton and updates -- their ada value when requested by the user and required by the protocol -- parameters. Logs an event whenever such a change occurs. -autoFillMinAda :: (MonadBlockChainBalancing m) => TxSkel -> m TxSkel -autoFillMinAda skel = (\x -> skel & txSkelOutsL .~ x) <$> forM (skel ^. txSkelOutsL) toTxSkelOutWithMinAda +autoFillMinAda :: + (Members '[Tweak, MockChainRead, MockChainLog, Error Ledger.ToCardanoError] effs) => + Sem effs () +autoFillMinAda = do + outputs <- viewTweak txSkelOutsL + newOutputs <- forM outputs toTxSkelOutWithMinAda + setTweak txSkelOutsL newOutputs diff --git a/src/Cooked/MockChain/Balancing.hs b/src/Cooked/MockChain/Balancing.hs index 726088ddb..3655a5d2e 100644 --- a/src/Cooked/MockChain/Balancing.hs +++ b/src/Cooked/MockChain/Balancing.hs @@ -15,10 +15,12 @@ import Cardano.Ledger.Conway.PParams qualified as Conway import Cardano.Ledger.Plutus.ExUnits qualified as Cardano import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad -import Control.Monad.Except import Cooked.MockChain.AutoFilling -import Cooked.MockChain.BlockChain +import Cooked.MockChain.Common +import Cooked.MockChain.Error import Cooked.MockChain.GenerateTx.Body +import Cooked.MockChain.Log +import Cooked.MockChain.Read import Cooked.MockChain.UtxoSearch import Cooked.Skeleton import Data.Bifunctor @@ -27,6 +29,7 @@ import Data.List (find, partition, sortBy) import Data.Map qualified as Map import Data.Ratio qualified as Rat import Data.Set qualified as Set +import Ledger.Tx qualified as Ledger import Lens.Micro.Extras qualified as MicroLens import Optics.Core import Optics.Core.Extras @@ -35,6 +38,9 @@ import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api import PlutusTx.Prelude qualified as PlutusTx +import Polysemy +import Polysemy.Error +import Polysemy.Fail -- | This is the main entry point of our balancing mechanism. This function -- takes a skeleton and returns a (possibly) balanced skeleton alongside the @@ -42,14 +48,17 @@ import PlutusTx.Prelude qualified as PlutusTx -- be empty when no script is involved in the transaction. The options from the -- skeleton control whether it should be balanced, and how to compute its -- associated elements. -balanceTxSkel :: (MonadBlockChainBalancing m) => TxSkel -> m (TxSkel, Fee, Collaterals) +balanceTxSkel :: + (Members '[MockChainRead, MockChainLog, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) => + TxSkel -> + Sem effs (TxSkel, Fee, Collaterals) balanceTxSkel skelUnbal@TxSkel {..} = do -- We retrieve the possible balancing user. Any extra payment will be -- redirected to them, and utxos will be taken from their user if associated -- with the BalancingUtxosFromBalancingUser policy balancingUser <- case txSkelOptBalancingPolicy txSkelOpts of BalanceWithFirstSignatory -> case txSkelSignatories of - [] -> throwError $ MCEMissingBalancingUser "The list of signatories is empty, but the balancing user is supposed to be the first signatory." + [] -> throw $ MCEMissingBalancingUser "The list of signatories is empty, but the balancing user is supposed to be the first signatory." bw : _ -> return $ Just $ UserPubKey $ view txSkelSignatoryPubKeyHashL bw BalanceWith bUser -> return $ Just $ UserPubKey bUser DoNotBalance -> return Nothing @@ -74,10 +83,12 @@ balanceTxSkel skelUnbal@TxSkel {..} = do (True, CollateralUtxosFromUser cUser) -> logEvent (MCLogUnusedCollaterals $ Left $ UserPubKey cUser) >> return Nothing (True, CollateralUtxosFromBalancingUser) -> return Nothing (False, CollateralUtxosFromSet utxos rUser) -> return $ Just (utxos, UserPubKey rUser) - (False, CollateralUtxosFromUser cUser) -> Just . (,UserPubKey cUser) . Set.fromList . map fst <$> runUtxoSearch (onlyValueOutputsAtSearch $ Script.toPubKeyHash cUser) + (False, CollateralUtxosFromUser (Script.toPubKeyHash -> cUser)) -> + Just . (,UserPubKey cUser) . Set.fromList + <$> getTxOutRefs (utxosAtSearch cUser ensureOnlyValueOutputs) (False, CollateralUtxosFromBalancingUser) -> case balancingUser of - Nothing -> throwError $ MCEMissingBalancingUser "Collateral utxos should be taken from the balancing user, but it does not exist." - Just bUser -> Just . (,bUser) . Set.fromList . map fst <$> runUtxoSearch (onlyValueOutputsAtSearch bUser) + Nothing -> throw $ MCEMissingBalancingUser "Collateral utxos should be taken from the balancing user, but it does not exist." + Just bUser -> Just . (,bUser) . Set.fromList <$> getTxOutRefs (utxosAtSearch bUser ensureOnlyValueOutputs) -- At this point, the presence (or absence) of balancing user dictates -- whether the transaction should be automatically balanced or not. @@ -94,10 +105,10 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- utxos based on the associated policy balancingUtxos <- case txSkelOptBalancingUtxos txSkelOpts of - BalancingUtxosFromBalancingUser -> runUtxoSearch $ onlyValueOutputsAtSearch bUser + BalancingUtxosFromBalancingUser -> getTxOutRefsAndOutputs $ utxosAtSearch bUser ensureOnlyValueOutputs BalancingUtxosFromSet utxos -> -- We resolve the given set of utxos - runUtxoSearch (txSkelOutByRefSearch (Set.toList utxos)) + getTxOutRefsAndOutputs (txSkelOutByRefSearch' (Set.toList utxos)) -- We filter out those belonging to scripts, while throwing a -- warning if any was actually discarded. >>= filterAndWarn (is (txSkelOutOwnerL % userPubKeyHashAT) . snd) "They belong to scripts." @@ -125,7 +136,7 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- | This computes the minimum and maximum possible fee a transaction can cost -- based on the current protocol parameters and its number of scripts. -getMinAndMaxFee :: (MonadBlockChainBalancing m) => Fee -> m (Fee, Fee) +getMinAndMaxFee :: (Member MockChainRead effs) => Fee -> Sem effs (Fee, Fee) getMinAndMaxFee nbOfScripts = do -- We retrieve the necessary parameters to compute the maximum possible fee -- for a transaction. There are quite a few of them. @@ -154,10 +165,18 @@ getMinAndMaxFee nbOfScripts = do -- | Computes optimal fee for a given skeleton and balances it around those fees. -- This uses a dichotomic search for an optimal "balanceable around" fee. -computeFeeAndBalance :: (MonadBlockChainBalancing m) => Peer -> Fee -> Fee -> Utxos -> Collaterals -> TxSkel -> m (TxSkel, Fee, Collaterals) +computeFeeAndBalance :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) => + Peer -> + Fee -> + Fee -> + Utxos -> + Collaterals -> + TxSkel -> + Sem effs (TxSkel, Fee, Collaterals) computeFeeAndBalance _ minFee maxFee _ _ _ | minFee > maxFee = - throwError $ FailWith "Unreachable case, please report a bug at https://github.com/tweag/cooked-validators/issues" + fail "Unreachable case, please report a bug at https://github.com/tweag/cooked-validators/issues" computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals skel | minFee == maxFee = do -- The fee interval is reduced to a single element, we balance around it @@ -168,7 +187,7 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske -- The fee interval is larger than a single element. We attempt to balance -- around its central point, which can fail due to missing value in -- balancing utxos or collateral utxos. - attemptedBalancing <- catchError + attemptedBalancing <- catch (Just <$> attemptBalancingAndCollaterals balancingUser balancingUtxos fee mCollaterals skel) $ \case -- If it fails, and the remaining fee interval is not reduced to the @@ -177,7 +196,7 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske -- fails and we spread the error. MCEUnbalanceable {} | fee - minFee > 0 -> return Nothing MCENoSuitableCollateral {} | fee - minFee > 0 -> return Nothing - err -> throwError err + err -> throw err (newMinFee, newMaxFee) <- case attemptedBalancing of -- The skeleton was not balanceable, we try strictly smaller fee @@ -208,7 +227,14 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske -- | Helper function to group the two real steps of the balancing: balance a -- skeleton around a given fee, and compute the associated collateral inputs -attemptBalancingAndCollaterals :: (MonadBlockChainBalancing m) => Peer -> Utxos -> Fee -> Collaterals -> TxSkel -> m (Collaterals, TxSkel) +attemptBalancingAndCollaterals :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + Peer -> + Utxos -> + Fee -> + Collaterals -> + TxSkel -> + Sem effs (Collaterals, TxSkel) attemptBalancingAndCollaterals balancingUser balancingUtxos fee mCollaterals skel = do adjustedCollateralIns <- collateralsFromFees fee mCollaterals attemptedSkel <- computeBalancedTxSkel balancingUser balancingUtxos skel fee @@ -218,7 +244,12 @@ attemptBalancingAndCollaterals balancingUser balancingUtxos fee mCollaterals ske -- accounting for the ratio to respect between fees and total collaterals, the -- min ada requirements in the associated return collateral and the maximum -- number of collateral inputs authorized by protocol parameters. -collateralInsFromFees :: (MonadBlockChainBalancing m) => Fee -> CollateralIns -> Peer -> m CollateralIns +collateralInsFromFees :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + Fee -> + CollateralIns -> + Peer -> + Sem effs CollateralIns collateralInsFromFees fee collateralIns returnCollateralUser = do -- We retrieve the protocal parameters params <- Emulator.pEmulatorPParams <$> getParams @@ -232,7 +263,7 @@ collateralInsFromFees fee collateralIns returnCollateralUser = do -- add one because of ledger requirement which seem to round up this value. let totalCollateral = Script.lovelace . (+ 1) . (`div` 100) . (* percentage) $ fee -- Collateral tx outputs sorted by decreasing ada amount - collateralTxOuts <- runUtxoSearch (txSkelOutByRefSearch $ Set.toList collateralIns) + collateralTxOuts <- getTxOutRefsAndOutputs $ txSkelOutByRefSearch' $ Set.toList collateralIns -- Candidate subsets of utxos to be used as collaterals let candidatesRaw = reachValue collateralTxOuts totalCollateral nbMax -- Preparing a possible collateral error @@ -241,7 +272,11 @@ collateralInsFromFees fee collateralIns returnCollateralUser = do Set.fromList . fst <$> getOptimalCandidate candidatesRaw returnCollateralUser noSuitableCollateralError -- | This adjusts collateral inputs when necessary -collateralsFromFees :: (MonadBlockChainBalancing m) => Fee -> Collaterals -> m Collaterals +collateralsFromFees :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + Fee -> + Collaterals -> + Sem effs Collaterals collateralsFromFees _ Nothing = return Nothing collateralsFromFees fee (Just (collateralIns, returnCollateralUser)) = Just . (,returnCollateralUser) <$> collateralInsFromFees fee collateralIns returnCollateralUser @@ -251,7 +286,11 @@ collateralsFromFees fee (Just (collateralIns, returnCollateralUser)) = -- stops when the target is reached, not adding superfluous UTxOs. Despite -- optimizations, this function is theoretically in 2^n where n is the number of -- candidate UTxOs. Use with caution. -reachValue :: Utxos -> Api.Value -> Fee -> [(Utxos, Api.Value)] +reachValue :: + Utxos -> + Api.Value -> + Fee -> + [(Utxos, Api.Value)] -- Target is smaller than the empty value (which means in only contains negative -- entries), we stop looking as adding more elements would be superfluous. reachValue _ target _ | target `Api.leq` mempty = [([], PlutusTx.negate target)] @@ -276,7 +315,12 @@ reachValue (h@(_, view txSkelOutValueL -> hVal) : t) target maxEls = -- | A helper function to grab an optimal candidate in terms of having a minimal -- enough amount of ada to sustain itself meant to be used after calling -- `reachValue`. This throws an error when there are no suitable candidates. -getOptimalCandidate :: (MonadBlockChainBalancing m) => [(Utxos, Api.Value)] -> Peer -> MockChainError -> m ([Api.TxOutRef], Api.Value) +getOptimalCandidate :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + [(Utxos, Api.Value)] -> + Peer -> + MockChainError -> + Sem effs ([Api.TxOutRef], Api.Value) getOptimalCandidate candidates paymentTarget mceError = do -- We decorate the candidates with their current ada and min ada requirements candidatesDecorated <- forM candidates $ \(output, val) -> @@ -285,12 +329,17 @@ getOptimalCandidate candidates paymentTarget mceError = do let candidatesFiltered = [(minLv, (fst <$> l, val)) | (l, val, Api.Lovelace lv, minLv) <- candidatesDecorated, minLv <= lv] case sortBy (compare `on` fst) candidatesFiltered of -- If the list of candidates is empty, we throw an error - [] -> throwError mceError + [] -> throw mceError (_, ret) : _ -> return ret -- | This function was originally inspired by -- https://github.com/input-output-hk/plutus-apps/blob/d4255f05477fd8477ee9673e850ebb9ebb8c9657/plutus-ledger/src/Ledger/Fee.hs#L19 -estimateTxSkelFee :: (MonadBlockChainBalancing m) => TxSkel -> Fee -> Collaterals -> m Fee +estimateTxSkelFee :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) => + TxSkel -> + Fee -> + Collaterals -> + Sem effs Fee estimateTxSkelFee skel fee mCollaterals = do -- We retrieve the necessary data to generate the transaction body params <- getParams @@ -307,7 +356,13 @@ estimateTxSkelFee skel fee mCollaterals = do -- | 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 + withdrawn value = output value + burned value + fee + deposits -computeBalancedTxSkel :: (MonadBlockChainBalancing m) => Peer -> Utxos -> TxSkel -> Fee -> m TxSkel +computeBalancedTxSkel :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + Peer -> + Utxos -> + TxSkel -> + Fee -> + Sem effs TxSkel computeBalancedTxSkel balancingUser balancingUtxos txSkel@TxSkel {..} (Script.lovelace -> feeValue) = do -- We compute the necessary values from the skeleton that are part of the -- equation, except for the `feeValue` which we already have. diff --git a/src/Cooked/MockChain/BlockChain.hs b/src/Cooked/MockChain/BlockChain.hs deleted file mode 100644 index 9264ef7ce..000000000 --- a/src/Cooked/MockChain/BlockChain.hs +++ /dev/null @@ -1,494 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | This modules provides a specification for our blockchain monads, in three --- layers: --- --- 1. MonadBlockChainBalancing provides what's needing for balancing purposes --- --- 2. MonadBlockChainWithoutValidation adds up remaining primitives without --- transaction validation --- --- 3. MonadBlockChain concludes with the addition of transaction validation, --- thus modifying the internal index of outputs --- --- In addition, you will find here many helpers functions which can be derived --- from the core definition of our blockchain. -module Cooked.MockChain.BlockChain - ( Fee, - CollateralIns, - Collaterals, - Utxos, - MockChainError (..), - MockChainLogEntry (..), - MonadBlockChainBalancing (..), - MonadBlockChainWithoutValidation (..), - MonadBlockChain (..), - AsTrans (..), - currentMSRange, - utxosFromCardanoTx, - currentSlot, - awaitSlot, - getEnclosingSlot, - awaitEnclosingSlot, - waitNMSFromSlotLowerBound, - waitNMSFromSlotUpperBound, - slotRangeBefore, - slotRangeAfter, - slotToMSRange, - txSkelInputScripts, - txSkelInputValue, - lookupUtxos, - validateTxSkel', - validateTxSkel_, - txSkelDepositedValueInProposals, - govActionDeposit, - defineM, - txSkelAllScripts, - previewByRef, - viewByRef, - dRepDeposit, - stakeAddressDeposit, - stakePoolDeposit, - txSkelDepositedValueInCertificates, - ) -where - -import Cardano.Api.Ledger qualified as Cardano -import Cardano.Ledger.Conway.Core qualified as Conway -import Cardano.Node.Emulator qualified as Emulator -import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Control.Lens qualified as Lens -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans.Control -import Control.Monad.Writer -import Cooked.Pretty.Hashable -import Cooked.Pretty.Plutus () -import Cooked.Skeleton -import Data.Kind -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe -import Data.Set (Set) -import Ledger.Index qualified as Ledger -import Ledger.Slot qualified as Ledger -import Ledger.Tx qualified as Ledger -import Ledger.Tx.CardanoAPI qualified as Ledger -import ListT -import Optics.Core -import Plutus.Script.Utils.Address qualified as Script -import Plutus.Script.Utils.Scripts qualified as Script -import PlutusLedgerApi.V3 qualified as Api - --- * Type aliases - --- | An alias for Integers used as fees -type Fee = Integer - --- | An alias for sets of utxos used as collateral inputs -type CollateralIns = Set Api.TxOutRef - --- | An alias for optional pairs of collateral inputs and return collateral peer -type Collaterals = Maybe (CollateralIns, Peer) - --- | An alias for lists of utxos with their associated output -type Utxos = [(Api.TxOutRef, TxSkelOut)] - --- * Mockchain errors - --- | Errors that can be produced by the blockchain -data MockChainError - = -- | Validation errors, either in Phase 1 or Phase 2 - MCEValidationError Ledger.ValidationPhase Ledger.ValidationError - | -- | The balancing user does not have enough funds - MCEUnbalanceable Peer Api.Value - | -- | The balancing user is required but missing - MCEMissingBalancingUser String - | -- | No suitable collateral could be associated with a skeleton - MCENoSuitableCollateral Integer Integer Api.Value - | -- | Translating a skeleton element to its Cardano counterpart failed - MCEToCardanoError String Ledger.ToCardanoError - | -- | The required reference script is missing from a witness utxo - MCEWrongReferenceScriptError Api.TxOutRef Api.ScriptHash (Maybe Api.ScriptHash) - | -- | A UTxO is missing from the mockchain state - MCEUnknownOutRef Api.TxOutRef - | -- | A jump in time would result in a past slot - MCEPastSlot Ledger.Slot Ledger.Slot - | -- | An attempt to invoke an unsupported feature has been made - MCEUnsupportedFeature String - | -- | Used to provide 'MonadFail' instances. - FailWith String - deriving (Show, Eq) - --- * Mockchain logs - --- | This represents the specific events that should be logged when processing --- transactions. If a new kind of event arises, then a new constructor should be --- provided here. -data MockChainLogEntry - = -- | Logging a Skeleton as it is submitted by the user. - MCLogSubmittedTxSkel TxSkel - | -- | Logging a Skeleton as it has been adjusted by the balancing mechanism, - -- alongside fee, and possible collateral utxos and return collateral user. - MCLogAdjustedTxSkel TxSkel Fee Collaterals - | -- | Logging the successful validation of a new transaction, with its id and - -- number of produced outputs. - MCLogNewTx Api.TxId Integer - | -- | Logging the fact that utxos provided by the user for balancing have to be - -- discarded for a specific reason. - MCLogDiscardedUtxos Integer String - | -- | Logging the fact that utxos provided as collaterals will not be used - -- because the transaction does not involve scripts. There are 2 cases, - -- depending on whether the user has provided an explicit user or a set of - -- utxos to be used as collaterals. - MCLogUnusedCollaterals (Either Peer CollateralIns) - | -- | Logging the automatic addition of a reference script - MCLogAddedReferenceScript TxSkelRedeemer Api.TxOutRef Script.ScriptHash - | -- | Logging the automatic addition of a withdrawal amount - MCLogAutoFilledWithdrawalAmount Api.Credential Api.Lovelace - | -- | Logging the automatic addition of the constitution script - MCLogAutoFilledConstitution Api.ScriptHash - | -- | Logging the automatic adjusment of a min ada amount - MCLogAdjustedTxSkelOut TxSkelOut Api.Lovelace - deriving (Show) - --- * Mockchain layers - --- | This is the first layer of our blockchain, which provides the minimal --- subset of primitives required to perform balancing. -class (MonadFail m, MonadError MockChainError m) => MonadBlockChainBalancing m where - -- | Returns the emulator parameters, including protocol parameters - getParams :: m Emulator.Params - - -- | Returns a list of all UTxOs at a certain address. - utxosAt :: (Script.ToAddress a) => a -> m Utxos - - -- | Returns an output given a reference to it. If the output does not exist, - -- throws a 'MCEUnknownOutRef' error. - txSkelOutByRef :: Api.TxOutRef -> m TxSkelOut - - -- | Logs an event that occured during a BlockChain run - logEvent :: MockChainLogEntry -> m () - --- | This is the second layer of our blockchain, which provides all the other --- blockchain primitives not needed for balancing, except transaction --- validation. This layers is the one where --- 'Cooked.MockChain.Tweak.Common.Tweak's are plugged to. -class (MonadBlockChainBalancing m) => MonadBlockChainWithoutValidation m where - -- | Returns a list of all currently known outputs. - allUtxos :: m Utxos - - -- | Updates parameters - setParams :: Emulator.Params -> m () - - -- | Wait a certain amount of slot. Throws 'MCEPastSlot' if the input integer - -- is negative. Returns the slot after jumping in time. - waitNSlots :: (Integral i) => i -> m Ledger.Slot - - -- | Binds a hashable quantity of type @a@ to a variable in the mockchain, - -- while registering its alias for printing purposes. - define :: (ToHash a) => String -> a -> m a - - -- | Sets the current script to act as the official constitution script - setConstitutionScript :: (ToVScript s) => s -> m () - - -- | Gets the current official constitution script - getConstitutionScript :: m (Maybe VScript) - - -- | Gets the current reward associated with a credential - getCurrentReward :: (Script.ToCredential c) => c -> m (Maybe Api.Lovelace) - --- | The final layer of our blockchain, adding transaction validation to the --- mix. This is the only primitive that actually modifies the ledger state. -class (MonadBlockChainWithoutValidation m) => MonadBlockChain m where - -- | Generates, balances and validates a transaction from a skeleton. It - -- returns the validated transaction and updates the state of the - -- blockchain. - validateTxSkel :: TxSkel -> m Ledger.CardanoTx - - -- | Forces the generation of utxos corresponding to certain 'TxSkelOut' - forceOutputs :: [TxSkelOut] -> m [Api.TxOutRef] - --- * Mockchain helpers - --- | Retrieves an output and views a specific element out of it -viewByRef :: (MonadBlockChainBalancing m, Is g A_Getter) => Optic' g is TxSkelOut c -> Api.TxOutRef -> m c -viewByRef optic = (view optic <$>) . txSkelOutByRef - --- | Retrieves an output and previews a specific element out of it -previewByRef :: (MonadBlockChainBalancing m, Is af An_AffineFold) => Optic' af is TxSkelOut c -> Api.TxOutRef -> m (Maybe c) -previewByRef optic = (preview optic <$>) . txSkelOutByRef - --- | Validates a skeleton, and retuns the ordered list of produced output --- references -validateTxSkel' :: (MonadBlockChain m) => TxSkel -> m [Api.TxOutRef] -validateTxSkel' = ((fmap fst <$>) . utxosFromCardanoTx) <=< validateTxSkel - --- | Validates a skeleton, and erases the outputs -validateTxSkel_ :: (MonadBlockChain m) => TxSkel -> m () -validateTxSkel_ = void . validateTxSkel - --- | Retrieves the ordered list of outputs of the given "CardanoTx". --- --- This is useful when writing endpoints and/or traces to fetch utxos of --- interest right from the start and avoid querying the chain for them --- afterwards using 'allUtxos' or similar functions. -utxosFromCardanoTx :: (MonadBlockChainBalancing m) => Ledger.CardanoTx -> m [(Api.TxOutRef, TxSkelOut)] -utxosFromCardanoTx = - mapM (\txOutRef -> (txOutRef,) <$> txSkelOutByRef txOutRef) - . fmap (Ledger.fromCardanoTxIn . snd) - . Ledger.getCardanoTxOutRefs - --- | Like 'define', but binds the result of a monadic computation instead -defineM :: (MonadBlockChainWithoutValidation m, ToHash a) => String -> m a -> m a -defineM name = (define name =<<) - --- | Retrieves the required governance action deposit amount -govActionDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace -govActionDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppGovActionDepositL . Emulator.emulatorPParams <$> getParams - --- | Retrieves the required drep deposit amount -dRepDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace -dRepDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppDRepDepositL . Emulator.emulatorPParams <$> getParams - --- | Retrieves the required stake address deposit amount -stakeAddressDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace -stakeAddressDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppKeyDepositL . Emulator.emulatorPParams <$> getParams - --- | Retrieves the required stake pool deposit amount -stakePoolDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace -stakePoolDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppPoolDepositL . Emulator.emulatorPParams <$> getParams - --- | Retrieves the total amount of lovelace deposited in proposals in this --- skeleton (equal to `govActionDeposit` times the number of proposals). -txSkelDepositedValueInProposals :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace -txSkelDepositedValueInProposals TxSkel {txSkelProposals} = Api.Lovelace . (toInteger (length txSkelProposals) *) . Api.getLovelace <$> govActionDeposit - --- | Retrieves the total amount of lovelace deposited in certificates in this --- skeleton. Note that unregistering a staking address or a dRep lead to a --- negative deposit (a withdrawal, in fact) which means this function can return --- a negative amount of lovelace, which is intended. The deposited amounts are --- dictated by the current protocol parameters, and computed as such. -txSkelDepositedValueInCertificates :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace -txSkelDepositedValueInCertificates txSkel = do - sDep <- stakeAddressDeposit - dDep <- dRepDeposit - pDep <- stakePoolDeposit - return $ - foldOf - ( txSkelCertificatesL - % traversed - % to - ( \case - TxSkelCertificate _ StakingRegister {} -> sDep - TxSkelCertificate _ StakingRegisterDelegate {} -> sDep - TxSkelCertificate _ StakingUnRegister {} -> -sDep - TxSkelCertificate _ DRepRegister {} -> dDep - TxSkelCertificate _ DRepUnRegister {} -> -dDep - TxSkelCertificate _ PoolRegister {} -> pDep - -- There is no special case for 'PoolRetire' because the deposit - -- is given back to the reward account. - _ -> Api.Lovelace 0 - ) - ) - txSkel - --- | Returns all scripts which guard transaction inputs -txSkelInputScripts :: (MonadBlockChainBalancing m) => TxSkel -> m [VScript] -txSkelInputScripts = fmap catMaybes . mapM (previewByRef (txSkelOutOwnerL % userVScriptAT)) . Map.keys . txSkelIns - --- | Returns all scripts involved in this 'TxSkel' -txSkelAllScripts :: (MonadBlockChainBalancing m) => TxSkel -> m [VScript] -txSkelAllScripts txSkel = do - txSkelSpendingScripts <- txSkelInputScripts txSkel - return - ( txSkelMintingScripts txSkel - <> txSkelWithdrawingScripts txSkel - <> txSkelProposingScripts txSkel - <> txSkelCertifyingScripts txSkel - <> txSkelSpendingScripts - ) - --- | Go through all of the 'Api.TxOutRef's in the list and look them up in the --- state of the blockchain, throwing an error if one of them cannot be resolved. -lookupUtxos :: (MonadBlockChainBalancing m) => [Api.TxOutRef] -> m (Map Api.TxOutRef TxSkelOut) -lookupUtxos = foldM (\m oRef -> flip (Map.insert oRef) m <$> txSkelOutByRef oRef) Map.empty - --- | look up the UTxOs the transaction consumes, and sum their values. -txSkelInputValue :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Value -txSkelInputValue = fmap mconcat . mapM (viewByRef txSkelOutValueL) . Map.keys . txSkelIns - --- * Slot and Time Management - --- $slotandtime --- #slotandtime# --- --- Slots are integers that monotonically increase and model the passage of --- time. By looking at the current slot, a validator gets to know that it is --- being executed within a certain window of wall-clock time. Things can get --- annoying pretty fast when trying to mock traces and trying to exercise --- certain branches of certain validators; make sure you also read the docs on --- 'autoSlotIncrease' to be able to simulate sending transactions in parallel. - --- | Returns the current slot number -currentSlot :: (MonadBlockChainWithoutValidation m) => m Ledger.Slot -currentSlot = waitNSlots @_ @Int 0 - --- | Wait for a certain slot, or throws an error if the slot is already past -awaitSlot :: (MonadBlockChainWithoutValidation m, Integral i) => i -> m Ledger.Slot -awaitSlot slot = currentSlot >>= waitNSlots . (slot -) . fromIntegral - --- | Returns the closed ms interval corresponding to the current slot -currentMSRange :: (MonadBlockChainWithoutValidation m) => m (Api.POSIXTime, Api.POSIXTime) -currentMSRange = slotToMSRange =<< currentSlot - --- | Returns the closed ms interval corresponding to the slot with the given --- number. It holds that --- --- > slotToMSRange (getEnclosingSlot t) == (a, b) ==> a <= t <= b --- --- and --- --- > slotToMSRange n == (a, b) ==> getEnclosingSlot a == n && getEnclosingSlot b == n --- --- and --- --- > slotToMSRange n == (a, b) ==> getEnclosingSlot (a-1) == n-1 && getEnclosingSlot (b+1) == n+1 -slotToMSRange :: (MonadBlockChainWithoutValidation m, Integral i) => i -> m (Api.POSIXTime, Api.POSIXTime) -slotToMSRange (fromIntegral -> slot) = do - slotConfig <- Emulator.pSlotConfig <$> getParams - case Emulator.slotToPOSIXTimeRange slotConfig slot of - Api.Interval - (Api.LowerBound (Api.Finite l) leftclosed) - (Api.UpperBound (Api.Finite r) rightclosed) -> - return - ( if leftclosed then l else l + 1, - if rightclosed then r else r - 1 - ) - _ -> fail "Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues" - --- | Return the slot that contains the given time. See 'slotToMSRange' for --- some satisfied equational properties. -getEnclosingSlot :: (MonadBlockChainWithoutValidation m) => Api.POSIXTime -> m Ledger.Slot -getEnclosingSlot t = (`Emulator.posixTimeToEnclosingSlot` t) . Emulator.pSlotConfig <$> getParams - --- | Waits until the current slot becomes greater or equal to the slot --- containing the given POSIX time. Note that that it might not wait for --- anything if the current slot is large enough. -awaitEnclosingSlot :: (MonadBlockChainWithoutValidation m) => Api.POSIXTime -> m Ledger.Slot -awaitEnclosingSlot = awaitSlot <=< getEnclosingSlot - --- | Wait a given number of ms from the lower bound of the current slot and --- returns the current slot after waiting. -waitNMSFromSlotLowerBound :: (MonadBlockChainWithoutValidation m, Integral i) => i -> m Ledger.Slot -waitNMSFromSlotLowerBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . fst - --- | Wait a given number of ms from the upper bound of the current slot and --- returns the current slot after waiting. -waitNMSFromSlotUpperBound :: (MonadBlockChainWithoutValidation m, Integral i) => i -> m Ledger.Slot -waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . snd - --- | The infinite range of slots ending before or at the given time -slotRangeBefore :: (MonadBlockChainWithoutValidation m) => Api.POSIXTime -> m Ledger.SlotRange -slotRangeBefore t = do - n <- getEnclosingSlot t - (_, b) <- slotToMSRange n - -- If the given time @t@ happens to be the last ms of its slot, we can include - -- the whole slot. Otherwise, the only way to be sure that the returned slot - -- range contains no time after @t@ is to go to the preceding slot. - return $ Api.to $ if t == b then n else n - 1 - --- | The infinite range of slots starting after or at the given time -slotRangeAfter :: (MonadBlockChainWithoutValidation m) => Api.POSIXTime -> m Ledger.SlotRange -slotRangeAfter t = do - n <- getEnclosingSlot t - (a, _) <- slotToMSRange n - return $ Api.from $ if t == a then n else n + 1 - --- * Deriving further 'MonadBlockChain' instances - --- | A newtype wrapper to be used with '-XDerivingVia' to derive instances of --- 'MonadBlockChain' for any 'MonadTransControl'. --- --- For example, to derive 'MonadBlockChain m => MonadBlockChain (ReaderT r m)', --- you'd write --- --- > deriving via (AsTrans (ReaderT r) m) instance MonadBlockChain m => MonadBlockChain (ReaderT r m) --- --- and avoid the trouble of defining all the class methods yourself. -newtype AsTrans t (m :: Type -> Type) a = AsTrans {getTrans :: t m a} - deriving newtype (Functor, Applicative, Monad, MonadTrans, MonadTransControl) - -instance (MonadTrans t, MonadFail m, Monad (t m)) => MonadFail (AsTrans t m) where - fail = lift . fail - -instance (MonadTransControl t, MonadError MockChainError m, Monad (t m)) => MonadError MockChainError (AsTrans t m) where - throwError = lift . throwError - catchError act f = liftWith (\run -> catchError (run act) (run . f)) >>= restoreT . return - -instance (MonadTrans t, MonadBlockChainBalancing m, Monad (t m), MonadError MockChainError (AsTrans t m)) => MonadBlockChainBalancing (AsTrans t m) where - getParams = lift getParams - utxosAt = lift . utxosAt - txSkelOutByRef = lift . txSkelOutByRef - logEvent = lift . logEvent - -instance (MonadTrans t, MonadBlockChainWithoutValidation m, Monad (t m), MonadError MockChainError (AsTrans t m)) => MonadBlockChainWithoutValidation (AsTrans t m) where - allUtxos = lift allUtxos - setParams = lift . setParams - waitNSlots = lift . waitNSlots - define name = lift . define name - setConstitutionScript = lift . setConstitutionScript - getConstitutionScript = lift getConstitutionScript - getCurrentReward = lift . getCurrentReward - -instance (MonadTrans t, MonadBlockChain m, MonadBlockChainWithoutValidation (AsTrans t m)) => MonadBlockChain (AsTrans t m) where - validateTxSkel = lift . validateTxSkel - forceOutputs = lift . forceOutputs - -deriving via (AsTrans (WriterT w) m) instance (Monoid w, MonadBlockChainBalancing m) => MonadBlockChainBalancing (WriterT w m) - -deriving via (AsTrans (WriterT w) m) instance (Monoid w, MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (WriterT w m) - -deriving via (AsTrans (WriterT w) m) instance (Monoid w, MonadBlockChain m) => MonadBlockChain (WriterT w m) - -deriving via (AsTrans (ReaderT r) m) instance (MonadBlockChainBalancing m) => MonadBlockChainBalancing (ReaderT r m) - -deriving via (AsTrans (ReaderT r) m) instance (MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (ReaderT r m) - -deriving via (AsTrans (ReaderT r) m) instance (MonadBlockChain m) => MonadBlockChain (ReaderT r m) - -deriving via (AsTrans (StateT s) m) instance (MonadBlockChainBalancing m) => MonadBlockChainBalancing (StateT s m) - -deriving via (AsTrans (StateT s) m) instance (MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (StateT s m) - -deriving via (AsTrans (StateT s) m) instance (MonadBlockChain m) => MonadBlockChain (StateT s m) - --- 'ListT' has no 'MonadTransControl' instance, so the @deriving via ...@ --- machinery is unusable here. However, there is --- --- > MonadError e m => MonadError e (ListT m) --- --- so I decided to go with a bit of code duplication to implement the --- 'MonadBlockChainWithoutValidation' and 'MonadBlockChain' instances for --- 'ListT', instead of more black magic... - -instance (MonadBlockChainBalancing m) => MonadBlockChainBalancing (ListT m) where - getParams = lift getParams - utxosAt = lift . utxosAt - txSkelOutByRef = lift . txSkelOutByRef - logEvent = lift . logEvent - -instance (MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (ListT m) where - allUtxos = lift allUtxos - setParams = lift . setParams - waitNSlots = lift . waitNSlots - define name = lift . define name - setConstitutionScript = lift . setConstitutionScript - getConstitutionScript = lift getConstitutionScript - getCurrentReward = lift . getCurrentReward - -instance (MonadBlockChain m) => MonadBlockChain (ListT m) where - validateTxSkel = lift . validateTxSkel - forceOutputs = lift . forceOutputs diff --git a/src/Cooked/MockChain/Common.hs b/src/Cooked/MockChain/Common.hs new file mode 100644 index 000000000..1ad8b71cd --- /dev/null +++ b/src/Cooked/MockChain/Common.hs @@ -0,0 +1,32 @@ +-- | This module exposes some type aliases common to our MockChain library +module Cooked.MockChain.Common + ( -- * Type aliases + Fee, + CollateralIns, + Collaterals, + Utxo, + Utxos, + ) +where + +import Cooked.Skeleton.Output +import Cooked.Skeleton.User +import Data.Set (Set) +import PlutusLedgerApi.V3 qualified as Api + +-- * Type aliases + +-- | An alias for Integers used as fees +type Fee = Integer + +-- | An alias for sets of utxos used as collateral inputs +type CollateralIns = Set Api.TxOutRef + +-- | An alias for optional pairs of collateral inputs and return collateral peer +type Collaterals = Maybe (CollateralIns, Peer) + +-- | An alias for an output and its reference +type Utxo = (Api.TxOutRef, TxSkelOut) + +-- | An alias for lists of `Utxo` +type Utxos = [Utxo] diff --git a/src/Cooked/MockChain/Direct.hs b/src/Cooked/MockChain/Direct.hs deleted file mode 100644 index 5c5ed3294..000000000 --- a/src/Cooked/MockChain/Direct.hs +++ /dev/null @@ -1,383 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - --- | This module provides a direct (as opposed to 'Cooked.MockChain.Staged') --- implementation of the `MonadBlockChain` specification. This rely on the --- emulator from cardano-node-emulator for transaction validation, although we --- have our own internal state. This choice might be revised in the future. -module Cooked.MockChain.Direct where - -import Cardano.Api qualified as Cardano -import Cardano.Api.Ledger qualified as Cardano -import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Control.Applicative -import Control.Lens qualified as Lens -import Control.Monad -import Control.Monad.Except -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Monad.Writer -import Cooked.InitialDistribution -import Cooked.MockChain.AutoFilling -import Cooked.MockChain.Balancing -import Cooked.MockChain.BlockChain -import Cooked.MockChain.GenerateTx.Body -import Cooked.MockChain.GenerateTx.Output -import Cooked.MockChain.GenerateTx.Witness -import Cooked.MockChain.MockChainState -import Cooked.MockChain.UtxoState (UtxoState) -import Cooked.Pretty.Hashable -import Cooked.Skeleton -import Data.Coerce -import Data.Default -import Data.Map (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe -import Ledger.Index qualified as Ledger -import Ledger.Orphans () -import Ledger.Tx qualified as Ledger -import Ledger.Tx.CardanoAPI qualified as Ledger -import Optics.Core -import Plutus.Script.Utils.Address qualified as Script -import Plutus.Script.Utils.Scripts qualified as Script -import PlutusLedgerApi.V3 qualified as Api - --- * Direct Emulation - --- $mockchaindocstr --- --- The MockChainT monad provides a direct emulator; that is, it gives us a --- simple way to run a full validation process directly, without relying on a --- deployed node. While simulated, the validation is performed by the --- cardano-ledger code, thus ensuring similar results on the real chain. --- --- A 'MockChain': --- --- - stores and updates a 'MockChainState' --- --- - returns a 'UtxoState' when run --- --- - emits entries in a 'MockChainBook' - --- | This represents elements that can be emitted throughout a 'MockChain' --- run. These elements are either log entries corresponding to internal events --- worth logging, or aliases for hashables corresponding to elements users --- wishes to be properly displayed when printed with --- 'Cooked.Pretty.Class.PrettyCooked' -data MockChainBook where - MockChainBook :: - { -- | Log entries generated by cooked-validators - mcbJournal :: [MockChainLogEntry], - -- | Aliases stored by the user - mcbAliases :: Map Api.BuiltinByteString String - } -> - MockChainBook - -instance Semigroup MockChainBook where - MockChainBook j a <> MockChainBook j' a' = MockChainBook (j <> j') (a <> a') - -instance Monoid MockChainBook where - mempty = MockChainBook mempty mempty - --- | A 'MockChainT' builds up a stack of monads on top of a given monad @m@ to --- reflect the requirements of the simulation. It writes a 'MockChainBook', --- updates and reads from a 'MockChainState' and throws possible --- 'MockChainError's. -newtype MockChainT m a = MockChainT - {unMockChain :: (ExceptT MockChainError (StateT MockChainState (WriterT MockChainBook m))) a} - deriving newtype - ( Functor, - Applicative, - MonadState MockChainState, - MonadError MockChainError, - MonadWriter MockChainBook - ) - --- | Our 'MockChain' naturally instantiate the inner monad with 'Identity' -type MockChain = MockChainT Identity - --- | Custom monad instance made to increase the slot count automatically -instance (Monad m) => Monad (MockChainT m) where - return = pure - MockChainT x >>= f = MockChainT $ x >>= unMockChain . f - -instance (Monad m) => MonadFail (MockChainT m) where - fail = throwError . FailWith - -instance MonadTrans MockChainT where - lift = MockChainT . lift . lift . lift - -instance (Monad m, Alternative m) => Alternative (MockChainT m) where - empty = MockChainT $ ExceptT $ StateT $ const $ WriterT empty - (<|>) = combineMockChainT (<|>) - -instance (MonadPlus m) => MonadPlus (MockChainT m) where - mzero = lift mzero - mplus = combineMockChainT mplus - --- | Combines two 'MockChainT' together -combineMockChainT :: (forall a. m a -> m a -> m a) -> MockChainT m x -> MockChainT m x -> MockChainT m x -combineMockChainT f ma mb = MockChainT $ - ExceptT $ - StateT $ \s -> - let resA = runWriterT $ runStateT (runExceptT (unMockChain ma)) s - resB = runWriterT $ runStateT (runExceptT (unMockChain mb)) s - in WriterT $ f resA resB - --- * 'MockChain' return types - --- | The returned type when running a 'MockChainT'. This is both a reorganizing --- and filtering of the natural returned type @((Either MockChainError a, --- MockChainState), MockChainBook)@, which is much easier to query. -data MockChainReturn a where - MockChainReturn :: - { -- | The value returned by the computation, or an error - mcrValue :: Either MockChainError a, - -- | The outputs at the end of the run - mcrOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), - -- | The 'UtxoState' at the end of the run - mcrUtxoState :: UtxoState, - -- | The final journal emitted during the run - mcrJournal :: [MockChainLogEntry], - -- | The map of aliases defined during the run - mcrAliases :: Map Api.BuiltinByteString String - } -> - MockChainReturn a - deriving (Functor) - --- | Raw return type of running a 'MockChainT' -type RawMockChainReturn a = ((Either MockChainError a, MockChainState), MockChainBook) - --- | Building a 'MockChainReturn' from a 'RawMockChainReturn' -unRawMockChainReturn :: RawMockChainReturn a -> MockChainReturn a -unRawMockChainReturn ((val, st), MockChainBook journal aliases) = MockChainReturn val (mcstOutputs st) (mcstToUtxoState st) journal aliases - --- * 'MockChain' configurations - --- | Configuration to run a 'MockChainT' -data MockChainConf a b where - MockChainConf :: - { -- | The initial state from which to run the 'MockChainT' - mccInitialState :: MockChainState, - -- | The initial payments to issue in the run - mccInitialDistribution :: InitialDistribution, - -- | The function to apply on the result of the run - mccFunOnResult :: RawMockChainReturn a -> b - } -> - MockChainConf a b - --- | A configuration with a default initial state, a given distribution, --- returning a 'MockChainReturn' -initDistConf :: InitialDistribution -> MockChainConf a (MockChainReturn a) -initDistConf i0 = MockChainConf def i0 unRawMockChainReturn - --- | A configuration with a given initial 'MockChainState', a default initial --- distribution, returning the final 'MockChainState' -mockChainStateConf :: MockChainState -> MockChainConf a MockChainState -mockChainStateConf s0 = MockChainConf s0 def (snd . fst) - --- * 'MockChain' runs - --- We give the possibility to run a 'MockChain' or a 'MockChainT' from an --- arbitrary 'MockChainConf', and instance for configuration with a given --- 'InitialDistribution', which is the most used in our tests. All other --- configuration can freely be built and used for runs. - --- | Runs a 'MockChainT' using a certain configuration -runMockChainTFromConf :: (Monad m) => MockChainConf a b -> MockChainT m a -> m b -runMockChainTFromConf MockChainConf {..} = - fmap mccFunOnResult - . runWriterT - . flip runStateT mccInitialState - . runExceptT - . unMockChain - . (forceOutputs (unInitialDistribution mccInitialDistribution) >>) - --- | Runs a 'MockChain' using a certain configuration -runMockChainFromConf :: MockChainConf a b -> MockChain a -> b -runMockChainFromConf conf = runIdentity . runMockChainTFromConf conf - --- | Runs a 'MockChainT' from an initial 'InitialDistribution' -runMockChainTFromInitDist :: (Monad m) => InitialDistribution -> MockChainT m a -> m (MockChainReturn a) -runMockChainTFromInitDist i0 = runMockChainTFromConf (initDistConf i0) - --- | See 'runMockChainTFromInitDist' -runMockChainFromInitDist :: InitialDistribution -> MockChain a -> MockChainReturn a -runMockChainFromInitDist i0 = runIdentity . runMockChainTFromInitDist i0 - --- | Uses 'runMockChainTFromInitDist' with a default 'InitialDistribution' -runMockChainT :: (Monad m) => MockChainT m a -> m (MockChainReturn a) -runMockChainT = runMockChainTFromInitDist def - --- | Uses 'runMockChainFromInitDist' with a default 'InitialDistribution' -runMockChain :: MockChain a -> MockChainReturn a -runMockChain = runMockChainFromInitDist def - --- * Direct Interpretation of Operations - -instance (Monad m) => MonadBlockChainBalancing (MockChainT m) where - getParams = gets mcstParams - txSkelOutByRef oRef = do - res <- gets $ Map.lookup oRef . mcstOutputs - case res of - Just (txSkelOut, True) -> return txSkelOut - _ -> throwError $ MCEUnknownOutRef oRef - utxosAt (Script.toAddress -> addr) = filter ((addr ==) . view txSkelOutAddressG . snd) <$> allUtxos - logEvent l = tell $ MockChainBook [l] Map.empty - -instance (Monad m) => MonadBlockChainWithoutValidation (MockChainT m) where - allUtxos = - gets $ - mapMaybe - (\(oRef, (txSkelOut, isAvailable)) -> if isAvailable then Just (oRef, txSkelOut) else Nothing) - . Map.toList - . mcstOutputs - setParams params = do - modify $ set mcstParamsL params - modify $ over mcstLedgerStateL (Emulator.updateStateParams params) - waitNSlots n = do - cs <- gets (Emulator.getSlot . mcstLedgerState) - if - | n == 0 -> return cs - | n > 0 -> do - let newSlot = cs + fromIntegral n - modify' (over mcstLedgerStateL $ Lens.set Emulator.elsSlotL $ fromIntegral newSlot) - return newSlot - | otherwise -> throwError $ MCEPastSlot cs (cs + fromIntegral n) - define name hashable = tell (MockChainBook [] (Map.singleton (toHash hashable) name)) >> return hashable - setConstitutionScript (toVScript -> cScript) = do - modify' (mcstConstitutionL ?~ cScript) - modify' $ - over mcstLedgerStateL $ - Lens.set Emulator.elsConstitutionScriptL $ - (Cardano.SJust . Cardano.toShelleyScriptHash . Script.toCardanoScriptHash) - cScript - getConstitutionScript = gets (view mcstConstitutionL) - getCurrentReward (Script.toCredential -> cred) = do - stakeCredential <- toStakeCredential cred - gets (fmap coerce . Emulator.getReward stakeCredential . view mcstLedgerStateL) - --- | Most of the logic of the direct emulation happens here -instance (Monad m) => MonadBlockChain (MockChainT m) where - validateTxSkel txSkel | TxSkelOpts {..} <- txSkelOpts txSkel = do - -- We log the submission of a new skeleton - logEvent $ MCLogSubmittedTxSkel txSkel - -- We retrieve the current parameters - oldParams <- getParams - -- We compute the optionally modified parameters - let newParams = txSkelOptModParams oldParams - -- We change the parameters for the duration of the validation process - setParams newParams - -- We ensure that the outputs have the required minimal amount of ada, when - -- requested in the skeleton options - txSkel <- autoFillMinAda txSkel - -- We retrieve the official constitution script and attach it to each - -- proposal that requires it, if it's not empty - txSkel <- autoFillConstitution txSkel - -- We add reference scripts in the various redeemers of the skeleton, when - -- they can be found in the index and are allowed to be auto filled - txSkel <- autoFillReferenceScripts txSkel - -- We attach the reward amount to withdrawals when applicable - txSkel <- autoFillWithdrawalAmounts txSkel - -- We balance the skeleton when requested in the skeleton option, and get - -- the associated fee, collateral inputs and return collateral user - (txSkel, fee, mCollaterals) <- balanceTxSkel txSkel - -- We log the adjusted skeleton - logEvent $ MCLogAdjustedTxSkel txSkel fee mCollaterals - -- We generate the transaction asscoiated with the skeleton, and apply on it - -- the modifications from the skeleton options - cardanoTx <- Ledger.CardanoEmulatorEraTx . txSkelOptModTx <$> txSkelToCardanoTx txSkel fee mCollaterals - -- To run transaction validation we need a minimal ledger state - eLedgerState <- gets mcstLedgerState - -- We finally run the emulated validation. We update our internal state - -- based on the validation result, and throw an error if this fails. If at - -- some point we want to allows mockchain runs with validation errors, the - -- caller will need to catch those errors and do something with them. - case Emulator.validateCardanoTx newParams eLedgerState cardanoTx of - -- In case of a phase 1 error, we give back the same index - (_, Ledger.FailPhase1 _ err) -> throwError $ MCEValidationError Ledger.Phase1 err - (newELedgerState, Ledger.FailPhase2 _ err _) | Just (colInputs, retColUser) <- mCollaterals -> do - -- We update the emulated ledger state - modify' (set mcstLedgerStateL newELedgerState) - -- We remove the collateral utxos from our own stored outputs - forM_ colInputs $ modify' . removeOutput - -- We add the returned collateral to our outputs (in practice this map - -- either contains no element, or a single one) - forM_ (Map.toList $ Ledger.getCardanoTxProducedReturnCollateral cardanoTx) $ \(txIn, txOut) -> - modify' $ - addOutput - (Ledger.fromCardanoTxIn txIn) - (retColUser `receives` Value (Api.txOutValue . Ledger.fromCardanoTxOutToPV2TxInfoTxOut . Ledger.getTxOut $ txOut)) - -- We throw a mockchain error - throwError $ MCEValidationError Ledger.Phase2 err - -- In case of success, we update the index with all inputs and outputs - -- contained in the transaction - (newELedgerState, Ledger.Success {}) -> do - -- We update the index with the utxos consumed and produced by the tx - modify' (set mcstLedgerStateL newELedgerState) - -- We retrieve the utxos created by the transaction - let utxos = Ledger.fromCardanoTxIn . snd <$> Ledger.getCardanoTxOutRefs cardanoTx - -- We add the news utxos to the state - forM_ (zip utxos (txSkelOuts txSkel)) $ modify' . uncurry addOutput - -- And remove the old ones - forM_ (Map.toList $ txSkelIns txSkel) $ modify' . removeOutput . fst - -- This is a theoretical unreachable case. Since we fail in Phase 2, it - -- means the transaction involved script, and thus we must have generated - -- collaterals. - (_, Ledger.FailPhase2 {}) - | Nothing <- mCollaterals -> - fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" - -- We apply a change of slot when requested in the options - when txSkelOptAutoSlotIncrease $ modify' (over mcstLedgerStateL Emulator.nextSlot) - -- We return the parameters to their original state - setParams oldParams - -- We log the validated transaction - logEvent $ MCLogNewTx (Ledger.fromCardanoTxId $ Ledger.getCardanoTxId cardanoTx) (fromIntegral $ length $ Ledger.getCardanoTxOutRefs cardanoTx) - -- We return the validated transaction - return cardanoTx - - forceOutputs outputs = do - -- We retrieve the protocol parameters - params <- getParams - -- The emulator takes for granted transactions with a single pseudo input, - -- which we build to force transaction validation - let input = - ( Cardano.genesisUTxOPseudoTxIn (Emulator.pNetworkId params) $ - Cardano.GenesisUTxOKeyHash $ - Cardano.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194", - Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending - ) - -- We adjust the outputs for the minimal required ADA if needed - outputsMinAda <- mapM toTxSkelOutWithMinAda outputs - -- We transform these outputs to Cardano outputs - outputs' <- mapM toCardanoTxOut outputsMinAda - -- We create our transaction body, which only consists of the dummy input - -- and the outputs to force. This create might result in an error. - let transactionBody = - Emulator.createTransactionBody params $ - Ledger.CardanoBuildTx - ( Ledger.emptyTxBodyContent - { Cardano.txOuts = outputs', - Cardano.txIns = [input] - } - ) - -- We retrieve the forcefully validated transaction associated with the - -- body, handling errors in the process. - cardanoTx <- - Ledger.CardanoEmulatorEraTx . txSignatoriesAndBodyToCardanoTx [] - <$> either (throwError . MCEToCardanoError "forceOutputs :") return transactionBody - -- We need to adjust our internal state to account for the forced - -- transaction. We beging by computing the new map of outputs. - let outputsMap = - Map.fromList $ - zipWith - (\x y -> (x, (y, True))) - (Ledger.fromCardanoTxIn . snd <$> Ledger.getCardanoTxOutRefs cardanoTx) - outputsMinAda - -- We update the index, which effectively receives the new utxos - modify' (over mcstLedgerStateL $ Lens.over Emulator.elsUtxoL (Ledger.fromPlutusIndex . Ledger.insert cardanoTx . Ledger.toPlutusIndex)) - -- We update our internal map by adding the new outputs - modify' (over mcstOutputsL (<> outputsMap)) - -- Finally, we return the created utxos - fmap fst <$> utxosFromCardanoTx cardanoTx diff --git a/src/Cooked/MockChain/Error.hs b/src/Cooked/MockChain/Error.hs new file mode 100644 index 000000000..0a93a11a4 --- /dev/null +++ b/src/Cooked/MockChain/Error.hs @@ -0,0 +1,60 @@ +-- | This module exposes the errors that can be raised during a mockchain run +module Cooked.MockChain.Error + ( -- * Mockchain errors + MockChainError (..), + + -- * Interpretating effects into `Error MockChainError` + runToCardanoErrorInMockChainError, + runFailInMockChainError, + ) +where + +import Cooked.Skeleton.User +import Ledger.Index qualified as Ledger +import Ledger.Slot qualified as Ledger +import Ledger.Tx qualified as Ledger +import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error +import Polysemy.Fail + +-- | Errors that can be produced by the blockchain +data MockChainError + = -- | Validation errors, either in Phase 1 or Phase 2 + MCEValidationError Ledger.ValidationPhase Ledger.ValidationError + | -- | The balancing user does not have enough funds + MCEUnbalanceable Peer Api.Value + | -- | The balancing user is required but missing + MCEMissingBalancingUser String + | -- | No suitable collateral could be associated with a skeleton + MCENoSuitableCollateral Integer Integer Api.Value + | -- | Translating a skeleton element to its Cardano counterpart failed + MCEToCardanoError Ledger.ToCardanoError + | -- | The required reference script is missing from a witness utxo + MCEWrongReferenceScriptError Api.TxOutRef Api.ScriptHash (Maybe Api.ScriptHash) + | -- | A UTxO is missing from the mockchain state + MCEUnknownOutRef Api.TxOutRef + | -- | A jump in time would result in a past slot + MCEPastSlot Ledger.Slot Ledger.Slot + | -- | An attempt to invoke an unsupported feature has been made + MCEUnsupportedFeature String + | -- | Used to provide 'MonadFail' instances. + MCEFailure String + deriving (Show, Eq) + +-- | Interpreting `Ledger.ToCardanoError` in terms of `MockChainError` +runToCardanoErrorInMockChainError :: + forall effs a. + (Member (Error MockChainError) effs) => + Sem (Error Ledger.ToCardanoError : effs) a -> + Sem effs a +runToCardanoErrorInMockChainError = mapError MCEToCardanoError + +-- | Interpreting failures in terms of `MockChainError` +runFailInMockChainError :: + forall effs a. + (Member (Error MockChainError) effs) => + Sem (Fail : effs) a -> + Sem effs a +runFailInMockChainError = interpret $ + \(Fail s) -> throw $ MCEFailure s diff --git a/src/Cooked/MockChain/GenerateTx/Body.hs b/src/Cooked/MockChain/GenerateTx/Body.hs index 3709ba543..7bed7d27a 100644 --- a/src/Cooked/MockChain/GenerateTx/Body.hs +++ b/src/Cooked/MockChain/GenerateTx/Body.hs @@ -13,11 +13,10 @@ where import Cardano.Api qualified as Cardano import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad -import Control.Monad.Except -import Cooked.MockChain.BlockChain +import Cooked.MockChain.Common +import Cooked.MockChain.Error import Cooked.MockChain.GenerateTx.Certificate import Cooked.MockChain.GenerateTx.Collateral -import Cooked.MockChain.GenerateTx.Common import Cooked.MockChain.GenerateTx.Input import Cooked.MockChain.GenerateTx.Mint import Cooked.MockChain.GenerateTx.Output @@ -25,6 +24,7 @@ import Cooked.MockChain.GenerateTx.Proposal import Cooked.MockChain.GenerateTx.ReferenceInputs import Cooked.MockChain.GenerateTx.Withdrawals import Cooked.MockChain.GenerateTx.Witness +import Cooked.MockChain.Read import Cooked.Skeleton import Data.Map qualified as Map import Data.Maybe @@ -32,27 +32,31 @@ import Data.Set qualified as Set import Ledger.Address qualified as Ledger import Ledger.Tx.CardanoAPI qualified as Ledger import Plutus.Script.Utils.Address qualified as Script +import Polysemy +import Polysemy.Error +import Polysemy.Fail -- | Generates a body content from a skeleton -txSkelToTxBodyContent :: (MonadBlockChainBalancing m) => TxSkel -> Fee -> Collaterals -> m (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra) +txSkelToTxBodyContent :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) => + TxSkel -> + Fee -> + Collaterals -> + Sem effs (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra) txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do txIns <- mapM toTxInAndWitness $ Map.toList txSkelIns txInsReference <- toInsReference skel (txInsCollateral, txTotalCollateral, txReturnCollateral) <- toCollateralTriplet fee mCollaterals txOuts <- mapM toCardanoTxOut txSkelOuts - (txValidityLowerBound, txValidityUpperBound) <- - throwOnToCardanoError - "txSkelToBodyContent: Unable to translate transaction validity range." - $ Ledger.toCardanoValidityRange txSkelValidityRange + (txValidityLowerBound, txValidityUpperBound) <- fromEither $ Ledger.toCardanoValidityRange txSkelValidityRange txMintValue <- toMintValue txSkelMints txExtraKeyWits <- if null txSkelSignatories then return Cardano.TxExtraKeyWitnessesNone else - throwOnToCardanoErrorOrApply - "txSkelToBodyContent: Unable to translate the required signatories" - (Cardano.TxExtraKeyWitnesses Cardano.AlonzoEraOnwardsConway) - $ mapM (Ledger.toCardanoPaymentKeyHash . Ledger.PaymentPubKeyHash . Script.toPubKeyHash) txSkelSignatories + Cardano.TxExtraKeyWitnesses Cardano.AlonzoEraOnwardsConway + <$> fromEither + (mapM (Ledger.toCardanoPaymentKeyHash . Ledger.PaymentPubKeyHash . Script.toPubKeyHash) txSkelSignatories) txProtocolParams <- Cardano.BuildTxWith . Just . Emulator.ledgerProtocolParameters <$> getParams txProposalProcedures <- Just . Cardano.Featured Cardano.ConwayEraOnwardsConway <$> toProposalProcedures txSkelProposals txWithdrawals <- toWithdrawals txSkelWithdrawals @@ -68,36 +72,42 @@ txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do return Cardano.TxBodyContent {..} -- | Generates a transaction body from a body content -txBodyContentToTxBody :: (MonadBlockChainBalancing m) => Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra -> m (Cardano.TxBody Cardano.ConwayEra) +txBodyContentToTxBody :: + (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) => + Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra -> + Sem effs (Cardano.TxBody Cardano.ConwayEra) txBodyContentToTxBody txBodyContent = do params <- getParams -- We create the associated Shelley TxBody - either - (throwError . MCEToCardanoError "generateTx :") - return - (Emulator.createTransactionBody params (Ledger.CardanoBuildTx txBodyContent)) + fromEither $ Emulator.createTransactionBody params $ Ledger.CardanoBuildTx txBodyContent -- | Generates an index with utxos known to a 'TxSkel' -txSkelToIndex :: (MonadBlockChainBalancing m) => TxSkel -> Collaterals -> m (Cardano.UTxO Cardano.ConwayEra) +txSkelToIndex :: + (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) => + TxSkel -> + Collaterals -> + Sem effs (Cardano.UTxO Cardano.ConwayEra) txSkelToIndex txSkel mCollaterals = do -- We build the index of UTxOs which are known to this skeleton. This includes -- collateral inputs, inputs and reference inputs. - let collateralIns = case mCollaterals of - Nothing -> [] - Just (s, _) -> Set.toList s + let collateralIns = maybe [] (Set.toList . fst) mCollaterals -- We retrieve all the outputs known to the skeleton (knownTxORefs, knownTxOuts) <- unzip . Map.toList <$> lookupUtxos (Set.toList (txSkelKnownTxOutRefs txSkel) <> collateralIns) -- We then compute their Cardano counterparts txOutL <- forM knownTxOuts toCardanoTxOut -- We build the index and handle the possible error - either (throwError . MCEToCardanoError "txSkelToIndex:") return $ do - txInL <- forM knownTxORefs Ledger.toCardanoTxIn - return $ Cardano.UTxO $ Map.fromList $ zip txInL $ Cardano.toCtxUTxOTxOut <$> txOutL + txInL <- fromEither $ forM knownTxORefs Ledger.toCardanoTxIn + return $ Cardano.UTxO $ Map.fromList $ zip txInL $ Cardano.toCtxUTxOTxOut <$> txOutL -- | Generates a transaction body from a 'TxSkel' and associated fee and -- collateral information. This transaction body accounts for the actual -- execution units of each of the scripts involved in the skeleton. -txSkelToTxBody :: (MonadBlockChainBalancing m) => TxSkel -> Fee -> Collaterals -> m (Cardano.TxBody Cardano.ConwayEra) +txSkelToTxBody :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) => + TxSkel -> + Fee -> + Collaterals -> + Sem effs (Cardano.TxBody Cardano.ConwayEra) txSkelToTxBody txSkel fee mCollaterals = do -- We create a first body content and body, without execution units txBodyContent' <- txSkelToTxBodyContent txSkel fee mCollaterals @@ -111,22 +121,32 @@ txSkelToTxBody txSkel fee mCollaterals = do case Emulator.getTxExUnitsWithLogs params (Ledger.fromPlutusIndex index) tx' of -- Computing the execution units can result in all kinds of validation -- errors except for the ones related to the execution units themselves. - Left err -> throwError $ uncurry MCEValidationError err + Left err -> throw $ uncurry MCEValidationError err -- When no error arises, we get an execution unit for each script usage. We -- first have to transform this Ledger map to a cardano API map. Right (Map.mapKeysMonotonic (Cardano.toScriptIndex Cardano.AlonzoEraOnwardsConway) . fmap (Cardano.fromAlonzoExUnits . snd) -> exUnits) -> -- We can then assign the right execution units to the body content case Cardano.substituteExecutionUnits exUnits txBodyContent' of -- This can only be a @TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap@ - Left _ -> throwError $ FailWith "Error while assigning execution units" + Left _ -> fail "Error while assigning execution units" -- We now have a body content with proper execution units and can create -- the final body from it Right txBody -> txBodyContentToTxBody txBody -- | Generates a Cardano transaction and signs it -txSignatoriesAndBodyToCardanoTx :: [TxSkelSignatory] -> Cardano.TxBody Cardano.ConwayEra -> Cardano.Tx Cardano.ConwayEra +txSignatoriesAndBodyToCardanoTx :: + [TxSkelSignatory] -> + Cardano.TxBody Cardano.ConwayEra -> + Cardano.Tx Cardano.ConwayEra txSignatoriesAndBodyToCardanoTx signatories txBody = Cardano.Tx txBody $ mapMaybe (toKeyWitness txBody) signatories -- | Generates a full Cardano transaction from a skeleton, fees and collaterals -txSkelToCardanoTx :: (MonadBlockChainBalancing m) => TxSkel -> Fee -> Collaterals -> m (Cardano.Tx Cardano.ConwayEra) -txSkelToCardanoTx txSkel fee = fmap (txSignatoriesAndBodyToCardanoTx (txSkelSignatories txSkel)) . txSkelToTxBody txSkel fee +txSkelToCardanoTx :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) => + TxSkel -> + Fee -> + Collaterals -> + Sem effs (Cardano.Tx Cardano.ConwayEra) +txSkelToCardanoTx txSkel fee = + fmap (txSignatoriesAndBodyToCardanoTx (txSkelSignatories txSkel)) + . txSkelToTxBody txSkel fee diff --git a/src/Cooked/MockChain/GenerateTx/Certificate.hs b/src/Cooked/MockChain/GenerateTx/Certificate.hs index 0e21272ac..d85e7e03d 100644 --- a/src/Cooked/MockChain/GenerateTx/Certificate.hs +++ b/src/Cooked/MockChain/GenerateTx/Certificate.hs @@ -8,27 +8,42 @@ import Cardano.Ledger.DRep qualified as Ledger import Cardano.Ledger.PoolParams qualified as Ledger import Cardano.Ledger.Shelley.TxCert qualified as Shelley import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Cooked.MockChain.BlockChain +import Cooked.MockChain.Error +import Cooked.MockChain.GenerateTx.Credential import Cooked.MockChain.GenerateTx.Witness +import Cooked.MockChain.Read import Cooked.Skeleton.Certificate import Cooked.Skeleton.User import Data.Default import Data.Maybe.Strict +import Ledger.Tx qualified as Ledger import Optics.Core import Plutus.Script.Utils.Address qualified as Script import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error +import Polysemy.Fail -toDRep :: (MonadBlockChainBalancing m) => Api.DRep -> m Ledger.DRep +toDRep :: + (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) => + Api.DRep -> + Sem effs Ledger.DRep toDRep Api.DRepAlwaysAbstain = return Ledger.DRepAlwaysAbstain toDRep Api.DRepAlwaysNoConfidence = return Ledger.DRepAlwaysNoConfidence toDRep (Api.DRep (Api.DRepCredential cred)) = Ledger.DRepCredential <$> toDRepCredential cred -toDelegatee :: (MonadBlockChainBalancing m) => Api.Delegatee -> m Conway.Delegatee +toDelegatee :: + (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) => + Api.Delegatee -> + Sem effs Conway.Delegatee toDelegatee (Api.DelegStake pkh) = Conway.DelegStake <$> toStakePoolKeyHash pkh toDelegatee (Api.DelegVote dRep) = Conway.DelegVote <$> toDRep dRep toDelegatee (Api.DelegStakeVote pkh dRep) = liftA2 Conway.DelegStakeVote (toStakePoolKeyHash pkh) (toDRep dRep) -toCertificate :: (MonadBlockChainBalancing m) => TxSkelCertificate -> m (Cardano.Certificate Cardano.ConwayEra) +toCertificate :: + (Members '[MockChainRead, Error Ledger.ToCardanoError, Fail] effs) => + TxSkelCertificate -> + Sem effs (Cardano.Certificate Cardano.ConwayEra) toCertificate txSkelCert = do depositStake <- Cardano.Coin . Api.getLovelace <$> stakeAddressDeposit @@ -74,7 +89,10 @@ toCertificate txSkelCert = TxSkelCertificate (Script.toCredential -> cred) CommitteeResign -> Conway.ConwayTxCertGov . (`Conway.ConwayResignCommitteeColdKey` SNothing) <$> toColdCredential cred -toCertificateWitness :: (MonadBlockChainBalancing m) => TxSkelCertificate -> m (Maybe (Cardano.ScriptWitness Cardano.WitCtxStake Cardano.ConwayEra)) +toCertificateWitness :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + TxSkelCertificate -> + Sem effs (Maybe (Cardano.ScriptWitness Cardano.WitCtxStake Cardano.ConwayEra)) toCertificateWitness = maybe (return Nothing) @@ -85,7 +103,10 @@ toCertificateWitness = . preview (txSkelCertificateOwnerAT @IsEither) -- | Builds a 'Cardano.TxCertificates' from a list of 'TxSkelCertificate' -toCertificates :: (MonadBlockChainBalancing m) => [TxSkelCertificate] -> m (Cardano.TxCertificates Cardano.BuildTx Cardano.ConwayEra) +toCertificates :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) => + [TxSkelCertificate] -> + Sem effs (Cardano.TxCertificates Cardano.BuildTx Cardano.ConwayEra) toCertificates = fmap (Cardano.mkTxCertificates Cardano.ShelleyBasedEraConway) . mapM (\txSkelCert -> liftA2 (,) (toCertificate txSkelCert) (toCertificateWitness txSkelCert)) diff --git a/src/Cooked/MockChain/GenerateTx/Collateral.hs b/src/Cooked/MockChain/GenerateTx/Collateral.hs index 9cf1de458..d441936dd 100644 --- a/src/Cooked/MockChain/GenerateTx/Collateral.hs +++ b/src/Cooked/MockChain/GenerateTx/Collateral.hs @@ -6,15 +6,17 @@ import Cardano.Api qualified as Cardano import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad -import Cooked.MockChain.BlockChain -import Cooked.MockChain.GenerateTx.Common -import Cooked.Skeleton +import Cooked.MockChain.Common +import Cooked.MockChain.Read +import Cooked.Skeleton.Output import Data.Set qualified as Set import Ledger.Tx.CardanoAPI qualified as Ledger import Lens.Micro.Extras qualified as MicroLens import Plutus.Script.Utils.Address qualified as Script import Plutus.Script.Utils.Value qualified as Script import PlutusTx.Numeric qualified as PlutusTx +import Polysemy +import Polysemy.Error -- | Computes the collateral triplet from the fees and the collateral inputs in -- the context. What we call a collateral triplet is composed of: @@ -24,10 +26,11 @@ import PlutusTx.Numeric qualified as PlutusTx -- These quantity should satisfy the equation (in terms of their values): -- collateral inputs = total collateral + return collateral toCollateralTriplet :: - (MonadBlockChainBalancing m) => + (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) => Fee -> Collaterals -> - m + Sem + effs ( Cardano.TxInsCollateral Cardano.ConwayEra, Cardano.TxTotalCollateral Cardano.ConwayEra, Cardano.TxReturnCollateral Cardano.CtxTx Cardano.ConwayEra @@ -38,7 +41,7 @@ toCollateralTriplet fee (Just (Set.toList -> collateralInsList, returnCollateral txInsCollateral <- case collateralInsList of [] -> return Cardano.TxInsCollateralNone - l -> throwOnToCardanoError "toCollateralTriplet" $ Cardano.TxInsCollateral Cardano.AlonzoEraOnwardsConway <$> mapM Ledger.toCardanoTxIn l + l -> fromEither $ Cardano.TxInsCollateral Cardano.AlonzoEraOnwardsConway <$> mapM Ledger.toCardanoTxIn l -- Retrieving the total value in collateral inputs. This fails if one of the -- collateral inputs has not been successfully resolved. collateralInsValue <- @@ -63,17 +66,11 @@ toCollateralTriplet fee (Just (Set.toList -> collateralInsList, returnCollateral then return Cardano.TxReturnCollateralNone else do -- The value is a translation of the remaining value - txReturnCollateralValue <- - Ledger.toCardanoTxOutValue - <$> throwOnToCardanoError - "toCollateralTriplet: cannot build return collateral value" - (Ledger.toCardanoValue returnCollateralValue) + txReturnCollateralValue <- Ledger.toCardanoTxOutValue <$> fromEither (Ledger.toCardanoValue returnCollateralValue) -- The address is the one from the return collateral user, which is -- required to exist here. networkId <- Emulator.pNetworkId <$> getParams - address <- - throwOnToCardanoError "toCollateralTriplet: cannot build return collateral address" $ - Ledger.toCardanoAddressInEra networkId (Script.toAddress returnCollateralUser) + address <- fromEither $ Ledger.toCardanoAddressInEra networkId (Script.toAddress returnCollateralUser) -- The return collateral is built up from those elements return $ Cardano.TxReturnCollateral Cardano.BabbageEraOnwardsConway $ diff --git a/src/Cooked/MockChain/GenerateTx/Common.hs b/src/Cooked/MockChain/GenerateTx/Common.hs deleted file mode 100644 index 2aefb0f61..000000000 --- a/src/Cooked/MockChain/GenerateTx/Common.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Common utilities used to transfer generation errors raised by plutus-ledger --- into instances of 'MockChainError' -module Cooked.MockChain.GenerateTx.Common - ( throwOnToCardanoErrorOrApply, - throwOnToCardanoError, - ) -where - -import Control.Monad.Except -import Cooked.MockChain.BlockChain -import Ledger.Tx qualified as Ledger - --- | Lifts a 'Ledger.ToCardanoError' with an associated error message, or apply a --- function if a value exists. -throwOnToCardanoErrorOrApply :: (MonadError MockChainError m) => String -> (a -> b) -> Either Ledger.ToCardanoError a -> m b -throwOnToCardanoErrorOrApply errorMsg f = either (throwError . MCEToCardanoError errorMsg) (return . f) - --- | Lifts a 'Ledger.ToCardanoError' with an associated error message, or leaves --- the value unchanged if it exists. -throwOnToCardanoError :: (MonadError MockChainError m) => String -> Either Ledger.ToCardanoError a -> m a -throwOnToCardanoError = flip throwOnToCardanoErrorOrApply id diff --git a/src/Cooked/MockChain/GenerateTx/Credential.hs b/src/Cooked/MockChain/GenerateTx/Credential.hs new file mode 100644 index 000000000..9e7f039f9 --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Credential.hs @@ -0,0 +1,127 @@ +-- | This module exposes the generation of various kinds of credentials +module Cooked.MockChain.GenerateTx.Credential + ( toRewardAccount, + toCardanoCredential, + toStakeCredential, + deserialiseFromBuiltinByteString, + toScriptHash, + toKeyHash, + toDRepCredential, + toStakePoolKeyHash, + toColdCredential, + toHotCredential, + toVRFVerKeyHash, + ) +where + +import Cardano.Api qualified as Cardano +import Cardano.Ledger.BaseTypes qualified as C.Ledger +import Cardano.Ledger.Hashes qualified as C.Ledger +import Cardano.Ledger.Shelley.API qualified as C.Ledger +import Ledger.Tx.CardanoAPI qualified as Ledger +import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error + +-- | Translates a given credential to a reward account. +toRewardAccount :: + (Member (Error Ledger.ToCardanoError) effs) => + Api.Credential -> + Sem effs C.Ledger.RewardAccount +toRewardAccount = + (C.Ledger.RewardAccount C.Ledger.Testnet <$>) + . toCardanoCredential Cardano.AsStakeKey Cardano.unStakeKeyHash + +-- TODO: if this works, migrate to plutus-ledger + +-- | Converts an 'Api.PubKeyHash' to any kind of key +deserialiseFromBuiltinByteString :: + ( Member (Error Ledger.ToCardanoError) effs, + Cardano.SerialiseAsRawBytes a + ) => + Cardano.AsType a -> + Api.BuiltinByteString -> + Sem effs a +deserialiseFromBuiltinByteString asType = + fromEither + . Ledger.deserialiseFromRawBytes asType + . Api.fromBuiltin + +-- | Converts a plutus script hash into a cardano ledger script hash +toScriptHash :: + (Member (Error Ledger.ToCardanoError) effs) => + Api.ScriptHash -> + Sem effs C.Ledger.ScriptHash +toScriptHash (Api.ScriptHash sHash) = do + Cardano.ScriptHash cHash <- deserialiseFromBuiltinByteString Cardano.AsScriptHash sHash + return cHash + +-- | Converts a plutus pkhash into a certain cardano ledger hash +toKeyHash :: + ( Member (Error Ledger.ToCardanoError) effs, + Cardano.SerialiseAsRawBytes (Cardano.Hash key) + ) => + Cardano.AsType key -> + (Cardano.Hash key -> C.Ledger.KeyHash kr) -> + Api.PubKeyHash -> + Sem effs (C.Ledger.KeyHash kr) +toKeyHash asType unwrap = + fmap unwrap + . deserialiseFromBuiltinByteString (Cardano.AsHash asType) + . Api.getPubKeyHash + +-- | Converts an 'Api.PubKeyHash' into a cardano ledger stake pool key hash +toStakePoolKeyHash :: + (Member (Error Ledger.ToCardanoError) effs) => + Api.PubKeyHash -> + Sem effs (C.Ledger.KeyHash 'C.Ledger.StakePool) +toStakePoolKeyHash = toKeyHash Cardano.AsStakePoolKey Cardano.unStakePoolKeyHash + +-- | Converts an 'Api.PubKeyHash' into a cardano ledger VRFVerKeyHash +toVRFVerKeyHash :: + (Member (Error Ledger.ToCardanoError) effs) => + Api.PubKeyHash -> + Sem effs (C.Ledger.VRFVerKeyHash a) +toVRFVerKeyHash (Api.PubKeyHash pkh) = do + Cardano.VrfKeyHash key <- deserialiseFromBuiltinByteString (Cardano.AsHash Cardano.AsVrfKey) pkh + return $ C.Ledger.toVRFVerKeyHash key + +-- | Converts an 'Api.Credential' to a Cardano Credential of the expected kind +toCardanoCredential :: + ( Member (Error Ledger.ToCardanoError) effs, + Cardano.SerialiseAsRawBytes (Cardano.Hash key) + ) => + Cardano.AsType key -> + (Cardano.Hash key -> C.Ledger.KeyHash kr) -> + Api.Credential -> + Sem effs (C.Ledger.Credential kr) +toCardanoCredential _ _ (Api.ScriptCredential sHash) = C.Ledger.ScriptHashObj <$> toScriptHash sHash +toCardanoCredential asType unwrap (Api.PubKeyCredential pkHash) = C.Ledger.KeyHashObj <$> toKeyHash asType unwrap pkHash + +-- | Translates a credential into a Cardano stake credential +toStakeCredential :: + (Member (Error Ledger.ToCardanoError) effs) => + Api.Credential -> + Sem effs (C.Ledger.Credential 'C.Ledger.Staking) +toStakeCredential = toCardanoCredential Cardano.AsStakeKey Cardano.unStakeKeyHash + +-- | Translates a credential into a Cardano drep credential +toDRepCredential :: + (Member (Error Ledger.ToCardanoError) effs) => + Api.Credential -> + Sem effs (C.Ledger.Credential 'C.Ledger.DRepRole) +toDRepCredential = toCardanoCredential Cardano.AsDRepKey Cardano.unDRepKeyHash + +-- | Translates a credential into a Cardano cold committee credential +toColdCredential :: + (Member (Error Ledger.ToCardanoError) effs) => + Api.Credential -> + Sem effs (C.Ledger.Credential 'C.Ledger.ColdCommitteeRole) +toColdCredential = toCardanoCredential Cardano.AsCommitteeColdKey Cardano.unCommitteeColdKeyHash + +-- | Translates a credential into a Cardano hot committee credential +toHotCredential :: + (Member (Error Ledger.ToCardanoError) effs) => + Api.Credential -> + Sem effs (C.Ledger.Credential 'C.Ledger.HotCommitteeRole) +toHotCredential = toCardanoCredential Cardano.AsCommitteeHotKey Cardano.unCommitteeHotKeyHash diff --git a/src/Cooked/MockChain/GenerateTx/Input.hs b/src/Cooked/MockChain/GenerateTx/Input.hs index 4bfce560f..668412aba 100644 --- a/src/Cooked/MockChain/GenerateTx/Input.hs +++ b/src/Cooked/MockChain/GenerateTx/Input.hs @@ -2,19 +2,25 @@ module Cooked.MockChain.GenerateTx.Input (toTxInAndWitness) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.BlockChain -import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.Error import Cooked.MockChain.GenerateTx.Witness +import Cooked.MockChain.Read import Cooked.Skeleton import Ledger.Tx.CardanoAPI qualified as Ledger import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error -- | Converts a 'TxSkel' input, which consists of a 'Api.TxOutRef' and a -- 'TxSkelRedeemer', into a 'Cardano.TxIn', together with the appropriate witness. toTxInAndWitness :: - (MonadBlockChainBalancing m) => + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => (Api.TxOutRef, TxSkelRedeemer) -> - m (Cardano.TxIn, Cardano.BuildTxWith Cardano.BuildTx (Cardano.Witness Cardano.WitCtxTxIn Cardano.ConwayEra)) + Sem + effs + ( Cardano.TxIn, + Cardano.BuildTxWith Cardano.BuildTx (Cardano.Witness Cardano.WitCtxTxIn Cardano.ConwayEra) + ) toTxInAndWitness (txOutRef, txSkelRedeemer) = do TxSkelOut owner _ datum _ _ _ <- txSkelOutByRef txOutRef witness <- case owner of @@ -26,7 +32,4 @@ toTxInAndWitness (txOutRef, txSkelRedeemer) = do NoTxSkelOutDatum -> Cardano.ScriptDatumForTxIn Nothing SomeTxSkelOutDatum _ Inline -> Cardano.InlineScriptDatum SomeTxSkelOutDatum dat _ -> Cardano.ScriptDatumForTxIn $ Just $ Ledger.toCardanoScriptData $ Api.toBuiltinData dat - throwOnToCardanoErrorOrApply - "toTxInAndWitness: Unable to translate TxOutRef" - (,Cardano.BuildTxWith witness) - (Ledger.toCardanoTxIn txOutRef) + (,Cardano.BuildTxWith witness) <$> fromEither (Ledger.toCardanoTxIn txOutRef) diff --git a/src/Cooked/MockChain/GenerateTx/Mint.hs b/src/Cooked/MockChain/GenerateTx/Mint.hs index 4abdca3b0..d1eab2b0f 100644 --- a/src/Cooked/MockChain/GenerateTx/Mint.hs +++ b/src/Cooked/MockChain/GenerateTx/Mint.hs @@ -3,10 +3,11 @@ module Cooked.MockChain.GenerateTx.Mint (toMintValue) where import Cardano.Api qualified as Cardano import Control.Monad -import Cooked.MockChain.BlockChain -import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.Error import Cooked.MockChain.GenerateTx.Witness -import Cooked.Skeleton +import Cooked.MockChain.Read +import Cooked.Skeleton.Mint +import Cooked.Skeleton.User import Data.Map qualified as Map import Data.Map.Strict qualified as SMap import GHC.Exts (fromList) @@ -14,16 +15,18 @@ import Ledger.Tx.CardanoAPI qualified as Ledger import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api import PlutusTx.Builtins.Internal qualified as PlutusTx +import Polysemy +import Polysemy.Error -- | Converts a 'TxSkelMints' into a 'Cardano.TxMintValue' -toMintValue :: (MonadBlockChainBalancing m) => TxSkelMints -> m (Cardano.TxMintValue Cardano.BuildTx Cardano.ConwayEra) +toMintValue :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + TxSkelMints -> + Sem effs (Cardano.TxMintValue Cardano.BuildTx Cardano.ConwayEra) toMintValue txSkelMints | txSkelMints == mempty = return Cardano.TxMintNone toMintValue (unTxSkelMints -> mints) = fmap (Cardano.TxMintValue Cardano.MaryEraOnwardsConway . SMap.fromList) $ forM (Map.toList mints) $ \(policyHash, (UserRedeemedScript policy red, Map.toList -> assets)) -> do - policyId <- - throwOnToCardanoError - "toMintValue: Unable to translate minting policy hash" - (Ledger.toCardanoPolicyId $ Script.toMintingPolicyHash policyHash) + policyId <- fromEither $ Ledger.toCardanoPolicyId $ Script.toMintingPolicyHash policyHash mintWitness <- Cardano.BuildTxWith <$> toScriptWitness policy red Cardano.NoScriptDatumForMint return ( policyId, diff --git a/src/Cooked/MockChain/GenerateTx/Output.hs b/src/Cooked/MockChain/GenerateTx/Output.hs index 5279676af..531814378 100644 --- a/src/Cooked/MockChain/GenerateTx/Output.hs +++ b/src/Cooked/MockChain/GenerateTx/Output.hs @@ -3,37 +3,42 @@ module Cooked.MockChain.GenerateTx.Output (toCardanoTxOut) where import Cardano.Api qualified as Cardano import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator -import Cooked.MockChain.BlockChain -import Cooked.MockChain.GenerateTx.Common -import Cooked.Skeleton +import Cooked.MockChain.Read +import Cooked.Skeleton.Datum +import Cooked.Skeleton.Output import Ledger.Tx.CardanoAPI qualified as Ledger import Optics.Core import Plutus.Script.Utils.Data qualified as Script import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error -- | Converts a 'TxSkelOut' to the corresponding 'Cardano.TxOut' -toCardanoTxOut :: (MonadBlockChainBalancing m) => TxSkelOut -> m (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) +toCardanoTxOut :: + (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) => + TxSkelOut -> + Sem effs (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) toCardanoTxOut output = do let oAddress = view txSkelOutAddressG output oValue = view txSkelOutValueL output oDatum = output ^. txSkelOutDatumL oRefScript = view txSkelOutMReferenceScriptL output networkId <- Emulator.pNetworkId <$> getParams - 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) + address <- fromEither $ Ledger.toCardanoAddressInEra networkId oAddress + (Ledger.toCardanoTxOutValue -> value) <- fromEither $ Ledger.toCardanoValue oValue datum <- case oDatum of NoTxSkelOutDatum -> return Cardano.TxOutDatumNone SomeTxSkelOutDatum datum (Hashed NotResolved) -> Cardano.TxOutDatumHash Cardano.AlonzoEraOnwardsConway - <$> throwOnToCardanoError - "toCardanoTxOut: Unable to resolve/transate a datum hash." - (Ledger.toCardanoScriptDataHash $ Script.datumHash $ Api.Datum $ Api.toBuiltinData datum) - SomeTxSkelOutDatum datum (Hashed Resolved) -> return $ Cardano.TxOutSupplementalDatum Cardano.AlonzoEraOnwardsConway $ Ledger.toCardanoScriptData $ Api.toBuiltinData datum - SomeTxSkelOutDatum datum Inline -> return $ Cardano.TxOutDatumInline Cardano.BabbageEraOnwardsConway $ Ledger.toCardanoScriptData $ Api.toBuiltinData datum + <$> fromEither (Ledger.toCardanoScriptDataHash $ Script.datumHash $ Api.Datum $ Api.toBuiltinData datum) + SomeTxSkelOutDatum datum (Hashed Resolved) -> + return $ + Cardano.TxOutSupplementalDatum Cardano.AlonzoEraOnwardsConway $ + Ledger.toCardanoScriptData $ + Api.toBuiltinData datum + SomeTxSkelOutDatum datum Inline -> + return $ + Cardano.TxOutDatumInline Cardano.BabbageEraOnwardsConway $ + Ledger.toCardanoScriptData $ + Api.toBuiltinData datum return $ Cardano.TxOut address value datum $ Ledger.toCardanoReferenceScript oRefScript diff --git a/src/Cooked/MockChain/GenerateTx/Proposal.hs b/src/Cooked/MockChain/GenerateTx/Proposal.hs index e146f77fb..06a8167b7 100644 --- a/src/Cooked/MockChain/GenerateTx/Proposal.hs +++ b/src/Cooked/MockChain/GenerateTx/Proposal.hs @@ -9,12 +9,13 @@ import Cardano.Ledger.Conway.Governance qualified as Conway import Cardano.Ledger.Conway.PParams qualified as Conway import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad -import Control.Monad.Except (throwError) -import Cooked.MockChain.BlockChain +import Cooked.MockChain.Error import Cooked.MockChain.GenerateTx.Anchor -import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.GenerateTx.Credential import Cooked.MockChain.GenerateTx.Witness -import Cooked.Skeleton +import Cooked.MockChain.Read +import Cooked.Skeleton.Proposal +import Cooked.Skeleton.User import Data.Coerce import Data.Map qualified as Map import Data.Map.Ordered.Strict qualified as OMap @@ -25,10 +26,15 @@ import Lens.Micro qualified as MicroLens import Plutus.Script.Utils.Address qualified as Script import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V1.Value qualified as Api +import Polysemy +import Polysemy.Error --- | Transorms a `Cooked.Skeleton.Proposal.ParameterChange` into an actual --- change over a Cardano parameter update -toPParamsUpdate :: ParameterChange -> Conway.PParamsUpdate Emulator.EmulatorEra -> Conway.PParamsUpdate Emulator.EmulatorEra +-- | Transorms a `Cooked.Skeleton.Proposal.ParamChange` into an actual change +-- over a Cardano parameter update +toPParamsUpdate :: + ParamChange -> + Conway.PParamsUpdate Emulator.EmulatorEra -> + Conway.PParamsUpdate Emulator.EmulatorEra toPParamsUpdate pChange = -- From rational to bounded rational let toBR :: (Cardano.BoundedRational r) => Rational -> r @@ -72,11 +78,15 @@ toPParamsUpdate pChange = MinFeeRefScriptCostPerByte q -> setL Conway.ppuMinFeeRefScriptCostPerByteL $ fromMaybe minBound $ Cardano.boundRational q -- | Translates a given skeleton proposal into a governance action -toGovAction :: (MonadBlockChainBalancing m) => GovernanceAction a -> StrictMaybe Conway.ScriptHash -> m (Conway.GovAction Emulator.EmulatorEra) +toGovAction :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + GovernanceAction a -> + StrictMaybe Conway.ScriptHash -> + Sem effs (Conway.GovAction Emulator.EmulatorEra) toGovAction NoConfidence _ = return $ Conway.NoConfidence SNothing -toGovAction UpdateCommittee {} _ = throwError $ MCEUnsupportedFeature "UpdateCommittee" -toGovAction NewConstitution {} _ = throwError $ MCEUnsupportedFeature "TxGovActionNewConstitution" -toGovAction HardForkInitiation {} _ = throwError $ MCEUnsupportedFeature "TxGovActionHardForkInitiation" +toGovAction UpdateCommittee {} _ = throw $ MCEUnsupportedFeature "UpdateCommittee" +toGovAction NewConstitution {} _ = throw $ MCEUnsupportedFeature "TxGovActionNewConstitution" +toGovAction HardForkInitiation {} _ = throw $ MCEUnsupportedFeature "TxGovActionHardForkInitiation" toGovAction (ParameterChange changes) sHash = return $ Conway.ParameterChange SNothing (foldl (flip toPParamsUpdate) (Conway.PParamsUpdate Cardano.emptyPParamsStrictMaybe) changes) sHash toGovAction (TreasuryWithdrawals (Map.toList -> withdrawals)) sHash = @@ -84,9 +94,9 @@ toGovAction (TreasuryWithdrawals (Map.toList -> withdrawals)) sHash = -- | Translates a list of skeleton proposals into a proposal procedures toProposalProcedures :: - (MonadBlockChainBalancing m) => + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => [TxSkelProposal] -> - m (Cardano.TxProposalProcedures Cardano.BuildTx Cardano.ConwayEra) + Sem effs (Cardano.TxProposalProcedures Cardano.BuildTx Cardano.ConwayEra) toProposalProcedures props | null props = return Cardano.TxProposalProceduresNone toProposalProcedures props = Cardano.TxProposalProcedures . OMap.fromList @@ -98,7 +108,7 @@ toProposalProcedures props = (Cardano.BuildTxWith -> mConstitutionWitness, mConstitutionHash) <- case mConstitution of Just (UserRedeemedScript (toVScript -> script) redeemer) -> do scriptWitness <- toScriptWitness script redeemer Cardano.NoScriptDatumForStake - Cardano.ScriptHash scriptHash <- throwOnToCardanoError "Unable to convert script hash" $ Ledger.toCardanoScriptHash $ Script.toScriptHash script + Cardano.ScriptHash scriptHash <- fromEither $ Ledger.toCardanoScriptHash $ Script.toScriptHash script return (Just scriptWitness, SJust scriptHash) _ -> return (Nothing, SNothing) cardanoGovAction <- toGovAction govAction mConstitutionHash diff --git a/src/Cooked/MockChain/GenerateTx/ReferenceInputs.hs b/src/Cooked/MockChain/GenerateTx/ReferenceInputs.hs index 0248808b9..69ae7375c 100644 --- a/src/Cooked/MockChain/GenerateTx/ReferenceInputs.hs +++ b/src/Cooked/MockChain/GenerateTx/ReferenceInputs.hs @@ -2,20 +2,24 @@ module Cooked.MockChain.GenerateTx.ReferenceInputs (toInsReference) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.BlockChain -import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.Read import Cooked.Skeleton import Data.Map qualified as Map import Data.Set qualified as Set import Ledger.Tx.CardanoAPI qualified as Ledger import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error -- | Takes a 'TxSkel' and generates the associated 'Cardano.TxInsReference' from -- its content. These reference inputs can be found in two places, either in -- direct reference inputs 'txSkelInsReference' or scattered in the various -- redeemers of the transaction, which can be gathered with -- 'txSkelInsReferenceInRedeemers'. -toInsReference :: (MonadBlockChainBalancing m) => TxSkel -> m (Cardano.TxInsReference Cardano.BuildTx Cardano.ConwayEra) +toInsReference :: + (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) => + TxSkel -> + Sem effs (Cardano.TxInsReference Cardano.BuildTx Cardano.ConwayEra) toInsReference skel = do -- As regular inputs can be used to hold scripts as if in reference inputs, we -- need to remove from the reference inputs stored in redeemers the ones that @@ -26,10 +30,7 @@ toInsReference skel = do if null refInputs then return Cardano.TxInsReferenceNone else do - cardanoRefInputs <- - throwOnToCardanoError - "toInsReference: Unable to translate reference inputs." - (mapM Ledger.toCardanoTxIn refInputs) + cardanoRefInputs <- fromEither $ mapM Ledger.toCardanoTxIn refInputs resolvedDatums <- mapM (viewByRef txSkelOutDatumL) refInputs return $ Cardano.TxInsReference Cardano.BabbageEraOnwardsConway cardanoRefInputs $ diff --git a/src/Cooked/MockChain/GenerateTx/Withdrawals.hs b/src/Cooked/MockChain/GenerateTx/Withdrawals.hs index e07242247..dafaaef31 100644 --- a/src/Cooked/MockChain/GenerateTx/Withdrawals.hs +++ b/src/Cooked/MockChain/GenerateTx/Withdrawals.hs @@ -4,19 +4,25 @@ module Cooked.MockChain.GenerateTx.Withdrawals (toWithdrawals) where import Cardano.Api qualified as Cardano import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad -import Cooked.MockChain.BlockChain -import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.Error import Cooked.MockChain.GenerateTx.Witness -import Cooked.Skeleton +import Cooked.MockChain.Read +import Cooked.Skeleton.User +import Cooked.Skeleton.Withdrawal import Data.Coerce import Ledger.Tx.CardanoAPI qualified as Ledger import Optics.Core import Plutus.Script.Utils.Address qualified as Script import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V1.Value qualified as Api +import Polysemy +import Polysemy.Error -- | Takes a 'TxSkelWithdrawals' and transforms it into a 'Cardano.TxWithdrawals' -toWithdrawals :: (MonadBlockChainBalancing m) => TxSkelWithdrawals -> m (Cardano.TxWithdrawals Cardano.BuildTx Cardano.ConwayEra) +toWithdrawals :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + TxSkelWithdrawals -> + Sem effs (Cardano.TxWithdrawals Cardano.BuildTx Cardano.ConwayEra) toWithdrawals withdrawals | withdrawals == mempty = return Cardano.TxWithdrawalsNone toWithdrawals (view txSkelWithdrawalsListI -> withdrawals) = do networkId <- Emulator.pNetworkId <$> getParams @@ -24,17 +30,13 @@ toWithdrawals (view txSkelWithdrawalsListI -> withdrawals) = do let coinAmount = maybe (Cardano.Coin 0) coerce amount (sCred, witness) <- case user of UserPubKey (Script.toPubKeyHash -> pkh) -> do - sCred <- - throwOnToCardanoError "toWithdrawals: unable to translate pkh stake credential" $ - Cardano.StakeCredentialByKey <$> Ledger.toCardanoStakeKeyHash pkh + sCred <- fromEither $ Cardano.StakeCredentialByKey <$> Ledger.toCardanoStakeKeyHash pkh return (sCred, Cardano.KeyWitness Cardano.KeyWitnessForStakeAddr) UserRedeemedScript (toVScript -> vScript) red -> do witness <- Cardano.ScriptWitness Cardano.ScriptWitnessForStakeAddr <$> toScriptWitness vScript red Cardano.NoScriptDatumForStake - sCred <- - throwOnToCardanoError "toWithdrawals: unable to translate script stake credential" $ - Cardano.StakeCredentialByScript <$> Ledger.toCardanoScriptHash (Script.toScriptHash vScript) + sCred <- fromEither $ Cardano.StakeCredentialByScript <$> Ledger.toCardanoScriptHash (Script.toScriptHash vScript) return (sCred, witness) return (Cardano.makeStakeAddress networkId sCred, coinAmount, Cardano.BuildTxWith witness) return $ Cardano.TxWithdrawals Cardano.ShelleyBasedEraConway cardanoWithdrawals diff --git a/src/Cooked/MockChain/GenerateTx/Witness.hs b/src/Cooked/MockChain/GenerateTx/Witness.hs index 6dec00f17..36e3beb83 100644 --- a/src/Cooked/MockChain/GenerateTx/Witness.hs +++ b/src/Cooked/MockChain/GenerateTx/Witness.hs @@ -1,122 +1,53 @@ --- | This module exposes the generation of witnesses and reward account +-- | This module exposes the generation of key and script witnesses module Cooked.MockChain.GenerateTx.Witness - ( toRewardAccount, - toCardanoCredential, - toScriptWitness, + ( toScriptWitness, toKeyWitness, - toStakeCredential, - deserialiseFromBuiltinByteString, - toScriptHash, - toKeyHash, - toDRepCredential, - toStakePoolKeyHash, - toColdCredential, - toHotCredential, - toVRFVerKeyHash, ) where import Cardano.Api qualified as Cardano -import Cardano.Ledger.BaseTypes qualified as C.Ledger -import Cardano.Ledger.Hashes qualified as C.Ledger -import Cardano.Ledger.Shelley.API qualified as C.Ledger -import Control.Monad.Except (throwError) -import Cooked.MockChain.BlockChain -import Cooked.MockChain.GenerateTx.Common +import Cooked.MockChain.Error +import Cooked.MockChain.Read import Cooked.Skeleton import Ledger.Address qualified as Ledger import Ledger.Tx.CardanoAPI qualified as Ledger import Optics.Core import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api - --- | Translates a given credential to a reward account. -toRewardAccount :: (MonadBlockChainBalancing m) => Api.Credential -> m C.Ledger.RewardAccount -toRewardAccount = (C.Ledger.RewardAccount C.Ledger.Testnet <$>) . toCardanoCredential Cardano.AsStakeKey Cardano.unStakeKeyHash - --- TODO: if this works, migrate to plutus-ledger - --- | Converts an 'Api.PubKeyHash' to any kind of key -deserialiseFromBuiltinByteString :: - (MonadBlockChainBalancing m, Cardano.SerialiseAsRawBytes a) => - Cardano.AsType a -> - Api.BuiltinByteString -> - m a -deserialiseFromBuiltinByteString asType = - throwOnToCardanoError "deserialiseFromBuiltinByteString" . Ledger.deserialiseFromRawBytes asType . Api.fromBuiltin - --- | Converts a plutus script hash into a cardano ledger script hash -toScriptHash :: (MonadBlockChainBalancing m) => Api.ScriptHash -> m C.Ledger.ScriptHash -toScriptHash (Api.ScriptHash sHash) = do - Cardano.ScriptHash cHash <- deserialiseFromBuiltinByteString Cardano.AsScriptHash sHash - return cHash - --- | Converts a plutus pkhash into a certain cardano ledger hash -toKeyHash :: - (MonadBlockChainBalancing m, Cardano.SerialiseAsRawBytes (Cardano.Hash key)) => - Cardano.AsType key -> - (Cardano.Hash key -> C.Ledger.KeyHash kr) -> - Api.PubKeyHash -> - m (C.Ledger.KeyHash kr) -toKeyHash asType unwrap = fmap unwrap . deserialiseFromBuiltinByteString (Cardano.AsHash asType) . Api.getPubKeyHash - --- | Converts an 'Api.PubKeyHash' into a cardano ledger stake pool key hash -toStakePoolKeyHash :: (MonadBlockChainBalancing m) => Api.PubKeyHash -> m (C.Ledger.KeyHash 'C.Ledger.StakePool) -toStakePoolKeyHash = toKeyHash Cardano.AsStakePoolKey Cardano.unStakePoolKeyHash - --- | Converts an 'Api.PubKeyHash' into a cardano ledger VRFVerKeyHash -toVRFVerKeyHash :: (MonadBlockChainBalancing m) => Api.PubKeyHash -> m (C.Ledger.VRFVerKeyHash a) -toVRFVerKeyHash (Api.PubKeyHash pkh) = do - Cardano.VrfKeyHash key <- deserialiseFromBuiltinByteString (Cardano.AsHash Cardano.AsVrfKey) pkh - return $ C.Ledger.toVRFVerKeyHash key - --- | Converts an 'Api.Credential' to a Cardano Credential of the expected kind -toCardanoCredential :: - (MonadBlockChainBalancing m, Cardano.SerialiseAsRawBytes (Cardano.Hash key)) => - Cardano.AsType key -> - (Cardano.Hash key -> C.Ledger.KeyHash kr) -> - Api.Credential -> - m (C.Ledger.Credential kr) -toCardanoCredential _ _ (Api.ScriptCredential sHash) = C.Ledger.ScriptHashObj <$> toScriptHash sHash -toCardanoCredential asType unwrap (Api.PubKeyCredential pkHash) = C.Ledger.KeyHashObj <$> toKeyHash asType unwrap pkHash - --- | Translates a credential into a Cardano stake credential -toStakeCredential :: (MonadBlockChainBalancing m) => Api.Credential -> m (C.Ledger.Credential 'C.Ledger.Staking) -toStakeCredential = toCardanoCredential Cardano.AsStakeKey Cardano.unStakeKeyHash - --- | Translates a credential into a Cardano drep credential -toDRepCredential :: (MonadBlockChainBalancing m) => Api.Credential -> m (C.Ledger.Credential 'C.Ledger.DRepRole) -toDRepCredential = toCardanoCredential Cardano.AsDRepKey Cardano.unDRepKeyHash - --- | Translates a credential into a Cardano cold committee credential -toColdCredential :: (MonadBlockChainBalancing m) => Api.Credential -> m (C.Ledger.Credential 'C.Ledger.ColdCommitteeRole) -toColdCredential = toCardanoCredential Cardano.AsCommitteeColdKey Cardano.unCommitteeColdKeyHash - --- | Translates a credential into a Cardano hot committee credential -toHotCredential :: (MonadBlockChainBalancing m) => Api.Credential -> m (C.Ledger.Credential 'C.Ledger.HotCommitteeRole) -toHotCredential = toCardanoCredential Cardano.AsCommitteeHotKey Cardano.unCommitteeHotKeyHash +import Polysemy +import Polysemy.Error -- | Translates a script and a reference script utxo into either a plutus script -- or a reference input containing the right script -toPlutusScriptOrReferenceInput :: (MonadBlockChainBalancing m) => VScript -> Maybe Api.TxOutRef -> m (Cardano.PlutusScriptOrReferenceInput lang) -toPlutusScriptOrReferenceInput (Script.Versioned (Script.Script script) _) Nothing = return $ Cardano.PScript $ Cardano.PlutusScriptSerialised script +toPlutusScriptOrReferenceInput :: + (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) => + VScript -> + Maybe Api.TxOutRef -> + Sem effs (Cardano.PlutusScriptOrReferenceInput lang) +toPlutusScriptOrReferenceInput (Script.Versioned (Script.Script script) _) Nothing = + return $ Cardano.PScript $ Cardano.PlutusScriptSerialised script toPlutusScriptOrReferenceInput (Script.toScriptHash -> scriptHash) (Just scriptOutRef) = do (preview txSkelOutReferenceScriptHashAF -> mScriptHash) <- txSkelOutByRef scriptOutRef case mScriptHash of Just scriptHash' - | scriptHash == scriptHash' -> - Cardano.PReferenceScript - <$> throwOnToCardanoError - "toPlutusScriptOrReferenceInput: Unable to translate reference script utxo." - (Ledger.toCardanoTxIn scriptOutRef) - _ -> throwError $ MCEWrongReferenceScriptError scriptOutRef scriptHash mScriptHash + | scriptHash == scriptHash' -> do + s <- fromEither $ Ledger.toCardanoTxIn scriptOutRef + return $ Cardano.PReferenceScript s + _ -> throw $ MCEWrongReferenceScriptError scriptOutRef scriptHash mScriptHash -- | Translates a script with its associated redeemer and datum to a script -- witness. Note on the usage of 'Ledger.zeroExecutionUnits': at this stage of -- the transaction create, we cannot know the execution units used by the -- script. They will be filled out later on once the full body has been -- generated. So, for now, we temporarily leave them to 0. -toScriptWitness :: (MonadBlockChainBalancing m, ToVScript a) => a -> TxSkelRedeemer -> Cardano.ScriptDatum b -> m (Cardano.ScriptWitness b Cardano.ConwayEra) +toScriptWitness :: + ( Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs, + ToVScript a + ) => + a -> + TxSkelRedeemer -> + Cardano.ScriptDatum b -> + Sem effs (Cardano.ScriptWitness b Cardano.ConwayEra) toScriptWitness (toVScript -> script@(Script.Versioned _ version)) (TxSkelRedeemer {..}) datum = do let scriptData = Ledger.toCardanoScriptData $ Api.toBuiltinData txSkelRedeemerContent case version of @@ -132,7 +63,10 @@ toScriptWitness (toVScript -> script@(Script.Versioned _ version)) (TxSkelRedeem -- | Generates a key witnesses for a given signatory and body, when the -- signatory contains a private key. -toKeyWitness :: Cardano.TxBody Cardano.ConwayEra -> TxSkelSignatory -> Maybe (Cardano.KeyWitness Cardano.ConwayEra) +toKeyWitness :: + Cardano.TxBody Cardano.ConwayEra -> + TxSkelSignatory -> + Maybe (Cardano.KeyWitness Cardano.ConwayEra) toKeyWitness txBody = fmap ( Cardano.makeShelleyKeyWitness Cardano.ShelleyBasedEraConway txBody diff --git a/src/Cooked/MockChain/Instances.hs b/src/Cooked/MockChain/Instances.hs new file mode 100644 index 000000000..4b06b1d9c --- /dev/null +++ b/src/Cooked/MockChain/Instances.hs @@ -0,0 +1,249 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module exposes concrete instances to run a mockchain. There are 4 of +-- them : +-- +-- - `DirectMockChain` exposes the minimal set of effects required to run a +-- mockchain, without the ability to branch or modify runs. Use this only if +-- you specifically want to disallow Ltl modifications (which behaves the same +-- in the absence of modifications). In should also perform somewhat better, +-- also in most cases this will be insignificant. +-- +-- - `StagedMockChain` exposes all the primitives required to run a mockchain, +-- with the addition of branching and Ltl modifications using tweaks. This +-- should be the environement to use in 99% of the cases. +-- +-- - `StagedInjectMockChain` exposes the same primitives as `StagedMockChain`, +-- with an additional custom effect that can both be used in the main thread +-- and in the associated tweaks. This allows a mockchain run to depend on +-- arbitrary additional effects (if multiple effects are needed, this single +-- effect can be instantiated to a bundle). +-- +-- - `FullMockChain` exposes all the effects used to process a mockchain run, +-- including intermediate effects usually hidden. This should only be used +-- when the users requires to manually execute internal primitives of cooked, +-- such as balancing. +module Cooked.MockChain.Instances where + +import Cooked.Ltl +import Cooked.MockChain.Error +import Cooked.MockChain.Journal +import Cooked.MockChain.Log +import Cooked.MockChain.Misc +import Cooked.MockChain.Read +import Cooked.MockChain.Runnable +import Cooked.MockChain.State +import Cooked.MockChain.Tweak +import Cooked.MockChain.Write +import Ledger.Tx qualified as Ledger +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.NonDet +import Polysemy.State +import Polysemy.Writer + +-- | The most direct stack of effects to run a mockchain +type DirectEffs = + '[ MockChainWrite, + MockChainRead, + MockChainMisc, + Fail + ] + +-- | A mockchain computation builds on top of the `DirectEffs` stack of effects +type DirectMockChain a = Sem DirectEffs a + +instance RunnableMockChain DirectEffs where + runMockChain mcst = + (: []) + . run + . runWriter + . runMockChainLog fromLogEntry + . runState mcst + . runError + . runToCardanoErrorInMockChainError + . runFailInMockChainError + . runMockChainMisc fromAlias fromNote fromAssert + . runMockChainRead + . runMockChainWrite + . insertAt @4 + @[ Error Ledger.ToCardanoError, + Error MockChainError, + State MockChainState, + MockChainLog, + Writer MockChainJournal + ] + +-- | A stack of effects aimed at being used as modifications for a +-- `StagedMockChain` computation +type StagedTweakEffs = + '[ MockChainMisc, + MockChainRead, + Fail + ] + +-- | A tweak computation based on the `StagedTweakEffs` stack of effects +type StagedTweak a = TypedTweak StagedTweakEffs a + +-- | A stack of effects which allows everything allowed by `DirectEffs` with the +-- addition of branching and `Ltl` modification with tweaks living in +-- `StagedTweakEffs` +type StagedEffs = + '[ ModifyGlobally (UntypedTweak StagedTweakEffs), + MockChainWrite, + MockChainMisc, + MockChainRead, + Fail, + NonDet + ] + +-- | A mockchain computation builds on top of the `StagedEffs` stack of effects +type StagedMockChain a = Sem StagedEffs a + +instance RunnableMockChain StagedEffs where + runMockChain mcst = + run + . runNonDet + . runWriter + . runMockChainLog fromLogEntry + . runState mcst + . runError + . runToCardanoErrorInMockChainError + . runFailInMockChainError + . runMockChainRead + . runMockChainMisc fromAlias fromNote fromAssert + . evalState [] + . runModifyLocally + . runMockChainWrite + . insertAt @6 + @[ Error Ledger.ToCardanoError, + Error MockChainError, + State MockChainState, + MockChainLog, + Writer MockChainJournal + ] + . reinterpretMockChainWriteWithTweak @StagedTweakEffs + . runModifyGlobally + . insertAt @2 + @[ ModifyLocally (UntypedTweak StagedTweakEffs), + State [Ltl (UntypedTweak StagedTweakEffs)] + ] + +-- | A stack of effects aimed at being used as modifications for a +-- `FullMockChain` computation +type FullTweakEffs = + '[ MockChainMisc, + MockChainRead, + Fail, + Error Ledger.ToCardanoError, + Error MockChainError, + State MockChainState, + MockChainLog, + Writer MockChainJournal + ] + +-- | A tweak computation based on the `FullTweakEffs` stack of effects +type FullTweak a = TypedTweak FullTweakEffs a + +-- | A stack of effects which allows everything allowed by `StagedEffs` with the +-- addition of all the lower level effects required to interpret it. +type FullEffs = + '[ ModifyGlobally (UntypedTweak FullTweakEffs), + MockChainWrite, + ModifyLocally (UntypedTweak FullTweakEffs), + State [Ltl (UntypedTweak FullTweakEffs)], + MockChainMisc, + MockChainRead, + Fail, + Error Ledger.ToCardanoError, + Error MockChainError, + State MockChainState, + MockChainLog, + Writer MockChainJournal, + NonDet + ] + +-- | A mockchain computation builds on top of the `FullEffs` stack of effects +type FullMockChain a = Sem FullEffs a + +instance RunnableMockChain FullEffs where + runMockChain mcst = + run + . runNonDet + . runWriter + . runMockChainLog fromLogEntry + . runState mcst + . runError + . runToCardanoErrorInMockChainError + . runFailInMockChainError + . runMockChainRead + . runMockChainMisc fromAlias fromNote fromAssert + . evalState [] + . runModifyLocally + . runMockChainWrite + . reinterpretMockChainWriteWithTweak @FullTweakEffs + . runModifyGlobally + +------------------------------------- + +class Interpret eff where + runInterpret :: Sem (eff : effs) a -> Sem effs a + +-- | A stack of effects aimed at being used as modifications for a +-- `StagedMockChain` computation +type StagedInjectTweakEff injEff = + '[ injEff, + MockChainMisc, + MockChainRead, + Fail + ] + +-- | A tweak computation based on the `StagedInjectTweakEff` stack of effects +type StagedInjectTweak injEff a = TypedTweak (StagedInjectTweakEff injEff) a + +-- | A stack of effects which allows everything allowed by `DirectEff` with the +-- addition of branching and `Ltl` modification with tweaks living in +-- `StagedInjectTweakEff` +type StagedInjectEff injEff = + '[ ModifyGlobally (UntypedTweak (StagedInjectTweakEff injEff)), + MockChainWrite, + injEff, + MockChainMisc, + MockChainRead, + Fail, + NonDet + ] + +-- | A mockchain computation builds on top of the `StagedInjectEff` stack of effects +type StagedInjectMockChain injEff a = Sem (StagedInjectEff injEff) a + +instance (Interpret injEff) => RunnableMockChain (StagedInjectEff injEff) where + runMockChain mcst = + run + . runNonDet + . runWriter + . runMockChainLog fromLogEntry + . runState mcst + . runError + . runToCardanoErrorInMockChainError + . runFailInMockChainError + . runMockChainRead + . runMockChainMisc fromAlias fromNote fromAssert + . runInterpret + . evalState [] + . runModifyLocally + . runMockChainWrite + . insertAt @7 + @[ Error Ledger.ToCardanoError, + Error MockChainError, + State MockChainState, + MockChainLog, + Writer MockChainJournal + ] + . reinterpretMockChainWriteWithTweak @(StagedInjectTweakEff injEff) + . runModifyGlobally + . insertAt @2 + @[ ModifyLocally (UntypedTweak (StagedInjectTweakEff injEff)), + State [Ltl (UntypedTweak (StagedInjectTweakEff injEff))] + ] diff --git a/src/Cooked/MockChain/Journal.hs b/src/Cooked/MockChain/Journal.hs new file mode 100644 index 000000000..fc9bc6a5e --- /dev/null +++ b/src/Cooked/MockChain/Journal.hs @@ -0,0 +1,49 @@ +-- | This module exposes the various events emitted during a mockchain run. +module Cooked.MockChain.Journal where + +import Cooked.MockChain.Log +import Cooked.Pretty.Class +import Cooked.Pretty.Options +import Data.Map +import Data.Map qualified as Map +import PlutusLedgerApi.V3 qualified as Api + +-- | This represents the writable elements that can be emitted throughout a +-- mockchain run. +data MockChainJournal where + MockChainJournal :: + { -- | Log entries generated by cooked-validators + mcbLog :: [MockChainLogEntry], + -- | Aliases stored by the user + mcbAliases :: Map Api.BuiltinByteString String, + -- | Notes taken by the user, parameterized by some pretty cooked options, + -- to get a better display at the end of the run + mcbNotes :: [PrettyCookedOpts -> DocCooked], + -- | Assertions gathered during the run, alongside their associated error + -- messages to display in case of failure + mcbAssertions :: [(String, Bool)] + } -> + MockChainJournal + +instance Semigroup MockChainJournal where + MockChainJournal l a n p <> MockChainJournal l' a' n' p' = + MockChainJournal (l <> l') (a <> a') (n <> n') (p <> p') + +instance Monoid MockChainJournal where + mempty = MockChainJournal mempty mempty mempty mempty + +-- | Build a `MockChainJournal` from a single log entry +fromLogEntry :: MockChainLogEntry -> MockChainJournal +fromLogEntry entry = mempty {mcbLog = [entry]} + +-- | Build a `MockChainJournal` from a single alias +fromAlias :: String -> Api.BuiltinByteString -> MockChainJournal +fromAlias s hash = mempty {mcbAliases = Map.singleton hash s} + +-- | Build a `MockChainJournal` from a single note +fromNote :: (PrettyCookedOpts -> DocCooked) -> MockChainJournal +fromNote s = mempty {mcbNotes = [s]} + +-- | Build a `MockChainJournal` from a single assertion and error message +fromAssert :: String -> Bool -> MockChainJournal +fromAssert s p = mempty {mcbAssertions = [(s, p)]} diff --git a/src/Cooked/MockChain/Log.hs b/src/Cooked/MockChain/Log.hs new file mode 100644 index 000000000..173eb1807 --- /dev/null +++ b/src/Cooked/MockChain/Log.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module exposes primitives required to log internal pieces of +-- information during a mockchain run. This includes, in particular, all the +-- adjustment automatically done by \cooked-validators\ during the transaction +-- processing phase. This effect is typically not available to users, and should +-- solely be used to track internal events. To trace additional elements from a +-- user's perspective, use `Cooked.MockChain.Misc.note` instead. +module Cooked.MockChain.Log + ( -- * Logging events + MockChainLogEntry (..), + + -- * Logging effect + MockChainLog, + runMockChainLog, + + -- * Logging primitive + logEvent, + ) +where + +import Cooked.MockChain.Common +import Cooked.Skeleton +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Writer + +-- | Events logged when processing transaction skeletons +data MockChainLogEntry + = -- | Logging a Skeleton as it is submitted by the user. + MCLogSubmittedTxSkel TxSkel + | -- | Logging a Skeleton as it has been adjusted by the balancing mechanism, + -- alongside fee, and possible collateral utxos and return collateral user. + MCLogAdjustedTxSkel TxSkel Fee Collaterals + | -- | Logging the successful validation of a new transaction, with its id and + -- number of produced outputs. + MCLogNewTx Api.TxId Integer + | -- | Logging the fact that utxos provided by the user for balancing have to be + -- discarded for a specific reason. + MCLogDiscardedUtxos Integer String + | -- | Logging the fact that utxos provided as collaterals will not be used + -- because the transaction does not involve scripts. There are 2 cases, + -- depending on whether the user has provided an explicit user or a set of + -- utxos to be used as collaterals. + MCLogUnusedCollaterals (Either Peer CollateralIns) + | -- | Logging the automatic addition of a reference script + MCLogAddedReferenceScript TxSkelRedeemer Api.TxOutRef Script.ScriptHash + | -- | Logging the automatic addition of a withdrawal amount + MCLogAutoFilledWithdrawalAmount Api.Credential Api.Lovelace + | -- | Logging the automatic addition of the constitution script + MCLogAutoFilledConstitution Api.ScriptHash + | -- | Logging the automatic adjustment of a min ada amount + MCLogAdjustedTxSkelOut TxSkelOut Api.Lovelace + deriving (Show) + +-- | An effect to allow logging of mockchain events +data MockChainLog :: Effect where + LogEvent :: MockChainLogEntry -> MockChainLog m () + +makeSem_ ''MockChainLog + +-- | Interpreting a `MockChainLog` in terms of a writer of +-- @[MockChainLogEntry]@ +runMockChainLog :: + (Member (Writer j) effs) => + (MockChainLogEntry -> j) -> + Sem (MockChainLog : effs) a -> + Sem effs a +runMockChainLog inject = interpret $ \(LogEvent event) -> tell $ inject event + +-- | Logs an internal event occurring while processing a transaction skeleton +logEvent :: (Member MockChainLog effs) => MockChainLogEntry -> Sem effs () diff --git a/src/Cooked/MockChain/Misc.hs b/src/Cooked/MockChain/Misc.hs new file mode 100644 index 000000000..a7654396b --- /dev/null +++ b/src/Cooked/MockChain/Misc.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module defines primitives that offer quality of life features when +-- operating a mockchain without interacting with the mockchain state itself. +module Cooked.MockChain.Misc + ( -- * Misc effect + MockChainMisc (..), + runMockChainMisc, + + -- * Storing aliases for hashable elements + define, + defineM, + + -- * Taking notes in the notebook + note, + noteP, + noteL, + noteW, + noteS, + + -- * Asserting properties + assert, + assert', + ) +where + +import Cooked.Pretty.Class +import Cooked.Pretty.Hashable +import Cooked.Pretty.Options +import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Writer +import Prettyprinter qualified as PP + +-- | An effect that corresponds to extra QOL capabilities of the MockChain +data MockChainMisc :: Effect where + Define :: (ToHash a) => String -> a -> MockChainMisc m a + Note :: (PrettyCookedOpts -> DocCooked) -> MockChainMisc m () + Assert :: String -> Bool -> MockChainMisc m () + +makeSem_ ''MockChainMisc + +-- | Interpreting a `MockChainMisc` in terms of a writer of @Map +-- BuiltinByteString String@ +runMockChainMisc :: + forall effs a j. + (Member (Writer j) effs) => + (String -> Api.BuiltinByteString -> j) -> + ((PrettyCookedOpts -> DocCooked) -> j) -> + (String -> Bool -> j) -> + Sem (MockChainMisc : effs) a -> + Sem effs a +runMockChainMisc injectAlias injectNote injectPred = interpret $ \case + (Define name hashable) -> tell (injectAlias name $ toHash hashable) >> return hashable + (Note s) -> tell $ injectNote s + (Assert s b) -> tell $ injectPred s b + +-- | Stores an alias matching a hashable data for pretty printing purpose +define :: forall effs a. (Member MockChainMisc effs, ToHash a) => String -> a -> Sem effs a + +-- | Like `define`, but binds the result of a monadic computation instead +defineM :: (Member MockChainMisc effs, ToHash a) => String -> Sem effs a -> Sem effs a +defineM name = (define name =<<) + +-- | Takes note of an element represented as its rendering function to trace at +-- the end of the run +note :: forall effs. (Member MockChainMisc effs) => (PrettyCookedOpts -> DocCooked) -> Sem effs () + +-- | Takes note of a pretty-printable element to trace at the end of the run +noteP :: forall effs s. (Member MockChainMisc effs, PrettyCooked s) => s -> Sem effs () +noteP doc = note (`prettyCookedOpt` doc) + +-- | Takes note of a pretty-printable element as list with a title, to trace at +-- the end of the run +noteL :: forall effs l. (Member MockChainMisc effs, PrettyCookedList l) => String -> l -> Sem effs () +noteL title docs = note $ \opts -> prettyItemize opts (prettyCooked title) "-" docs + +-- | Takes note of a showable element to trace at the end of the run +noteW :: forall effs s. (Member MockChainMisc effs, Show s) => s -> Sem effs () +noteW = note . const . PP.viaShow + +-- | Takes note of a String to trace at the end of the run +noteS :: forall effs. (Member MockChainMisc effs) => String -> Sem effs () +noteS = noteP + +-- | Ensures a specific property holds, sending the provided error message otherwise +assert :: forall effs. (Member MockChainMisc effs) => String -> Bool -> Sem effs () + +-- | Ensures a specific property holds, with a default error message otherwise +assert' :: forall effs. (Member MockChainMisc effs) => Bool -> Sem effs () +assert' = assert "Assertion error" diff --git a/src/Cooked/MockChain/MockChainState.hs b/src/Cooked/MockChain/MockChainState.hs deleted file mode 100644 index 39c3d4b34..000000000 --- a/src/Cooked/MockChain/MockChainState.hs +++ /dev/null @@ -1,87 +0,0 @@ --- | This module exposes the internal state in which our direct simulation is --- run, and functions to update and query it. -module Cooked.MockChain.MockChainState - ( MockChainState (..), - mcstParamsL, - mcstLedgerStateL, - mcstOutputsL, - mcstConstitutionL, - mcstToUtxoState, - addOutput, - removeOutput, - ) -where - -import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Cooked.MockChain.UtxoState -import Cooked.Skeleton -import Data.Default -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Ledger.Orphans () -import Optics.Core -import Optics.TH -import PlutusLedgerApi.V3 qualified as Api - --- | The state used to run the simulation in 'Cooked.MockChain.Direct' -data MockChainState where - MockChainState :: - { -- | The parametors of the emulated blockchain - mcstParams :: Emulator.Params, - -- | The ledger state of the emulated blockchain - mcstLedgerState :: Emulator.EmulatedLedgerState, - -- | Associates to each 'Api.TxOutRef' the 'TxSkelOut' that produced it, - -- alongside a boolean to state whether this UTxO is still present in the - -- index ('True') or has already been consumed ('False'). - mcstOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), - -- | The constitution script to be used with proposals - mcstConstitution :: Maybe VScript - } -> - MockChainState - deriving (Show) - --- | A lens to set or get the parameters of the 'MockChainState' -makeLensesFor [("mcstParams", "mcstParamsL")] ''MockChainState - --- | A lens to set or get the ledger state of the 'MockChainState' -makeLensesFor [("mcstLedgerState", "mcstLedgerStateL")] ''MockChainState - --- | A lens to set or get the outputs of the 'MockChainState' -makeLensesFor [("mcstOutputs", "mcstOutputsL")] ''MockChainState - --- | A lens to set or get the constitution script of the 'MockChainState' -makeLensesFor [("mcstConstitution", "mcstConstitutionL")] ''MockChainState - -instance Default MockChainState where - def = MockChainState def (Emulator.initialState def) Map.empty Nothing - --- | Builds a 'UtxoState' from a 'MockChainState' -mcstToUtxoState :: MockChainState -> UtxoState -mcstToUtxoState = - foldl extractPayload mempty . Map.toList . mcstOutputs - where - extractPayload :: UtxoState -> (Api.TxOutRef, (TxSkelOut, Bool)) -> UtxoState - extractPayload utxoState (txOutRef, (txSkelOut, bool)) = - let newAddress = view txSkelOutAddressG txSkelOut - newPayloadSet = - UtxoPayloadSet - [ UtxoPayload - txOutRef - (view txSkelOutValueL txSkelOut) - ( case txSkelOut ^. txSkelOutDatumL of - NoTxSkelOutDatum -> NoUtxoPayloadDatum - SomeTxSkelOutDatum content kind -> SomeUtxoPayloadDatum content (kind /= Inline) - ) - (preview txSkelOutReferenceScriptHashAF txSkelOut) - ] - in if bool - then utxoState {availableUtxos = Map.insertWith (<>) newAddress newPayloadSet (availableUtxos utxoState)} - else utxoState {consumedUtxos = Map.insertWith (<>) newAddress newPayloadSet (consumedUtxos utxoState)} - --- | Stores an output in a 'MockChainState' -addOutput :: Api.TxOutRef -> TxSkelOut -> MockChainState -> MockChainState -addOutput oRef txSkelOut = over mcstOutputsL (Map.insert oRef (txSkelOut, True)) - --- | Removes an output from the 'MockChainState' -removeOutput :: Api.TxOutRef -> MockChainState -> MockChainState -removeOutput oRef = over mcstOutputsL (Map.update (\(output, _) -> Just (output, False)) oRef) diff --git a/src/Cooked/MockChain/Read.hs b/src/Cooked/MockChain/Read.hs new file mode 100644 index 000000000..07413fd63 --- /dev/null +++ b/src/Cooked/MockChain/Read.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module exposes primitives to query the current state of the +-- blockchain. +module Cooked.MockChain.Read + ( -- * The `MockChainRead` effect + MockChainRead, + runMockChainRead, + + -- * Queries related to protocol parameters + getParams, + govActionDeposit, + dRepDeposit, + stakeAddressDeposit, + stakePoolDeposit, + + -- * Queries related to `Cooked.Skeleton.TxSkel` + txSkelDepositedValueInCertificates, + txSkelDepositedValueInProposals, + txSkelAllScripts, + txSkelInputScripts, + txSkelInputValue, + + -- * Queries related to timing + currentSlot, + currentMSRange, + getEnclosingSlot, + slotRangeBefore, + slotRangeAfter, + slotToMSRange, + + -- * Queries related to fetching UTxOs + allUtxos, + utxosAt, + txSkelOutByRef, + utxosFromCardanoTx, + lookupUtxos, + previewByRef, + viewByRef, + + -- * Other queries + getConstitutionScript, + getCurrentReward, + ) +where + +import Cardano.Api qualified as Cardano +import Cardano.Ledger.Conway.Core qualified as Conway +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Control.Lens qualified as Lens +import Control.Monad +import Cooked.MockChain.Common +import Cooked.MockChain.Error +import Cooked.MockChain.GenerateTx.Credential (toStakeCredential) +import Cooked.MockChain.State +import Cooked.Skeleton +import Data.Coerce (coerce) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe +import Ledger.Slot qualified as Ledger +import Ledger.Tx qualified as Ledger +import Ledger.Tx.CardanoAPI qualified as Ledger +import Optics.Core +import Plutus.Script.Utils.Address qualified as Script +import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.State + +-- | An effect that offers primitives to query the current state of the +-- mockchain. As its name suggests, this effect is read-only and does not alter +-- the state in any way. +data MockChainRead :: Effect where + GetParams :: MockChainRead m Emulator.Params + TxSkelOutByRef :: Api.TxOutRef -> MockChainRead m TxSkelOut + CurrentSlot :: MockChainRead m Ledger.Slot + AllUtxos :: MockChainRead m Utxos + UtxosAt :: (Script.ToCredential a) => a -> MockChainRead m Utxos + GetConstitutionScript :: MockChainRead m (Maybe VScript) + GetCurrentReward :: (Script.ToCredential c) => c -> MockChainRead m (Maybe Api.Lovelace) + +makeSem_ ''MockChainRead + +-- | The interpretation for read-only effect in the blockchain state +runMockChainRead :: + forall effs a. + ( Members + '[ State MockChainState, + Error Ledger.ToCardanoError, + Error MockChainError + ] + effs + ) => + Sem (MockChainRead : effs) a -> + Sem effs a +runMockChainRead = interpret $ \case + GetParams -> gets mcstParams + TxSkelOutByRef oRef -> do + res <- gets $ Map.lookup oRef . mcstOutputs + case res of + Just (txSkelOut, True) -> return txSkelOut + _ -> throw $ MCEUnknownOutRef oRef + AllUtxos -> fetchUtxos $ const True + UtxosAt (Script.toCredential -> cred) -> fetchUtxos $ (== cred) . Script.toCredential + CurrentSlot -> gets $ view $ mcstLedgerStateL % to Emulator.getSlot + GetConstitutionScript -> gets $ view mcstConstitutionL + GetCurrentReward (Script.toCredential -> cred) -> do + stakeCredential <- toStakeCredential cred + gets $ + preview $ + mcstLedgerStateL + % to (Emulator.getReward stakeCredential) + % _Just + % to coerce + where + fetchUtxos decide = + gets $ + toListOf $ + mcstOutputsL + % to Map.toList + % traversed + % filtered (snd . snd) + % filtered (decide . fst . snd) + % to (fmap fst) + +-- | Returns the emulator parameters, including protocol parameters +getParams :: + (Member MockChainRead effs) => + Sem effs Emulator.Params + +-- | Retrieves the required governance action deposit amount +govActionDeposit :: + (Member MockChainRead effs) => + Sem effs Api.Lovelace +govActionDeposit = + getParams + <&> Api.Lovelace + . Cardano.unCoin + . Lens.view Conway.ppGovActionDepositL + . Emulator.emulatorPParams + +-- | Retrieves the required drep deposit amount +dRepDeposit :: + (Member MockChainRead effs) => + Sem effs Api.Lovelace +dRepDeposit = + getParams + <&> Api.Lovelace + . Cardano.unCoin + . Lens.view Conway.ppDRepDepositL + . Emulator.emulatorPParams + +-- | Retrieves the required stake address deposit amount +stakeAddressDeposit :: + (Member MockChainRead effs) => + Sem effs Api.Lovelace +stakeAddressDeposit = + getParams + <&> Api.Lovelace + . Cardano.unCoin + . Lens.view Conway.ppKeyDepositL + . Emulator.emulatorPParams + +-- | Retrieves the required stake pool deposit amount +stakePoolDeposit :: + (Member MockChainRead effs) => + Sem effs Api.Lovelace +stakePoolDeposit = + getParams + <&> Api.Lovelace + . Cardano.unCoin + . Lens.view Conway.ppPoolDepositL + . Emulator.emulatorPParams + +-- | Retrieves the total amount of lovelace deposited in certificates in this +-- skeleton. Note that unregistering a staking address or a dRep lead to a +-- negative deposit (a withdrawal, in fact) which means this function can return +-- a negative amount of lovelace, which is intended. The deposited amounts are +-- dictated by the current protocol parameters, and computed as such. +txSkelDepositedValueInCertificates :: + (Member MockChainRead effs) => + TxSkel -> + Sem effs Api.Lovelace +txSkelDepositedValueInCertificates txSkel = do + sDep <- stakeAddressDeposit + dDep <- dRepDeposit + pDep <- stakePoolDeposit + return $ + foldOf + ( txSkelCertificatesL + % traversed + % to + ( \case + TxSkelCertificate _ StakingRegister {} -> sDep + TxSkelCertificate _ StakingRegisterDelegate {} -> sDep + TxSkelCertificate _ StakingUnRegister {} -> -sDep + TxSkelCertificate _ DRepRegister {} -> dDep + TxSkelCertificate _ DRepUnRegister {} -> -dDep + TxSkelCertificate _ PoolRegister {} -> pDep + -- There is no special case for 'PoolRetire' because the deposit + -- is given back to the reward account. + _ -> Api.Lovelace 0 + ) + ) + txSkel + +-- | Retrieves the total amount of lovelace deposited in proposals in this +-- skeleton (equal to `govActionDeposit` times the number of proposals) +txSkelDepositedValueInProposals :: + (Member MockChainRead effs) => + TxSkel -> + Sem effs Api.Lovelace +txSkelDepositedValueInProposals TxSkel {txSkelProposals} = + govActionDeposit + <&> Api.Lovelace + . (toInteger (length txSkelProposals) *) + . Api.getLovelace + +-- | Returns all scripts involved in this 'TxSkel' +txSkelAllScripts :: + (Member MockChainRead effs) => + TxSkel -> + Sem effs [VScript] +txSkelAllScripts txSkel = do + txSkelSpendingScripts <- txSkelInputScripts txSkel + return + ( txSkelMintingScripts txSkel + <> txSkelWithdrawingScripts txSkel + <> txSkelProposingScripts txSkel + <> txSkelCertifyingScripts txSkel + <> txSkelSpendingScripts + ) + +-- | Returns all scripts which guard transaction inputs +txSkelInputScripts :: + (Member MockChainRead effs) => + TxSkel -> + Sem effs [VScript] +txSkelInputScripts = + fmap catMaybes + . mapM (previewByRef (txSkelOutOwnerL % userVScriptAT)) + . Map.keys + . txSkelIns + +-- | look up the UTxOs the transaction consumes, and sum their values. +txSkelInputValue :: + (Member MockChainRead effs) => + TxSkel -> + Sem effs Api.Value +txSkelInputValue = + fmap mconcat + . mapM (viewByRef txSkelOutValueL) + . Map.keys + . txSkelIns + +-- | Returns the current slot +currentSlot :: + (Member MockChainRead effs) => + Sem effs Ledger.Slot + +-- | Returns the closed ms interval corresponding to the current slot +currentMSRange :: + (Members '[MockChainRead, Fail] effs) => + Sem effs (Api.POSIXTime, Api.POSIXTime) +currentMSRange = slotToMSRange =<< currentSlot + +-- | Return the slot that contains the given time. See 'slotToMSRange' for +-- some satisfied equational properties. +getEnclosingSlot :: + (Member MockChainRead effs) => + Api.POSIXTime -> + Sem effs Ledger.Slot +getEnclosingSlot t = + getParams + <&> (`Emulator.posixTimeToEnclosingSlot` t) + . Emulator.pSlotConfig + +-- | The infinite range of slots ending before or at the given time +slotRangeBefore :: + (Members '[MockChainRead, Fail] effs) => + Api.POSIXTime -> + Sem effs Ledger.SlotRange +slotRangeBefore t = do + n <- getEnclosingSlot t + (_, b) <- slotToMSRange n + -- If the given time @t@ happens to be the last ms of its slot, we can include + -- the whole slot. Otherwise, the only way to be sure that the returned slot + -- range contains no time after @t@ is to go to the preceding slot. + return $ Api.to $ if t == b then n else n - 1 + +-- | The infinite range of slots starting after or at the given time +slotRangeAfter :: + (Members '[MockChainRead, Fail] effs) => + Api.POSIXTime -> + Sem effs Ledger.SlotRange +slotRangeAfter t = do + n <- getEnclosingSlot t + (a, _) <- slotToMSRange n + return $ Api.from $ if t == a then n else n + 1 + +-- | Returns the closed ms interval corresponding to the slot with the given +-- number. It holds that +-- +-- > slotToMSRange (getEnclosingSlot t) == (a, b) ==> a <= t <= b +-- +-- and +-- +-- > slotToMSRange n == (a, b) ==> getEnclosingSlot a == n && getEnclosingSlot b == n +-- +-- and +-- +-- > slotToMSRange n == (a, b) ==> getEnclosingSlot (a-1) == n-1 && getEnclosingSlot (b+1) == n+1 +slotToMSRange :: + ( Members '[MockChainRead, Fail] effs, + Integral i + ) => + i -> + Sem effs (Api.POSIXTime, Api.POSIXTime) +slotToMSRange (fromIntegral -> slot) = do + slotConfig <- Emulator.pSlotConfig <$> getParams + case Emulator.slotToPOSIXTimeRange slotConfig slot of + Api.Interval + (Api.LowerBound (Api.Finite l) leftclosed) + (Api.UpperBound (Api.Finite r) rightclosed) -> + return + ( if leftclosed then l else l + 1, + if rightclosed then r else r - 1 + ) + _ -> fail "Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues" + +-- | Returns a list of all currently known outputs +allUtxos :: + (Member MockChainRead effs) => + Sem effs Utxos + +-- | Returns a list of all UTxOs at a certain address. +utxosAt :: + ( Member MockChainRead effs, + Script.ToCredential cred + ) => + cred -> + Sem effs Utxos + +-- | Returns an output given a reference to it +txSkelOutByRef :: + (Member MockChainRead effs) => + Api.TxOutRef -> + Sem effs TxSkelOut + +-- | Retrieves the ordered list of outputs of the given "CardanoTx". +-- +-- This is useful when writing endpoints and/or traces to fetch utxos of +-- interest right from the start and avoid querying the chain for them +-- afterwards using 'allUtxos' or similar functions. +utxosFromCardanoTx :: + (Member MockChainRead effs) => + Ledger.CardanoTx -> + Sem effs [(Api.TxOutRef, TxSkelOut)] +utxosFromCardanoTx = + mapM (\txOutRef -> (txOutRef,) <$> txSkelOutByRef txOutRef) + . fmap (Ledger.fromCardanoTxIn . snd) + . Ledger.getCardanoTxOutRefs + +-- | Go through all of the 'Api.TxOutRef's in the list and look them up in the +-- state of the blockchain, throwing an error if one of them cannot be resolved. +lookupUtxos :: + (Member MockChainRead effs) => + [Api.TxOutRef] -> + Sem effs (Map Api.TxOutRef TxSkelOut) +lookupUtxos = + foldM + (\m oRef -> flip (Map.insert oRef) m <$> txSkelOutByRef oRef) + Map.empty + +-- | Retrieves an output and views a specific element out of it +viewByRef :: + ( Member MockChainRead effs, + Is g A_Getter + ) => + Optic' g is TxSkelOut c -> + Api.TxOutRef -> + Sem effs c +viewByRef optic = (view optic <$>) . txSkelOutByRef + +-- | Retrieves an output and previews a specific element out of it +previewByRef :: + ( Member MockChainRead effs, + Is af An_AffineFold + ) => + Optic' af is TxSkelOut c -> + Api.TxOutRef -> + Sem effs (Maybe c) +previewByRef optic = (preview optic <$>) . txSkelOutByRef + +-- | Gets the current official constitution script +getConstitutionScript :: + (Member MockChainRead effs) => + Sem effs (Maybe VScript) + +-- | Gets the current reward associated with a credential +getCurrentReward :: + ( Member MockChainRead effs, + Script.ToCredential c + ) => + c -> + Sem effs (Maybe Api.Lovelace) diff --git a/src/Cooked/MockChain/Runnable.hs b/src/Cooked/MockChain/Runnable.hs new file mode 100644 index 000000000..7225dffbc --- /dev/null +++ b/src/Cooked/MockChain/Runnable.hs @@ -0,0 +1,151 @@ +-- | This module exposes the infrastructure to execute mockchain runs. In +-- particular: +-- +-- - The notion of initial distribution (a list of payments) +-- +-- - The return types of the runs (raw and refined) +-- +-- - The initial configuration with which to execute a run +-- +-- - The notion of `RunnableMockChain` to actually execute computations +module Cooked.MockChain.Runnable where + +import Cooked.MockChain.Error +import Cooked.MockChain.Journal +import Cooked.MockChain.State +import Cooked.MockChain.Write +import Cooked.Skeleton.Output +import Cooked.Wallet +import Data.Default +import Data.List (foldl') +import Data.Map (Map) +import Plutus.Script.Utils.Value qualified as Script +import PlutusLedgerApi.V3 qualified as Api +import Polysemy + +-- * Initial distribution of funds + +-- | Describes the initial distribution of UTxOs per user. +-- +-- The following specifies a starting state where @wallet 1@ owns two UTxOs, +-- one with 42 Ada and one with 2 Ada and one "TOK" token; @wallet 2@ owns a +-- single UTxO with 10 Ada and @wallet 3@ has 10 Ada and a permanent value +-- +-- > i0 = distributionFromList $ +-- > [ (wallet 1 , [ ada 42 , ada 2 <> quickValue "TOK" 1 ] +-- > , (wallet 2 , [ ada 10 ]) +-- > , (wallet 3 , [ ada 10 <> permanentValue "XYZ" 10]) +-- > ] +-- +-- Note that payment issued through an initial distribution will be attached +-- enough ADA to sustain themselves. +data InitialDistribution where + InitialDistribution :: + {unInitialDistribution :: [TxSkelOut]} -> + InitialDistribution + +-- | 4 UTxOs with 100 Ada each, for each of the first 4 'knownWallets' +instance Default InitialDistribution where + def = + distributionFromList + . zip (take 4 knownWallets) + . repeat + . replicate 4 + $ Script.ada 100 + +instance Semigroup InitialDistribution where + i <> j = InitialDistribution (unInitialDistribution i <> unInitialDistribution j) + +instance Monoid InitialDistribution where + mempty = InitialDistribution mempty + +-- | Creating a initial distribution with simple values assigned to owners +distributionFromList :: (IsTxSkelOutAllowedOwner owner) => [(owner, [Api.Value])] -> InitialDistribution +distributionFromList = + InitialDistribution + . foldl' (\x (user, values) -> x <> map (receives user . Value) values) [] + +-- | Raw return type of running a mockchain +type RawMockChainReturn a = + (MockChainJournal, (MockChainState, Either MockChainError a)) + +-- | The returned type when running a mockchain. This is both a reorganizing and +-- filtering of the natural returned type `RawMockChainReturn`. +data MockChainReturn a where + MockChainReturn :: + { -- | The value returned by the computation, or an error + mcrValue :: Either MockChainError a, + -- | The outputs at the end of the run + mcrOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), + -- | The 'UtxoState' at the end of the run + mcrUtxoState :: UtxoState, + -- | The final journal emitted during the run + mcrJournal :: MockChainJournal + } -> + MockChainReturn a + deriving (Functor) + +-- | The type of functions transforming an element of type @RawMockChainReturn a@ +-- into an element of type @b@ +type FunOnMockChainResult a b = RawMockChainReturn a -> b + +-- | Building a `MockChainReturn` from a `RawMockChainReturn` +unRawMockChainReturn :: FunOnMockChainResult a (MockChainReturn a) +unRawMockChainReturn (journal, (st, val)) = + MockChainReturn val (mcstOutputs st) (mcstToUtxoState st) journal + +-- | Configuration from which to run a mockchain +data MockChainConf a b where + MockChainConf :: + { -- | The initial state from which to run the mockchain + mccInitialState :: MockChainState, + -- | The initial payments to issue in the run + mccInitialDistribution :: InitialDistribution, + -- | The function to apply on the results of the run + mccFunOnResult :: FunOnMockChainResult a b + } -> + MockChainConf a b + +-- | The default `MockChainConf`, which uses the default initial state and +-- initial distribution, and returns a refined `MockChainReturn` +mockChainConfTemplate :: MockChainConf a (MockChainReturn a) +mockChainConfTemplate = MockChainConf def def unRawMockChainReturn + +-- | The class of effects that represent a mockchain run +class RunnableMockChain effs where + -- | Runs a computation from an initial `MockChainState`, while returning a + -- list of `RawMockChainReturn` + runMockChain :: MockChainState -> Sem effs a -> [RawMockChainReturn a] + +-- | Runs a `RunnableMockChain` from an initial `MockChainConf` +runMockChainFromConf :: + ( RunnableMockChain effs, + Member MockChainWrite effs + ) => + MockChainConf a b -> + Sem effs a -> + [b] +runMockChainFromConf (MockChainConf initState initDist funOnResult) currentRun = + fmap funOnResult $ + runMockChain initState $ + forceOutputs (unInitialDistribution initDist) >> currentRun + +-- | Runs a `RunnableMockChain` from an initial distribution +runMockChainFromInitDist :: + ( RunnableMockChain effs, + Member MockChainWrite effs + ) => + InitialDistribution -> + Sem effs a -> + [MockChainReturn a] +runMockChainFromInitDist initDist = + runMockChainFromConf $ mockChainConfTemplate {mccInitialDistribution = initDist} + +-- | Runs a `RunnableMockChain` from a default configuration +runMockChainDef :: + ( RunnableMockChain effs, + Member MockChainWrite effs + ) => + Sem effs a -> + [MockChainReturn a] +runMockChainDef = runMockChainFromConf mockChainConfTemplate diff --git a/src/Cooked/MockChain/Staged.hs b/src/Cooked/MockChain/Staged.hs deleted file mode 100644 index 17ed6e6a8..000000000 --- a/src/Cooked/MockChain/Staged.hs +++ /dev/null @@ -1,223 +0,0 @@ --- | This module provides a staged implementation of our `MonadBlockChain`. The --- motivation is to be able to modify transactions with `Cooked.Tweak`s deployed --- in time with `Cooked.Ltl` while the computation gets interpreted, and before --- the transactions are sent for validation. -module Cooked.MockChain.Staged - ( -- * 'StagedMockChain': An AST of mockchain computations - MockChainBuiltin, - InterpMockChain, - MockChainTweak, - StagedMockChain, - - -- * Interpreting and running a 'StagedMockChain' - interpretAndRunWith, - interpretAndRun, - - -- * Temporal modalities - MonadModalBlockChain, - withTweak, - somewhere, - somewhere', - everywhere, - everywhere', - there, - there', - nowhere, - nowhere', - whenAble, - whenAble', - ) -where - -import Cardano.Node.Emulator qualified as Emulator -import Control.Applicative -import Control.Monad -import Control.Monad.Except -import Cooked.Ltl -import Cooked.MockChain.BlockChain -import Cooked.MockChain.Direct -import Cooked.Pretty.Hashable -import Cooked.Skeleton -import Cooked.Tweak.Common -import Ledger.Slot qualified as Ledger -import Ledger.Tx qualified as Ledger -import Plutus.Script.Utils.Address qualified as Script -import PlutusLedgerApi.V3 qualified as Api - --- | Abstract representation of all the builtin functions of a 'MonadBlockChain' -data MockChainBuiltin a where - -- Builtins of 'MonadBlockChain' - GetParams :: MockChainBuiltin Emulator.Params - SetParams :: Emulator.Params -> MockChainBuiltin () - ValidateTxSkel :: TxSkel -> MockChainBuiltin Ledger.CardanoTx - TxSkelOutByRef :: Api.TxOutRef -> MockChainBuiltin TxSkelOut - WaitNSlots :: (Integral i) => i -> MockChainBuiltin Ledger.Slot - AllUtxos :: MockChainBuiltin [(Api.TxOutRef, TxSkelOut)] - UtxosAt :: (Script.ToAddress a) => a -> MockChainBuiltin [(Api.TxOutRef, TxSkelOut)] - LogEvent :: MockChainLogEntry -> MockChainBuiltin () - Define :: (ToHash a) => String -> a -> MockChainBuiltin a - SetConstitutionScript :: (ToVScript s) => s -> MockChainBuiltin () - GetConstitutionScript :: MockChainBuiltin (Maybe VScript) - GetCurrentReward :: (Script.ToCredential c) => c -> MockChainBuiltin (Maybe Api.Lovelace) - ForceOutputs :: [TxSkelOut] -> MockChainBuiltin [Api.TxOutRef] - -- The empty set of traces - Empty :: MockChainBuiltin a - -- The union of two sets of traces - Alt :: StagedMockChain a -> StagedMockChain a -> MockChainBuiltin a - -- for the 'MonadError MockChainError' instance - ThrowError :: MockChainError -> MockChainBuiltin a - CatchError :: StagedMockChain a -> (MockChainError -> StagedMockChain a) -> MockChainBuiltin a - --- | The domain in which 'StagedMockChain' gets interpreted -type InterpMockChain = MockChainT [] - --- | Tweaks operating within the 'InterpMockChain' domain -type MockChainTweak = UntypedTweak InterpMockChain - --- | A 'StagedMockChain' is an AST of mockchain builtins wrapped into @LtlOp@ to --- be subject to @Ltl@ modifications. -type StagedMockChain = StagedLtl MockChainTweak MockChainBuiltin - -instance Alternative StagedMockChain where - empty = singletonBuiltin Empty - a <|> b = singletonBuiltin $ Alt a b - -instance MonadPlus StagedMockChain where - mzero = empty - mplus = (<|>) - -instance MonadFail StagedMockChain where - fail = singletonBuiltin . ThrowError . FailWith - -instance MonadError MockChainError StagedMockChain where - throwError = singletonBuiltin . ThrowError - catchError act = singletonBuiltin . CatchError act - -instance MonadBlockChainBalancing StagedMockChain where - getParams = singletonBuiltin GetParams - txSkelOutByRef = singletonBuiltin . TxSkelOutByRef - utxosAt = singletonBuiltin . UtxosAt - logEvent = singletonBuiltin . LogEvent - -instance MonadBlockChainWithoutValidation StagedMockChain where - allUtxos = singletonBuiltin AllUtxos - setParams = singletonBuiltin . SetParams - waitNSlots = singletonBuiltin . WaitNSlots - define name = singletonBuiltin . Define name - setConstitutionScript = singletonBuiltin . SetConstitutionScript - getConstitutionScript = singletonBuiltin GetConstitutionScript - getCurrentReward = singletonBuiltin . GetCurrentReward - -instance MonadBlockChain StagedMockChain where - validateTxSkel = singletonBuiltin . ValidateTxSkel - forceOutputs = singletonBuiltin . ForceOutputs - -instance ModInterpBuiltin MockChainTweak MockChainBuiltin InterpMockChain where - modifyAndInterpBuiltin = \case - GetParams -> Left getParams - SetParams params -> Left $ setParams params - ValidateTxSkel skel -> Right $ \now -> do - (_, skel') <- - (`runTweakInChain` skel) $ - foldr - ( \req acc -> case req of - Apply (UntypedTweak tweak) -> tweak >> acc - EnsureFailure (UntypedTweak tweak) -> ensureFailingTweak tweak >> acc - ) - doNothingTweak - now - validateTxSkel skel' - TxSkelOutByRef o -> Left $ txSkelOutByRef o - WaitNSlots s -> Left $ waitNSlots s - AllUtxos -> Left allUtxos - UtxosAt address -> Left $ utxosAt address - LogEvent entry -> Left $ logEvent entry - Define name hash -> Left $ define name hash - SetConstitutionScript script -> Left $ setConstitutionScript script - GetConstitutionScript -> Left getConstitutionScript - GetCurrentReward cred -> Left $ getCurrentReward cred - ForceOutputs outs -> Left $ forceOutputs outs - Empty -> Left mzero - Alt l r -> Left $ interpStagedLtl l `mplus` interpStagedLtl r - ThrowError err -> Left $ throwError err - CatchError act handler -> Left $ catchError (interpStagedLtl act) (interpStagedLtl . handler) - --- | Interprets the staged mockchain then runs the resulting computation with a --- custom function. This can be used, for example, to supply a custom --- 'Cooked.InitialDistribution.InitialDistribution' by providing --- 'runMockChainTFromInitDist'. -interpretAndRunWith :: (forall m. (Monad m) => MockChainT m a -> m res) -> StagedMockChain a -> [res] -interpretAndRunWith f = f . interpStagedLtl - --- | Same as 'interpretAndRunWith' but using 'runMockChainT' as the default way --- to run the computation. -interpretAndRun :: StagedMockChain a -> [MockChainReturn a] -interpretAndRun = interpretAndRunWith runMockChainT - --- | A modal mockchain is a mockchain that allows us to use LTL modifications --- with 'Tweak's -type MonadModalBlockChain m = (MonadBlockChain m, MonadLtl MockChainTweak m) - -fromTweak :: Tweak m a -> Ltl (UntypedTweak m) -fromTweak = LtlAtom . UntypedTweak - --- | Applies a 'Tweak' to every step in a trace where it is applicable, --- branching at any such locations. The tweak must apply at least once. -somewhere :: (MonadModalBlockChain m) => Tweak InterpMockChain b -> m a -> m a -somewhere = somewhere' . fromTweak - --- | Applies an Ltl modification following the same rules as `somewhere`. -somewhere' :: (MonadLtl mod m) => Ltl mod -> m a -> m a -somewhere' = modifyLtl . ltlEventually - --- | Applies a 'Tweak' to every transaction in a given trace. Fails if the tweak --- fails anywhere in the trace. -everywhere :: (MonadModalBlockChain m) => Tweak InterpMockChain b -> m a -> m a -everywhere = everywhere' . fromTweak - --- | Applies a Ltl modification following the sames rules as `everywhere`. -everywhere' :: (MonadLtl mod m) => Ltl mod -> m a -> m a -everywhere' = modifyLtl . ltlAlways - --- | Ensures a given 'Tweak' can never successfully be applied in a computation, --- and leaves the computation unchanged. -nowhere :: (MonadModalBlockChain m) => Tweak InterpMockChain b -> m a -> m a -nowhere = nowhere' . fromTweak - --- | Ensures a given Ltl modifications follow the same rules as `nowhere`. -nowhere' :: (MonadLtl mod m) => Ltl mod -> m a -> m a -nowhere' = modifyLtl . ltlNever - --- | Apply a given 'Tweak' at every location in a computation where it does not --- fail, which might never occur. -whenAble :: (MonadModalBlockChain m) => Tweak InterpMockChain b -> m a -> m a -whenAble = whenAble' . fromTweak - --- | Apply an Ltl modification following the same rules as `whenAble`. -whenAble' :: (MonadLtl mod m) => Ltl mod -> m a -> m a -whenAble' = modifyLtl . ltlWhenPossible - --- | Apply a 'Tweak' to the (0-indexed) nth transaction in a given --- trace. Successful when this transaction exists and can be modified. --- --- See also `Cooked.Tweak.Labels.labelled` to select transactions based on --- labels instead of their index. -there :: (MonadModalBlockChain m) => Integer -> Tweak InterpMockChain b -> m a -> m a -there n = there' n . fromTweak - --- | Apply an Ltl modification following the same rules as `there`. -there' :: (MonadLtl mod m) => Integer -> Ltl mod -> m a -> m a -there' n = modifyLtl . ltlDelay n - --- | Apply a 'Tweak' to the next transaction in the given trace. The order of --- arguments enables an idiom like --- --- > do ... --- > endpoint arguments `withTweak` someModification --- > ... --- --- where @endpoint@ builds and validates a single transaction depending on the --- given @arguments@. Then `withTweak` says "I want to modify the transaction --- returned by this endpoint in the following way". -withTweak :: (MonadModalBlockChain m) => m a -> Tweak InterpMockChain b -> m a -withTweak = flip (there 0) diff --git a/src/Cooked/MockChain/State.hs b/src/Cooked/MockChain/State.hs new file mode 100644 index 000000000..978bb0c0a --- /dev/null +++ b/src/Cooked/MockChain/State.hs @@ -0,0 +1,277 @@ +-- | This module exposes the internal state in which our direct simulation is +-- run (`MockChainState`), as well as a restricted and simplified version +-- (`UtxoState`). The latter only consists of Utxos with a focus on who owns +-- those Utxos. You can see this as having some sort of an "account" view of the +-- ledger state, which typically does not exist in Cardano. This is useful for +-- two reasons: +-- +-- - For printing purposes, where it is much more convient to see the available +-- assets as "who owns what" rather than as a set of mixed Utxos. +-- +-- - For testings purposes, when querying the final state of a run is +-- needed. For instance, properties such as "does Alice indeed owns 3 XXX +-- tokens at the end of this run?" become much easier to express. +module Cooked.MockChain.State + ( -- * `MockChainState` and associated optics + MockChainState (..), + mcstParamsL, + mcstLedgerStateL, + mcstOutputsL, + mcstConstitutionL, + mcstMOutputL, + + -- * Helpers to add or remove outputs from a `MockChainState` + addOutput, + removeOutput, + + -- * `UtxoState`: A simplified, address-focused view on a `MockChainState` + UtxoPayloadDatum (..), + utxoPayloadDatumKindAT, + utxoPayloadDatumTypedAT, + UtxoPayload (..), + utxoPayloadTxOutRefL, + utxoPayloadValueL, + utxoPayloadDatumL, + utxoPayloadMReferenceScriptHashL, + utxoPayloadReferenceScriptHashAT, + UtxoPayloadSet (..), + utxoPayloadSetListI, + UtxoState (..), + availableUtxosL, + consumedUtxosL, + + -- * Querying the assets owned by a given address + holdsInState, + + -- * Transforming a `MockChainState` into an `UtxoState` + mcstToUtxoState, + ) +where + +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Cooked.Skeleton +import Data.Default +import Data.Function (on) +import Data.List qualified as List +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Typeable +import Ledger.Orphans () +import Optics.Core +import Optics.TH +import Plutus.Script.Utils.Address qualified as Script +import PlutusLedgerApi.V1.Value qualified as Api +import PlutusLedgerApi.V3 qualified as Api + +-- | The state used to run the simulation in 'Cooked.MockChain.Direct' +data MockChainState where + MockChainState :: + { -- | The parametors of the emulated blockchain + mcstParams :: Emulator.Params, + -- | The ledger state of the emulated blockchain + mcstLedgerState :: Emulator.EmulatedLedgerState, + -- | Associates to each 'Api.TxOutRef' the 'TxSkelOut' that produced it, + -- alongside a boolean to state whether this UTxO is still present in the + -- index ('True') or has already been consumed ('False'). + mcstOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), + -- | The constitution script to be used with proposals + mcstConstitution :: Maybe VScript + } -> + MockChainState + deriving (Show) + +-- | A lens to set or get the parameters of the 'MockChainState' +makeLensesFor [("mcstParams", "mcstParamsL")] ''MockChainState + +-- | A lens to set or get the ledger state of the 'MockChainState' +makeLensesFor [("mcstLedgerState", "mcstLedgerStateL")] ''MockChainState + +-- | A lens to set or get the outputs of the 'MockChainState' +makeLensesFor [("mcstOutputs", "mcstOutputsL")] ''MockChainState + +-- | A lens to set or get the constitution script of the 'MockChainState' +makeLensesFor [("mcstConstitution", "mcstConstitutionL")] ''MockChainState + +instance Default MockChainState where + def = MockChainState def (Emulator.initialState def) Map.empty Nothing + +-- | Accesses a given available Utxo from a `MockChainState` +mcstMOutputL :: Api.TxOutRef -> Lens' MockChainState (Maybe TxSkelOut) +mcstMOutputL oRef = mcstOutputsL % at oRef % iso (fmap fst) (fmap (,True)) + +-- | Stores an output in a 'MockChainState' +addOutput :: Api.TxOutRef -> TxSkelOut -> MockChainState -> MockChainState +addOutput oRef = set (mcstMOutputL oRef) . Just + +-- | Removes an output from the 'MockChainState' +removeOutput :: Api.TxOutRef -> MockChainState -> MockChainState +removeOutput oRef = set (mcstOutputsL % at oRef) Nothing + +-- | A simplified version of a 'Cooked.Skeleton.Datum.TxSkelOutDatum' which only +-- stores the actual datum and whether it is hashed (@True@) or inline +-- (@False@). The only difference is that whether the datum was resolved in the +-- transaction creating it on the ledger is absent, which makes sense after the +-- fact. +data UtxoPayloadDatum where + NoUtxoPayloadDatum :: UtxoPayloadDatum + SomeUtxoPayloadDatum :: (DatumConstrs dat) => dat -> Bool -> UtxoPayloadDatum + +-- | Focuses on whether on not this `UtxoPayloadDatum` isHashed +utxoPayloadDatumKindAT :: AffineTraversal' UtxoPayloadDatum Bool +utxoPayloadDatumKindAT = + atraversal + ( \case + NoUtxoPayloadDatum -> Left NoUtxoPayloadDatum + SomeUtxoPayloadDatum _ b -> Right b + ) + ( flip + ( \kind -> \case + NoUtxoPayloadDatum -> NoUtxoPayloadDatum + SomeUtxoPayloadDatum content _ -> SomeUtxoPayloadDatum content kind + ) + ) + +-- | Extracts, or sets, the typed datum of a 'UtxoPayloadDatum' following the +-- same rules as `txSkelOutDatumTypedAT` +utxoPayloadDatumTypedAT :: (DatumConstrs a, DatumConstrs b) => AffineTraversal UtxoPayloadDatum UtxoPayloadDatum a b +utxoPayloadDatumTypedAT = + atraversal + ( \case + (SomeUtxoPayloadDatum content _) | Just content' <- cast content -> Right content' + (SomeUtxoPayloadDatum content _) | Just content' <- Api.fromBuiltinData $ Api.toBuiltinData content -> Right content' + dc -> Left dc + ) + ( flip + ( \content -> \case + NoUtxoPayloadDatum -> NoUtxoPayloadDatum + SomeUtxoPayloadDatum _ kind -> SomeUtxoPayloadDatum content kind + ) + ) + +deriving instance Show UtxoPayloadDatum + +instance Ord UtxoPayloadDatum where + compare NoUtxoPayloadDatum NoUtxoPayloadDatum = EQ + compare NoUtxoPayloadDatum _ = LT + compare _ NoUtxoPayloadDatum = GT + compare + (SomeUtxoPayloadDatum (Api.toBuiltinData -> dat) b) + (SomeUtxoPayloadDatum (Api.toBuiltinData -> dat') b') = + compare (dat, b) (dat', b') + +instance Eq UtxoPayloadDatum where + dat == dat' = compare dat dat' == EQ + +-- | A convenient wrapping of the interesting information of a UTxO. +data UtxoPayload where + UtxoPayload :: + { -- | The reference of this UTxO + utxoPayloadTxOutRef :: Api.TxOutRef, + -- | The value stored in this UTxO + utxoPayloadValue :: Api.Value, + -- | The optional datum stored in this UTxO + utxoPayloadDatum :: UtxoPayloadDatum, + -- | The hash of the optional reference script stored in this UTxO + utxoPayloadReferenceScriptHash :: Maybe Api.ScriptHash + } -> + UtxoPayload + deriving (Eq, Show) + +-- | A lens to set or get the UTxO reference from this `UtxoPayload` +makeLensesFor [("utxoPayloadTxOutRef", "utxoPayloadTxOutRefL")] ''UtxoPayload + +-- | A lens to set or get the value from this `UtxoPayload` +makeLensesFor [("utxoPayloadValue", "utxoPayloadValueL")] ''UtxoPayload + +-- | A lens to set or get the datum from this `UtxoPayload` +makeLensesFor [("utxoPayloadDatum", "utxoPayloadDatumL")] ''UtxoPayload + +-- | A lens to set or get the optional reference script hash from this +-- `UtxoPayload` +makeLensesFor [("utxoPayloadReferenceScriptHash", "utxoPayloadMReferenceScriptHashL")] ''UtxoPayload + +-- | Focusing on the optional reference script hash of a `UtxoPayload` +utxoPayloadReferenceScriptHashAT :: AffineTraversal' UtxoPayload Api.ScriptHash +utxoPayloadReferenceScriptHashAT = utxoPayloadMReferenceScriptHashL % _Just + +-- | Represents a /set/ of payloads. +newtype UtxoPayloadSet = UtxoPayloadSet + { -- | List of UTxOs contained in this 'UtxoPayloadSet' + utxoPayloadSet :: [UtxoPayload] + -- We use a list instead of a set because 'Api.Value' doesn't implement 'Ord' + -- and because it is possible that we want to distinguish between utxo states + -- that have additional utxos, even if these could have been merged together. + } + deriving (Show) + +-- | Going back and forth between a list of `UtxoPayload` and a `UtxoPayloadSet` +utxoPayloadSetListI :: Iso' UtxoPayloadSet [UtxoPayload] +utxoPayloadSetListI = iso utxoPayloadSet UtxoPayloadSet + +instance Eq UtxoPayloadSet where + (UtxoPayloadSet xs) == (UtxoPayloadSet ys) = xs' == ys' + where + k (UtxoPayload ref val dat rs) = (ref, Api.flattenValue val, dat, rs) + xs' = List.sortBy (compare `on` k) xs + ys' = List.sortBy (compare `on` k) ys + +instance Semigroup UtxoPayloadSet where + UtxoPayloadSet a <> UtxoPayloadSet b = UtxoPayloadSet $ a ++ b + +instance Monoid UtxoPayloadSet where + mempty = UtxoPayloadSet [] + +-- | A description of who owns what in a blockchain. Owners are addresses and +-- they each own a 'UtxoPayloadSet'. +data UtxoState where + UtxoState :: + { -- | Utxos available to be consumed + availableUtxos :: Map Api.Address UtxoPayloadSet, + -- | Utxos already consumed + consumedUtxos :: Map Api.Address UtxoPayloadSet + } -> + UtxoState + deriving (Eq) + +-- | A lens to set or get the available UTxOs from a `UtxoState` +makeLensesFor [("availableUtxos", "availableUtxosL")] ''UtxoState + +-- | A lens to set or get the consumed UTxOs from a `UtxoState` +makeLensesFor [("consumedUtxos", "consumedUtxosL")] ''UtxoState + +instance Semigroup UtxoState where + (UtxoState a c) <> (UtxoState a' c') = UtxoState (Map.unionWith (<>) a a') (Map.unionWith (<>) c c') + +instance Monoid UtxoState where + mempty = UtxoState Map.empty Map.empty + +-- | Total value accessible to what's pointed by the address. +holdsInState :: (Script.ToAddress a) => a -> UtxoState -> Api.Value +holdsInState (Script.toAddress -> address) = maybe mempty utxoPayloadSetTotal . view (availableUtxosL % at address) + +-- | Computes the total value in a set +utxoPayloadSetTotal :: UtxoPayloadSet -> Api.Value +utxoPayloadSetTotal = foldOf (utxoPayloadSetListI % folded % utxoPayloadValueL) + +-- | Builds a 'UtxoState' from a 'MockChainState' +mcstToUtxoState :: MockChainState -> UtxoState +mcstToUtxoState = + foldl extractPayload mempty . Map.toList . mcstOutputs + where + extractPayload :: UtxoState -> (Api.TxOutRef, (TxSkelOut, Bool)) -> UtxoState + extractPayload utxoState (txOutRef, (txSkelOut, bool)) = + let newAddress = view txSkelOutAddressG txSkelOut + newPayloadSet = + UtxoPayloadSet + [ UtxoPayload + txOutRef + (view txSkelOutValueL txSkelOut) + ( case txSkelOut ^. txSkelOutDatumL of + NoTxSkelOutDatum -> NoUtxoPayloadDatum + SomeTxSkelOutDatum content kind -> SomeUtxoPayloadDatum content (kind /= Inline) + ) + (preview txSkelOutReferenceScriptHashAF txSkelOut) + ] + in if bool + then utxoState {availableUtxos = Map.insertWith (<>) newAddress newPayloadSet (availableUtxos utxoState)} + else utxoState {consumedUtxos = Map.insertWith (<>) newAddress newPayloadSet (consumedUtxos utxoState)} diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index 2df19d739..8fed0b24c 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -1,14 +1,17 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This modules provides primitives to run tests over mockchain executions and -- to provide requirements on the the number and results of these runs. module Cooked.MockChain.Testing where import Control.Exception qualified as E import Control.Monad -import Cooked.InitialDistribution -import Cooked.MockChain.BlockChain -import Cooked.MockChain.Direct -import Cooked.MockChain.Staged -import Cooked.MockChain.UtxoState +import Cooked.MockChain.Error +import Cooked.MockChain.Journal +import Cooked.MockChain.Log +import Cooked.MockChain.Runnable +import Cooked.MockChain.State +import Cooked.MockChain.Write import Cooked.Pretty import Data.Default import Data.List (isInfixOf) @@ -17,6 +20,7 @@ import Data.Text qualified as T import Ledger qualified import Plutus.Script.Utils.Address qualified as Script import PlutusLedgerApi.V1.Value qualified as Api +import Polysemy import Test.QuickCheck qualified as QC import Test.Tasty qualified as HU import Test.Tasty.HUnit qualified as HU @@ -54,6 +58,11 @@ testBool :: (IsProp prop) => Bool -> prop testBool True = testSuccess testBool False = testFailure +-- | Turns a boolean into a @prop@, displaying an error message when applicable +testBoolMsg :: (IsProp prop) => String -> Bool -> prop +testBoolMsg _ True = testSuccess +testBoolMsg msg False = testFailureMsg msg + -- | Ensures all elements of a list satisfy a given @prop@ testAll :: (IsProp prop) => (a -> prop) -> [a] -> prop testAll f = testConjoin . map f @@ -149,19 +158,19 @@ assertSameSets l r = -- * Data structure to test mockchain traces {-- - Note on properties over the journal (or list of 'MockChainLogEntry'): our - 'Test' structure does not directly embed a predicate over the journal. Instead + Note on properties over the log (or list of 'MockChainLogEntry'): our + 'Test' structure does not directly embed a predicate over the log. Instead it is embedded in both the failure and success prediates. The reason is - simple: the journal is generated and accessible in both cases and thus it is + simple: the log is generated and accessible in both cases and thus it is theoretically possible to define predicates that combine requirements over the - journal and the error in case of failure, and the journal and the returning - state and value in the case of success. If the journal predicate was a field + log and the error in case of failure, and the log and the returning + state and value in the case of success. If the log predicate was a field in itself, this link would be broken and it would not be possible to epxress - complex requirements that involve both the journal and other components of the + complex requirements that involve both the log and other components of the returned elements in the mockchain run. Granted, this use cas is extremely rare, but it does not mean our API should not reflect this capability. - However, we also provide 'JournalProp' as in most cases on predicating over - the journal itself will be sufficient. + However, we also provide 'LogProp' as in most cases predicating over + the log itself will be sufficient. --} -- | Type of properties over failures @@ -175,8 +184,8 @@ type SuccessProp a prop = PrettyCookedOpts -> [MockChainLogEntry] -> a -> UtxoSt -- contain anything significant that can be pretty printed. type SizeProp prop = Integer -> prop --- | Type of properties over the mockchain journal -type JournalProp prop = PrettyCookedOpts -> [MockChainLogEntry] -> prop +-- | Type of properties over the mockchain log +type LogProp prop = PrettyCookedOpts -> [MockChainLogEntry] -> prop -- | Type of properties over the 'UtxoState' type StateProp prop = PrettyCookedOpts -> UtxoState -> prop @@ -184,13 +193,12 @@ type StateProp prop = PrettyCookedOpts -> UtxoState -> prop -- | Data structure to test a mockchain trace. @a@ is the return typed of the -- tested trace, @prop@ is the domain in which the properties live. This is not -- enforced here, but it will often be assumed that @prop@ satisfies 'IsProp'. -data Test a prop = Test +data Test effs a prop = Test { -- | The mockchain trace to test, which returns a result of type a - testTrace :: StagedMockChain a, + testTrace :: Sem effs a, -- | The initial distribution from which the trace should be run testInitDist :: InitialDistribution, - -- | The requirement on the number of results, as 'StagedMockChain' is a - -- 'Control.Monad.MonadPlus' + -- | The requirement on the number of results testSizeProp :: SizeProp prop, -- | The property that should hold in case of failure over the resulting -- error and the logs emitted during the run @@ -198,7 +206,7 @@ data Test a prop = Test -- | The property that should hold in case of success over the returned -- result and the final state of the trace, as well as the logs testSuccessProp :: SuccessProp a prop, - -- | The printing option that should be use to render test results + -- | The printing options that should be use to render the test results testPrettyOpts :: PrettyCookedOpts } @@ -208,18 +216,28 @@ data Test a prop = Test -- the nature of these outcomes, either calls 'testFailureProp' or -- 'testSuccessProp'. It also uses the aliases emitted during the mockchain run -- to pretty print messages when applicable. -testToProp :: (IsProp prop, Show a) => Test a prop -> prop +testToProp :: + ( IsProp prop, + Show a, + Member MockChainWrite effs, + RunnableMockChain effs + ) => + Test effs a prop -> + prop testToProp Test {..} = - let results = interpretAndRunWith (runMockChainTFromInitDist testInitDist) testTrace + let results = runMockChainFromConf (mockChainConfTemplate {mccInitialDistribution = testInitDist}) testTrace in testSizeProp (toInteger (length results)) .&&. testAll - ( \ret@(MockChainReturn outcome _ state mcLog names) -> + ( \ret@(MockChainReturn outcome _ state (MockChainJournal mcLog names _ assertions)) -> let pcOpts = addHashNames names testPrettyOpts - in testCounterexample - (renderString (prettyCookedOpt pcOpts) ret) - $ case outcome of - Left err -> testFailureProp pcOpts mcLog err state - Right result -> testSuccessProp pcOpts mcLog result state + in testConjoin + [ testConjoin $ uncurry testBoolMsg <$> assertions, + testCounterexample + (renderString (prettyCookedOpt pcOpts) ret) + $ case outcome of + Left err -> testFailureProp pcOpts mcLog err state + Right result -> testSuccessProp pcOpts mcLog result state + ] ) results @@ -227,17 +245,33 @@ testToProp Test {..} = -- 'HU.testCase' with 'testCooked' and thus avoid the use of 'testToProp'. -- Sadly we cannot generalise it with type classes on @prop@ to work for -- QuichCheck at GHC will never be able to instantiate @prop@. -testCooked :: (Show a) => String -> Test a HU.Assertion -> HU.TestTree +testCooked :: + forall effs a. + ( Show a, + Member MockChainWrite effs, + RunnableMockChain effs + ) => + String -> + Test effs a HU.Assertion -> + HU.TestTree testCooked name = HU.testCase name . testToProp -- | Same as 'testCooked', but for 'QC.Property' -testCookedQC :: (Show a) => String -> Test a QC.Property -> HU.TestTree +testCookedQC :: + forall effs a. + ( Show a, + Member MockChainWrite effs, + RunnableMockChain effs + ) => + String -> + Test effs a QC.Property -> + HU.TestTree testCookedQC name = QC.testProperty name . testToProp -- * Simple test templates -- | A test template which expects a success from a trace -mustSucceedTest :: (IsProp prop) => StagedMockChain a -> Test a prop +mustSucceedTest :: (IsProp prop) => Sem effs a -> Test effs a prop mustSucceedTest trace = Test { testTrace = trace, @@ -249,7 +283,7 @@ mustSucceedTest trace = } -- | A test template which expects a failure from a trace -mustFailTest :: (IsProp prop) => StagedMockChain a -> Test a prop +mustFailTest :: (IsProp prop) => Sem effs a -> Test effs a prop mustFailTest trace = Test { testTrace = trace, @@ -263,45 +297,45 @@ mustFailTest trace = -- * Appending elements (in particular requirements) to existing tests -- | Gives an initial distribution from which the trace will be run -withInitDist :: Test a prop -> InitialDistribution -> Test a prop +withInitDist :: Test effs a prop -> InitialDistribution -> Test effs a prop withInitDist test initDist = test {testInitDist = initDist} -- | Gives some pretty options to render test messages -withPrettyOpts :: Test a prop -> PrettyCookedOpts -> Test a prop +withPrettyOpts :: Test effs a prop -> PrettyCookedOpts -> Test effs a prop withPrettyOpts test opts = test {testPrettyOpts = opts} -- | Appends a requirements over the emitted log, which will need to be satisfied -- both in case of success or failure of the run. -withJournalProp :: (IsProp prop) => Test a prop -> JournalProp prop -> Test a prop -withJournalProp test journalProp = +withLogProp :: (IsProp prop) => Test effs a prop -> LogProp prop -> Test effs a prop +withLogProp test logProp = test - { testFailureProp = \opts journal err state -> testFailureProp test opts journal err state .&&. journalProp opts journal, - testSuccessProp = \opts journal val state -> testSuccessProp test opts journal val state .&&. journalProp opts journal + { testFailureProp = \opts log err state -> testFailureProp test opts log err state .&&. logProp opts log, + testSuccessProp = \opts log val state -> testSuccessProp test opts log val state .&&. logProp opts log } -- | Appends a requirements over the resulting 'UtxoState', which will need to -- be satisfied both in case of success or failure of the run. -withStateProp :: (IsProp prop) => Test a prop -> StateProp prop -> Test a prop +withStateProp :: (IsProp prop) => Test effs a prop -> StateProp prop -> Test effs a prop withStateProp test stateProp = test - { testFailureProp = \opts journal err state -> testFailureProp test opts journal err state .&&. stateProp opts state, - testSuccessProp = \opts journal val state -> testSuccessProp test opts journal val state .&&. stateProp opts state + { testFailureProp = \opts log err state -> testFailureProp test opts log err state .&&. stateProp opts state, + testSuccessProp = \opts log val state -> testSuccessProp test opts log val state .&&. stateProp opts state } -- | Appends a requirement over the resulting value and state of the mockchain -- run which will need to be satisfied if the run is successful -withSuccessProp :: (IsProp prop) => Test a prop -> SuccessProp a prop -> Test a prop +withSuccessProp :: (IsProp prop) => Test effs a prop -> SuccessProp a prop -> Test effs a prop withSuccessProp test successProp = test - { testSuccessProp = \opts journal val state -> testSuccessProp test opts journal val state .&&. successProp opts journal val state + { testSuccessProp = \opts log val state -> testSuccessProp test opts log val state .&&. successProp opts log val state } -- | Same as 'withSuccessProp' but only considers the returning value of the run -withResultProp :: (IsProp prop) => Test a prop -> (a -> prop) -> Test a prop +withResultProp :: (IsProp prop) => Test effs a prop -> (a -> prop) -> Test effs a prop withResultProp test p = withSuccessProp test (\_ _ res _ -> p res) -- | Appends a requirement over the resulting number of outcomes of the run -withSizeProp :: (IsProp prop) => Test a prop -> SizeProp prop -> Test a prop +withSizeProp :: (IsProp prop) => Test effs a prop -> SizeProp prop -> Test effs a prop withSizeProp test reqSize = test { testSizeProp = \size -> testSizeProp test size .&&. reqSize size @@ -309,11 +343,11 @@ withSizeProp test reqSize = -- | Appends a requirement over the resulting value and state of the mockchain -- run which will need to be satisfied if the run is successful -withFailureProp :: (IsProp prop) => Test a prop -> FailureProp prop -> Test a prop -withFailureProp test failureProp = test {testFailureProp = \opts journal err state -> testFailureProp test opts journal err state .&&. failureProp opts journal err state} +withFailureProp :: (IsProp prop) => Test effs a prop -> FailureProp prop -> Test effs a prop +withFailureProp test failureProp = test {testFailureProp = \opts log err state -> testFailureProp test opts log err state .&&. failureProp opts log err state} -- | Same as 'withFailureProp' but only considers the returning error of the run -withErrorProp :: (IsProp prop) => Test a prop -> (MockChainError -> prop) -> Test a prop +withErrorProp :: (IsProp prop) => Test effs a prop -> (MockChainError -> prop) -> Test effs a prop withErrorProp test errorProp = withFailureProp test (\_ _ err _ -> errorProp err) -- * Specific properties around failures @@ -355,21 +389,21 @@ isAtMostOfSize :: (IsProp prop) => Integer -> SizeProp prop isAtMostOfSize n1 n2 | n1 >= n2 = testSuccess isAtMostOfSize n1 n2 = testFailureMsg $ "Incorrect number of results (expected at most: " <> show n1 <> " but got: " <> show n2 <> ")" --- * Specific properties over the journal +-- * Specific properties over the log -- | Ensures a certain event has been emitted. This uses the constructor's name -- of the 'MockChainLogEntry' by relying on 'show' being lazy. -happened :: (IsProp prop) => String -> JournalProp prop -happened eventName _ journal - | allEventNames <- Set.fromList (head . words . show <$> journal) = +happened :: (IsProp prop) => String -> LogProp prop +happened eventName _ log + | allEventNames <- Set.fromList (head . words . show <$> log) = if eventName `Set.member` allEventNames then testSuccess else testFailureMsg $ "The event " <> show eventName <> " did not occur (but those did: " <> show allEventNames <> ")" -- | Ensures a certain event has not been emitted. This uses the constructor's -- name of the 'MockChainLogEntry' by relying on 'show' being lazy. -didNotHappen :: (IsProp prop) => String -> JournalProp prop -didNotHappen eventName _ journal | not (eventName `Set.member` Set.fromList (head . words . show <$> journal)) = testSuccess +didNotHappen :: (IsProp prop) => String -> LogProp prop +didNotHappen eventName _ log | not (eventName `Set.member` Set.fromList (head . words . show <$> log)) = testSuccess didNotHappen eventName _ _ = testFailureMsg $ "The event " <> show eventName <> " was forbidden but occurred nonetheless" -- * Specific properties over successes @@ -413,25 +447,25 @@ possesses w ac n = isAtAddress [(w, [(ac, (== n))])] --} -- | A test template which expects a Phase 2 failure -mustFailInPhase2Test :: (IsProp prop) => StagedMockChain a -> Test a prop -mustFailInPhase2Test run = mustFailTest run `withFailureProp` isPhase2Failure +mustFailInPhase2Test :: (IsProp prop) => Sem effs a -> Test effs a prop +mustFailInPhase2Test trace = mustFailTest trace `withFailureProp` isPhase2Failure -- | A test template which expects a specific phase 2 error message -mustFailInPhase2WithMsgTest :: (IsProp prop) => String -> StagedMockChain a -> Test a prop -mustFailInPhase2WithMsgTest msg run = mustFailTest run `withFailureProp` isPhase2FailureWithMsg msg +mustFailInPhase2WithMsgTest :: (IsProp prop) => String -> Sem effs a -> Test effs a prop +mustFailInPhase2WithMsgTest msg trace = mustFailTest trace `withFailureProp` isPhase2FailureWithMsg msg -- | A test template which expects a Phase 1 failure -mustFailInPhase1Test :: (IsProp prop) => StagedMockChain a -> Test a prop -mustFailInPhase1Test run = mustFailTest run `withFailureProp` isPhase1Failure +mustFailInPhase1Test :: (IsProp prop) => Sem effs a -> Test effs a prop +mustFailInPhase1Test trace = mustFailTest trace `withFailureProp` isPhase1Failure -- | A test template which expects a specific phase 1 error message -mustFailInPhase1WithMsgTest :: (IsProp prop) => String -> StagedMockChain a -> Test a prop -mustFailInPhase1WithMsgTest msg run = mustFailTest run `withFailureProp` isPhase1FailureWithMsg msg +mustFailInPhase1WithMsgTest :: (IsProp prop) => String -> Sem effs a -> Test effs a prop +mustFailInPhase1WithMsgTest msg trace = mustFailTest trace `withFailureProp` isPhase1FailureWithMsg msg -- | A test template which expects a certain number of successful outcomes -mustSucceedWithSizeTest :: (IsProp prop) => Integer -> StagedMockChain a -> Test a prop -mustSucceedWithSizeTest size run = mustSucceedTest run `withSizeProp` (testBool . (== size)) +mustSucceedWithSizeTest :: (IsProp prop) => Integer -> Sem effs a -> Test effs a prop +mustSucceedWithSizeTest size trace = mustSucceedTest trace `withSizeProp` (testBool . (== size)) -- | A test template which expects a certain number of unsuccessful outcomes -mustFailWithSizeTest :: (IsProp prop) => Integer -> StagedMockChain a -> Test a prop -mustFailWithSizeTest size run = mustFailTest run `withSizeProp` isOfSize size +mustFailWithSizeTest :: (IsProp prop) => Integer -> Sem effs a -> Test effs a prop +mustFailWithSizeTest size trace = mustFailTest trace `withSizeProp` isOfSize size diff --git a/src/Cooked/MockChain/Tweak.hs b/src/Cooked/MockChain/Tweak.hs new file mode 100644 index 000000000..d97f4e57f --- /dev/null +++ b/src/Cooked/MockChain/Tweak.hs @@ -0,0 +1,140 @@ +-- | This module applies the `Cooked.Tweak.Common.Tweak` effect for the purpose +-- of modifying transaction skeleton before sending them for validation. +module Cooked.MockChain.Tweak + ( -- * Modifying mockchain runs using tweaks + reinterpretMockChainWriteWithTweak, + + -- * Typed and Untyped tweaks geared for `Cooked.Skeleton.TxSkel` + + -- modifications + TypedTweak, + UntypedTweak (..), + + -- * Modalities to deploy `UntypedTweak`s on time + somewhere, + everywhere, + nowhere, + whenAble, + there, + withTweak, + ) +where + +import Control.Monad +import Cooked.Ltl +import Cooked.MockChain.Write +import Cooked.Tweak.Common +import Data.Coerce +import Polysemy +import Polysemy.Internal +import Polysemy.NonDet + +-- | A stack of effects starting with `Tweak` and `NonDet` +type TypedTweak tweakEffs a = Sem (Tweak : NonDet : tweakEffs) a + +-- | Wrapping up typed tweaks to existentially quantify on their return type +data UntypedTweak tweakEffs where + UntypedTweak :: TypedTweak tweakEffs a -> UntypedTweak tweakEffs + +fromTweak :: + TypedTweak tweakEffs a -> + Ltl (UntypedTweak tweakEffs) +fromTweak = LtlAtom . UntypedTweak + +-- | Applies a 'Tweak' to every step in a trace where it is applicable, +-- branching at any such locations. The tweak must apply at least once. +somewhere :: + (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + TypedTweak tweakEffs b -> + Sem effs a -> + Sem effs a +somewhere = modifyLtl . ltlEventually . fromTweak + +-- | Applies a 'Tweak' to every transaction in a given trace. Fails if the tweak +-- fails anywhere in the trace. +everywhere :: + (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + TypedTweak tweakEffs b -> + Sem effs a -> + Sem effs a +everywhere = modifyLtl . ltlAlways . fromTweak + +-- | Ensures a given 'Tweak' can never successfully be applied in a computation, +-- and leaves the computation unchanged. +nowhere :: + (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + TypedTweak tweakEffs b -> + Sem effs a -> + Sem effs a +nowhere = modifyLtl . ltlNever . fromTweak + +-- | Apply a given 'Tweak' at every location in a computation where it does not +-- fail, which might never occur. +whenAble :: + (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + TypedTweak tweakEffs b -> + Sem effs a -> + Sem effs a +whenAble = modifyLtl . ltlWhenPossible . fromTweak + +-- | Apply a 'Tweak' to the (0-indexed) nth transaction in a given +-- trace. Successful when this transaction exists and can be modified. +-- +-- See also `Cooked.Tweak.Labels.labelled` to select transactions based on +-- labels instead of their index. +there :: + (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + Integer -> + TypedTweak tweakEffs b -> + Sem effs a -> + Sem effs a +there n = modifyLtl . ltlDelay n . fromTweak + +-- | Apply a 'Tweak' to the next transaction in the given trace. The order of +-- arguments enables an idiom like +-- +-- > do ... +-- > endpoint arguments `withTweak` someModification +-- > ... +-- +-- where @endpoint@ builds and validates a single transaction depending on the +-- given @arguments@. Then `withTweak` says "I want to modify the transaction +-- returned by this endpoint in the following way". +withTweak :: + (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + Sem effs a -> + TypedTweak tweakEffs b -> + Sem effs a +withTweak = flip (there 0) + +-- | Reinterpretes `MockChainWrite` in itself, when the `ModifyLocally` effect +-- exists in the stack, applying the relevant modifications in the process. +reinterpretMockChainWriteWithTweak :: + forall tweakEffs effs a. + ( Members + '[ ModifyLocally (UntypedTweak tweakEffs), + NonDet + ] + effs, + Subsume tweakEffs effs + ) => + Sem (MockChainWrite : effs) a -> + Sem (MockChainWrite : effs) a +reinterpretMockChainWriteWithTweak = reinterpret @MockChainWrite $ \case + ValidateTxSkel skel -> do + requirements <- getRequirements + let sumTweak :: TypedTweak tweakEffs () = + foldr + ( \req acc -> case req of + Apply (UntypedTweak tweak) -> tweak >> acc + EnsureFailure (UntypedTweak tweak) -> do + txSkel' <- getTxSkel + results <- raise_ $ runNonDet @[] $ runTweak txSkel' tweak + guard $ null results + acc + ) + (return ()) + requirements + newTxSkel <- raise $ subsume_ $ fst <$> runTweak skel sumTweak + validateTxSkel newTxSkel + a -> send $ coerce a diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/MockChain/UtxoSearch.hs index e377df67b..1e8841973 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/src/Cooked/MockChain/UtxoSearch.hs @@ -1,149 +1,251 @@ --- | This module provides a convenient framework to look through UTxOs and --- search relevant ones based on predicates. For instance, it makes it very --- convenient to gather all UTxOs at a certain address. +-- | This module provides a convenient framework to look through UTxOs and: +-- - filter them in a convenient manner +-- - extract pieces of information from them module Cooked.MockChain.UtxoSearch - ( UtxoSearch, - runUtxoSearch, + ( -- * UTxO searches + UtxoSearch, + beginSearch, + + -- * Processing search result + UtxoSearchResult, + getOutputs, + getOutputsAndExtracts, + getExtracts, + getTxOutRefs, + getTxOutRefsAndOutputs, + + -- * Basic UTxO searches + utxosAtSearch, allUtxosSearch, - utxosOwnedBySearch, - utxosFromCardanoTxSearch, txSkelOutByRefSearch, - filterWith, - filterWithPure, - filterWithOptic, - filterWithPred, - filterWithValuePred, - filterWithOnlyAda, - filterWithNotOnlyAda, - onlyValueOutputsAtSearch, - vanillaOutputsAtSearch, - filterWithAlways, - referenceScriptOutputsSearch, - filterWithPureRev, + txSkelOutByRefSearch', + + -- * Extracting new information from UTxOs + extract, + extractPure, + extractAFold, + extractTotal, + extractPureTotal, + extractGetter, + + -- * Filtering some UTxOs out + ensure, + ensurePure, + ensureAFoldIs, + ensureAFoldIsn't, + + -- * Cooked filters + ensureOnlyValueOutputs, + ensureVanillaOutputs, + ensureProperReferenceScript, ) where -import Control.Monad -import Cooked.MockChain.BlockChain -import Cooked.Skeleton +import Control.Monad (filterM, forM) +import Cooked.Families hiding (Member) +import Cooked.MockChain.Common +import Cooked.MockChain.Read +import Cooked.Skeleton.Datum +import Cooked.Skeleton.Output +import Cooked.Skeleton.Value +import Data.Functor import Data.Maybe -import Ledger.Tx qualified as Ledger -import ListT (ListT (..)) -import ListT qualified import Optics.Core +import Optics.Core.Extras import Plutus.Script.Utils.Address qualified as Script import Plutus.Script.Utils.Scripts qualified as Script -import Plutus.Script.Utils.Value qualified as Script -import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api - --- * The type of UTxO searches - --- | If a UTxO is a 'Api.TxOutRef' with some additional information, this type --- captures a "stream" of UTxOs. -type UtxoSearch m a = ListT m (Api.TxOutRef, a) - --- | Given a UTxO search, we can run it to obtain a list of UTxOs. -runUtxoSearch :: (Monad m) => UtxoSearch m a -> m [(Api.TxOutRef, a)] -runUtxoSearch = ListT.toList - --- * Initial UTxO searches - --- | Search all currently known 'Api.TxOutRef's together with their corresponding --- 'Api.TxOut'. -allUtxosSearch :: (MonadBlockChain m) => UtxoSearch m TxSkelOut -allUtxosSearch = allUtxos >>= ListT.fromFoldable - --- | Search all 'Api.TxOutRef's at a certain address, together with their --- 'Api.TxOut'. This will attempt to cast the owner of the 'TxSkelOut' to @addr@ --- so be careful how you use it. -utxosOwnedBySearch :: (MonadBlockChainBalancing m, Script.ToAddress addr) => addr -> UtxoSearch m TxSkelOut -utxosOwnedBySearch = utxosAt . Script.toAddress >=> ListT.fromFoldable - --- | Search all 'Cooked.Skelelton.Output.TxSkelOut's corresponding to given the list of --- 'Api.TxOutRef's. Any 'Api.TxOutRef' that doesn't correspond to a known output --- will be filtered out. -txSkelOutByRefSearch :: (MonadBlockChainBalancing m) => [Api.TxOutRef] -> UtxoSearch m TxSkelOut -txSkelOutByRefSearch orefs = - ListT.traverse (\o -> return (o, o)) (ListT.fromFoldable orefs) - `filterWith` ((Just <$>) . txSkelOutByRef) - --- | Search all 'Api.TxOutRef's of a transaction, together with their --- 'Api.TxOut'. -utxosFromCardanoTxSearch :: (MonadBlockChainBalancing m) => Ledger.CardanoTx -> UtxoSearch m TxSkelOut -utxosFromCardanoTxSearch = utxosFromCardanoTx >=> ListT.fromFoldable - --- * filtering UTxO searches - --- | Transform a 'UtxoSearch' by applying a possibly partial monadic --- transformation on each output in the stream -filterWith :: (Monad m) => UtxoSearch m a -> (a -> m (Maybe b)) -> UtxoSearch m b -filterWith (ListT as) f = - ListT $ - as >>= \case - Nothing -> return Nothing - Just ((oref, a), rest) -> - let filteredRest@(ListT bs) = filterWith rest f - in f a >>= \case - Nothing -> bs - Just b -> return $ Just ((oref, b), filteredRest) - --- | Same as 'filterWith' but with a pure transformation -filterWithPure :: (Monad m) => UtxoSearch m a -> (a -> Maybe b) -> UtxoSearch m b -filterWithPure as f = filterWith as (return . f) - --- | Some as 'filterWithPure' but with a total transformation -filterWithAlways :: (Monad m) => UtxoSearch m a -> (a -> b) -> UtxoSearch m b -filterWithAlways as f = filterWithPure as (Just . f) - --- | Some as 'filterWithPure', but the transformation is taken from an optic -filterWithOptic :: (Is k An_AffineFold, Monad m) => UtxoSearch m a -> Optic' k is a b -> UtxoSearch m b -filterWithOptic as optic = filterWithPure as (^? optic) - --- | Same as 'filterWithPure' but the outputs are selected using a boolean --- predicate, and not modified -filterWithPred :: (Monad m) => UtxoSearch m a -> (a -> Bool) -> UtxoSearch m a -filterWithPred as f = filterWithPure as $ \a -> if f a then Just a else Nothing - --- | Same as 'filterWithPure' but inverses the predicate -filterWithPureRev :: (Monad m) => UtxoSearch m a -> (a -> Maybe b) -> UtxoSearch m a -filterWithPureRev as = filterWithPred as . (isNothing .) - --- | A specific version of 'filterWithPred' where outputs must me of type --- 'TxSkelOut' and the predicate only relies on their value -filterWithValuePred :: (Monad m) => UtxoSearch m TxSkelOut -> (Api.Value -> Bool) -> UtxoSearch m TxSkelOut -filterWithValuePred as f = filterWithPred as (f . view txSkelOutValueL) - --- | A specific version of 'filterWithValuePred' when 'TxSkelOut's are only kept --- when they contain only ADA -filterWithOnlyAda :: (Monad m) => UtxoSearch m TxSkelOut -> UtxoSearch m TxSkelOut -filterWithOnlyAda as = filterWithValuePred as Script.isAdaOnlyValue - --- | A specific version of 'filterWithValuePred' when 'TxSkelOut's are only kept --- when they contain non-ADA assets -filterWithNotOnlyAda :: (Monad m) => UtxoSearch m TxSkelOut -> UtxoSearch m TxSkelOut -filterWithNotOnlyAda as = filterWithValuePred as (not . Script.isAdaOnlyValue) - --- * Useful composite UTxO searches with filters already applied - --- | Search for UTxOs at a specific address, which only carry address and value --- information (no datum, staking credential, or reference script). -onlyValueOutputsAtSearch :: (MonadBlockChainBalancing m, Script.ToAddress addr) => addr -> UtxoSearch m TxSkelOut -onlyValueOutputsAtSearch addr = - utxosOwnedBySearch addr - `filterWithPureRev` preview (txSkelOutDatumL % txSkelOutDatumKindAT) - `filterWithPureRev` view txSkelOutMStakingCredentialL - `filterWithPureRev` view txSkelOutMReferenceScriptL - --- | Same as 'onlyValueOutputsAtSearch', but also ensures the returned outputs --- do not contain non-ADA assets. These "vanilla" outputs are perfect candidates --- to be used for balancing transaction and attaching collaterals. -vanillaOutputsAtSearch :: (MonadBlockChainBalancing m, Script.ToAddress addr) => addr -> UtxoSearch m TxSkelOut -vanillaOutputsAtSearch = filterWithOnlyAda . onlyValueOutputsAtSearch - --- | Searches for all outputs containing a given script as reference script -referenceScriptOutputsSearch :: - (MonadBlockChain m, Script.ToScriptHash s) => s -> UtxoSearch m TxSkelOut -referenceScriptOutputsSearch s = - allUtxosSearch - `filterWithPred` ((Just (Script.toScriptHash s) ==) . preview txSkelOutReferenceScriptHashAF) +import Polysemy + +-- | Raw result of a `UtxoSearch`. We store the `Api.TxOutRef` of the output, +-- alongside an heterogeneous list starting with the output in question, +-- followed by any element that was extracted during the search. +type UtxoSearchResult elems = [(Api.TxOutRef, HList (TxSkelOut ': elems))] + +-- | A `UtxoSearch` is a computation that returns a list of UTxOs alongside +-- their `TxSkelOut` counterpart and a list of other elements retrieved from the +-- output. The idea is to begin with a simple search and refine the search with +-- filters while appending new elements to the list. +type UtxoSearch effs elems = Sem effs (UtxoSearchResult elems) + +-- | Wraps up a computation returning a `Utxos` into a `UtxoSearch` +beginSearch :: + Sem effs Utxos -> + UtxoSearch effs '[] +beginSearch = fmap (fmap (fmap (`HCons` HEmpty))) + +-- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` +getOutputs :: + Sem effs (UtxoSearchResult elems) -> + Sem effs [TxSkelOut] +getOutputs = fmap (fmap (hHead . snd)) + +-- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` alongside the +-- extracted elements +getOutputsAndExtracts :: + Sem effs (UtxoSearchResult elems) -> + Sem effs [(TxSkelOut, HList elems)] +getOutputsAndExtracts = + fmap (fmap (\(_, HCons output l) -> (output, l))) + +-- | Retrieves the extracted elements from a `UtxoSearchResult` +getExtracts :: + Sem effs (UtxoSearchResult elems) -> + Sem effs [HList elems] +getExtracts = fmap (fmap (hTail . snd)) + +-- | Retrieves the `Api.TxOutRef`s from a `UtxoSearchResult` +getTxOutRefs :: + Sem effs (UtxoSearchResult elems) -> + Sem effs [Api.TxOutRef] +getTxOutRefs = fmap (fmap fst) + +-- | Retrieves both the `Api.TxOutRef`s and `TxSkelOut`s from a `UtxoSearchResult` +getTxOutRefsAndOutputs :: + Sem effs (UtxoSearchResult elems) -> + Sem effs Utxos +getTxOutRefsAndOutputs = fmap (fmap (\(oRef, HCons output _) -> (oRef, output))) + +-- | Searches for utxos at a given address with a given filter +utxosAtSearch :: + (Member MockChainRead effs, Script.ToCredential pkh) => + pkh -> + (UtxoSearch effs '[] -> UtxoSearch effs els) -> + UtxoSearch effs els +utxosAtSearch pkh filters = filters $ beginSearch $ utxosAt pkh + +-- | Searches for all the known utxos with a given filter +allUtxosSearch :: + (Member MockChainRead effs) => + (UtxoSearch effs '[] -> UtxoSearch effs els) -> + UtxoSearch effs els +allUtxosSearch filters = filters $ beginSearch allUtxos + +-- | Searches for utxos belonging to a given list with a given filter +txSkelOutByRefSearch :: + (Member MockChainRead effs) => + [Api.TxOutRef] -> + (UtxoSearch effs '[] -> UtxoSearch effs els) -> + UtxoSearch effs els +txSkelOutByRefSearch utxos filters = + filters $ beginSearch (zip utxos <$> mapM txSkelOutByRef utxos) + +-- | Searches for utxos belonging to a given list with no filter +txSkelOutByRefSearch' :: + (Member MockChainRead effs) => + [Api.TxOutRef] -> + UtxoSearch effs '[] +txSkelOutByRefSearch' = (`txSkelOutByRefSearch` id) + +-- | Extracts a new element from the currently selected outputs, filtering in +-- the process out utxos for which this element is not available +extract :: + (TxSkelOut -> Sem effs (Maybe b)) -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extract extractFun comp = do + resl <- comp + resl' <- forM resl $ + \(oRef, HCons txSkelOut other) -> do + res <- extractFun txSkelOut + return $ res <&> (\x -> (oRef, HCons txSkelOut (HCons x other))) + return $ catMaybes resl' + +-- | Same as `extract`, but with a pure extraction function +extractPure :: + (TxSkelOut -> Maybe b) -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractPure = extract . (return .) + +-- | Same as `extractPure`, using an affine fold to extract the element +extractAFold :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractAFold = extractPure . preview + +-- | Same as `extract`, but with a total extraction function +extractTotal :: + (TxSkelOut -> Sem effs b) -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractTotal = extract . (fmap Just .) + +-- | Same as `extract`, but with a pure and total extraction function +extractPureTotal :: + (TxSkelOut -> b) -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractPureTotal = extractTotal . (return .) + +-- | Same as `extractPureTotal`, using a getter to extract the element +extractGetter :: + (Is k A_Getter) => + Optic' k is TxSkelOut b -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractGetter = extractPureTotal . view + +-- | Ensures the outputs resulting from the search satisfy the given predicate +ensure :: + (TxSkelOut -> Sem effs Bool) -> + UtxoSearch effs els -> + UtxoSearch effs els +ensure filterF comp = + comp >>= filterM (filterF . hHead . snd) + +-- | Same as `ensure`, but with a pure predicate +ensurePure :: + (TxSkelOut -> Bool) -> + UtxoSearch effs els -> + UtxoSearch effs els +ensurePure = ensure . (return .) + +-- | Ensures the outputs resulting from the search contain the focus of the +-- given affine fold +ensureAFoldIs :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearch effs els -> + UtxoSearch effs els +ensureAFoldIs = ensurePure . is + +-- | Ensures the outputs resulting from the search do not contain the focus of +-- the given affine fold +ensureAFoldIsn't :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearch effs els -> + UtxoSearch effs els +ensureAFoldIsn't = ensurePure . isn't + +-- | Ensures the outputs resulting from the search do not have a reference +-- script, nor a staking credential, nor a datum +ensureOnlyValueOutputs :: + UtxoSearch effs els -> + UtxoSearch effs els +ensureOnlyValueOutputs = + ensureAFoldIsn't txSkelOutReferenceScriptAT + . ensureAFoldIsn't txSkelOutStakingCredentialAT + . ensureAFoldIsn't (txSkelOutDatumL % txSkelOutDatumKindAT) + +-- | Same as 'ensureOnlyValueOutputs', but also ensures the searched outputs do not +-- contain non-ADA assets. +ensureVanillaOutputs :: + UtxoSearch effs els -> + UtxoSearch effs els +ensureVanillaOutputs = + ensureAFoldIs (txSkelOutValueL % valueLovelaceP) + . ensureOnlyValueOutputs + +-- | Ensures the outputs resulting from the search have the given script as a +-- reference script +ensureProperReferenceScript :: + (Script.ToScriptHash s) => + s -> + UtxoSearch effs els -> + UtxoSearch effs els +ensureProperReferenceScript (Script.toScriptHash -> sHash) = + ensureAFoldIs (txSkelOutReferenceScriptHashAF % filtered (== sHash)) diff --git a/src/Cooked/MockChain/UtxoState.hs b/src/Cooked/MockChain/UtxoState.hs deleted file mode 100644 index 055daad72..000000000 --- a/src/Cooked/MockChain/UtxoState.hs +++ /dev/null @@ -1,103 +0,0 @@ --- | This module provides a depiction of the state we return when running a --- 'Cooked.BlockChain.Direct.MockChain'. -module Cooked.MockChain.UtxoState - ( UtxoState (..), - UtxoPayloadSet (..), - UtxoPayload (..), - UtxoPayloadDatum (..), - holdsInState, - ) -where - -import Cooked.Skeleton.Datum -import Data.Function (on) -import Data.List qualified as List -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Plutus.Script.Utils.Address qualified as Script -import PlutusLedgerApi.V1.Value qualified as Api -import PlutusLedgerApi.V3 qualified as Api - --- | A description of who owns what in a blockchain. Owners are addresses and --- they each own a 'UtxoPayloadSet'. -data UtxoState where - UtxoState :: - { -- | Utxos available to be consumed - availableUtxos :: Map Api.Address UtxoPayloadSet, - -- | Utxos already consumed - consumedUtxos :: Map Api.Address UtxoPayloadSet - } -> - UtxoState - deriving (Eq) - --- | Total value accessible to what's pointed by the address. -holdsInState :: (Script.ToAddress a) => a -> UtxoState -> Api.Value -holdsInState (Script.toAddress -> address) = maybe mempty utxoPayloadSetTotal . Map.lookup address . availableUtxos - -instance Semigroup UtxoState where - (UtxoState a c) <> (UtxoState a' c') = UtxoState (Map.unionWith (<>) a a') (Map.unionWith (<>) c c') - -instance Monoid UtxoState where - mempty = UtxoState Map.empty Map.empty - --- | Represents a /set/ of payloads. -newtype UtxoPayloadSet = UtxoPayloadSet - { -- | List of UTxOs contained in this 'UtxoPayloadSet' - utxoPayloadSet :: [UtxoPayload] - -- We use a list instead of a set because 'Api.Value' doesn't implement 'Ord' - -- and because it is possible that we want to distinguish between utxo states - -- that have additional utxos, even if these could have been merged together. - } - deriving (Show) - --- | A simplified version of a 'Cooked.Skeleton.Datum.TxSkelOutDatum' which only --- stores the actual datum and whether it is hashed or inline. -data UtxoPayloadDatum where - NoUtxoPayloadDatum :: UtxoPayloadDatum - SomeUtxoPayloadDatum :: (DatumConstrs dat) => dat -> Bool -> UtxoPayloadDatum - -deriving instance Show UtxoPayloadDatum - -instance Ord UtxoPayloadDatum where - compare NoUtxoPayloadDatum NoUtxoPayloadDatum = EQ - compare NoUtxoPayloadDatum _ = LT - compare _ NoUtxoPayloadDatum = GT - compare - (SomeUtxoPayloadDatum (Api.toBuiltinData -> dat) b) - (SomeUtxoPayloadDatum (Api.toBuiltinData -> dat') b') = - compare (dat, b) (dat', b') - -instance Eq UtxoPayloadDatum where - dat == dat' = compare dat dat' == EQ - --- | A convenient wrapping of the interesting information of a UTxO. -data UtxoPayload where - UtxoPayload :: - { -- | The reference of this UTxO - utxoPayloadTxOutRef :: Api.TxOutRef, - -- | The value stored in this UTxO - utxoPayloadValue :: Api.Value, - -- | The optional datum stored in this UTxO - utxoPayloadDatum :: UtxoPayloadDatum, - -- | The optional reference script stored in this UTxO - utxoPayloadReferenceScript :: Maybe Api.ScriptHash - } -> - UtxoPayload - deriving (Eq, Show) - -instance Eq UtxoPayloadSet where - (UtxoPayloadSet xs) == (UtxoPayloadSet ys) = xs' == ys' - where - k (UtxoPayload ref val dat rs) = (ref, Api.flattenValue val, dat, rs) - xs' = List.sortBy (compare `on` k) xs - ys' = List.sortBy (compare `on` k) ys - -instance Semigroup UtxoPayloadSet where - UtxoPayloadSet a <> UtxoPayloadSet b = UtxoPayloadSet $ a ++ b - -instance Monoid UtxoPayloadSet where - mempty = UtxoPayloadSet [] - --- | Computes the total value in a set -utxoPayloadSetTotal :: UtxoPayloadSet -> Api.Value -utxoPayloadSetTotal = mconcat . fmap utxoPayloadValue . utxoPayloadSet diff --git a/src/Cooked/MockChain/Write.hs b/src/Cooked/MockChain/Write.hs new file mode 100644 index 000000000..55611898a --- /dev/null +++ b/src/Cooked/MockChain/Write.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module exposes primitives to update the current state of the +-- blockchain, including by sending transactions for validation. +module Cooked.MockChain.Write + ( -- * The `MockChainWrite` effect + MockChainWrite (..), + runMockChainWrite, + + -- * Modifications of the current time + waitNSlots, + awaitSlot, + awaitEnclosingSlot, + waitNMSFromSlotLowerBound, + waitNMSFromSlotUpperBound, + + -- * Sending `Cooked.Skeleton.TxSkel`s for validation + validateTxSkel, + validateTxSkel', + validateTxSkel_, + + -- * Other operations + setParams, + setConstitutionScript, + forceOutputs, + ) +where + +import Cardano.Api qualified as Cardano +import Cardano.Api.Ledger qualified as Cardano +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Control.Lens qualified as Lens +import Control.Monad +import Cooked.MockChain.AutoFilling +import Cooked.MockChain.Balancing +import Cooked.MockChain.Common +import Cooked.MockChain.Error +import Cooked.MockChain.GenerateTx.Body +import Cooked.MockChain.GenerateTx.Output +import Cooked.MockChain.Log +import Cooked.MockChain.Read +import Cooked.MockChain.State +import Cooked.Skeleton +import Cooked.Tweak.Common +import Data.Map.Strict qualified as Map +import Ledger.Index qualified as Ledger +import Ledger.Orphans () +import Ledger.Slot 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.V3 qualified as Api +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.State + +-- | An effect that offers all the primitives that are performing modifications +-- on the blockchain state. +data MockChainWrite :: Effect where + WaitNSlots :: Integer -> MockChainWrite m Ledger.Slot + SetParams :: Emulator.Params -> MockChainWrite m () + ValidateTxSkel :: TxSkel -> MockChainWrite m (Ledger.CardanoTx, Utxos) + SetConstitutionScript :: (ToVScript s) => s -> MockChainWrite m () + ForceOutputs :: [TxSkelOut] -> MockChainWrite m Utxos + +makeSem_ ''MockChainWrite + +-- | Interpretes the `MockChainWrite` effect +runMockChainWrite :: + forall effs a. + ( Members + '[ State MockChainState, + Error Ledger.ToCardanoError, + Error MockChainError, + MockChainLog, + MockChainRead, + Fail + ] + effs + ) => + Sem (MockChainWrite : effs) a -> + Sem effs a +runMockChainWrite = interpret $ \case + SetParams params -> do + modify $ set mcstParamsL params + modify $ over mcstLedgerStateL $ Emulator.updateStateParams params + WaitNSlots n -> do + cs <- gets (Emulator.getSlot . mcstLedgerState) + if + | n == 0 -> return cs + | n > 0 -> do + let newSlot = cs + fromIntegral n + modify' (over mcstLedgerStateL $ Lens.set Emulator.elsSlotL $ fromIntegral newSlot) + return newSlot + | otherwise -> throw $ MCEPastSlot cs (cs + fromIntegral n) + SetConstitutionScript (toVScript -> cScript) -> do + modify' (mcstConstitutionL ?~ cScript) + modify' $ + over mcstLedgerStateL $ + Lens.set Emulator.elsConstitutionScriptL $ + (Cardano.SJust . Cardano.toShelleyScriptHash . Script.toCardanoScriptHash) + cScript + ForceOutputs outputs -> do + -- We retrieve the protocol parameters + params <- getParams + -- The emulator takes for granted transactions with a single pseudo input, + -- which we build to force transaction validation + let input = + ( Cardano.genesisUTxOPseudoTxIn (Emulator.pNetworkId params) $ + Cardano.GenesisUTxOKeyHash $ + Cardano.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194", + Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending + ) + -- We adjust the outputs for the minimal required ADA if needed + outputsMinAda <- mapM toTxSkelOutWithMinAda outputs + -- We transform these outputs to Cardano outputs + outputs' <- mapM toCardanoTxOut outputsMinAda + -- We create our transaction body, which only consists of the dummy input + -- and the outputs to force, and make a transaction out of it. + cardanoTx <- + Ledger.CardanoEmulatorEraTx . txSignatoriesAndBodyToCardanoTx [] + <$> fromEither + ( Emulator.createTransactionBody params $ + Ledger.CardanoBuildTx + ( Ledger.emptyTxBodyContent + { Cardano.txOuts = outputs', + Cardano.txIns = [input] + } + ) + ) + -- We need to adjust our internal state to account for the forced + -- transaction. We beging by computing the new map of outputs. + let outputsMap = + Map.fromList $ + zipWith + (\x y -> (x, (y, True))) + (Ledger.fromCardanoTxIn . snd <$> Ledger.getCardanoTxOutRefs cardanoTx) + outputsMinAda + -- We update the index, which effectively receives the new utxos + modify' + ( over mcstLedgerStateL $ + Lens.over + Emulator.elsUtxoL + ( Ledger.fromPlutusIndex + . Ledger.insert cardanoTx + . Ledger.toPlutusIndex + ) + ) + -- We update our internal map by adding the new outputs + modify' (over mcstOutputsL (<> outputsMap)) + -- Finally, we return the created utxos + return $ Map.toList (fst <$> outputsMap) + ValidateTxSkel skel -> fmap snd $ runTweak skel $ do + -- We retrieve the current skeleton options + TxSkelOpts {..} <- viewTweak txSkelOptsL + -- We log the submission of the new skeleton + viewTweak simple >>= logEvent . MCLogSubmittedTxSkel + -- We retrieve the current parameters + oldParams <- getParams + -- We compute the optionally modified parameters + let newParams = txSkelOptModParams oldParams + -- We change the parameters for the duration of the validation process + modify $ set mcstParamsL newParams + modify $ over mcstLedgerStateL $ Emulator.updateStateParams newParams + -- We ensure that the outputs have the required minimal amount of ada, when + -- requested in the skeleton options + autoFillMinAda + -- We retrieve the official constitution script and attach it to each + -- proposal that requires it, if it's not empty + autoFillConstitution + -- We add reference scripts in the various redeemers of the skeleton, when + -- they can be found in the index and are allowed to be auto filled + autoFillReferenceScripts + -- We attach the reward amount to withdrawals when applicable + autoFillWithdrawalAmounts + -- We balance the skeleton when requested in the skeleton option, and get + -- the associated fee, collateral inputs and return collateral user + (finalTxSkel, fee, mCollaterals) <- viewTweak simple >>= balanceTxSkel + -- We log the adjusted skeleton + logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals + -- We generate the transaction asscoiated with the skeleton, and apply on it + -- the modifications from the skeleton options + cardanoTx <- Ledger.CardanoEmulatorEraTx . txSkelOptModTx <$> txSkelToCardanoTx finalTxSkel fee mCollaterals + -- To run transaction validation we need a minimal ledger state + eLedgerState <- gets mcstLedgerState + -- We finally run the emulated validation. We update our internal state + -- based on the validation result, and throw an error if this fails. If at + -- some point we want to allows mockchain runs with validation errors, the + -- caller will need to catch those errors and do something with them. + newOutputs <- case Emulator.validateCardanoTx newParams eLedgerState cardanoTx of + -- In case of a phase 1 error, we give back the same index + (_, Ledger.FailPhase1 _ err) -> throw $ MCEValidationError Ledger.Phase1 err + (newELedgerState, Ledger.FailPhase2 _ err _) | Just (colInputs, retColUser) <- mCollaterals -> do + -- We update the emulated ledger state + modify' (set mcstLedgerStateL newELedgerState) + -- We remove the collateral utxos from our own stored outputs + forM_ colInputs $ modify' . removeOutput + -- We add the returned collateral to our outputs (in practice this map + -- either contains no element, or a single one) + forM_ (Map.toList $ Ledger.getCardanoTxProducedReturnCollateral cardanoTx) $ \(txIn, txOut) -> + modify' $ + addOutput + (Ledger.fromCardanoTxIn txIn) + (retColUser `receives` Value (Api.txOutValue . Ledger.fromCardanoTxOutToPV2TxInfoTxOut . Ledger.getTxOut $ txOut)) + -- We throw a mockchain error + throw $ MCEValidationError Ledger.Phase2 err + -- In case of success, we update the index with all inputs and outputs + -- contained in the transaction + (newELedgerState, Ledger.Success {}) -> do + -- We update the index with the utxos consumed and produced by the tx + modify' (set mcstLedgerStateL newELedgerState) + -- We retrieve the utxos created by the transaction + let utxos = Ledger.fromCardanoTxIn . snd <$> Ledger.getCardanoTxOutRefs cardanoTx + -- We combine them with their corresponding `TxSkelOut` + let newOutputs = zip utxos (txSkelOuts finalTxSkel) + -- We add the news utxos to the state + forM_ newOutputs $ modify' . uncurry addOutput + -- And remove the old ones + forM_ (Map.toList $ txSkelIns finalTxSkel) $ modify' . removeOutput . fst + -- We return the newly created outputs + return newOutputs + -- This is a theoretical unreachable case. Since we fail in Phase 2, it + -- means the transaction involved script, and thus we must have generated + -- collaterals. + (_, Ledger.FailPhase2 {}) + | Nothing <- mCollaterals -> + fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" + -- We apply a change of slot when requested in the options + when txSkelOptAutoSlotIncrease $ modify' (over mcstLedgerStateL Emulator.nextSlot) + -- We return the parameters to their original state + modify $ set mcstParamsL oldParams + modify $ over mcstLedgerStateL $ Emulator.updateStateParams oldParams + -- We log the validated transaction + logEvent $ MCLogNewTx (Ledger.fromCardanoTxId $ Ledger.getCardanoTxId cardanoTx) (fromIntegral $ length $ Ledger.getCardanoTxOutRefs cardanoTx) + -- We return the validated transaction + return (cardanoTx, newOutputs) + +-- | Waits a certain number of slots and returns the new slot +waitNSlots :: (Member MockChainWrite effs) => Integer -> Sem effs Ledger.Slot + +-- | Wait for a certain slot, or throws an error if the slot is already past +awaitSlot :: (Members '[MockChainRead, MockChainWrite] effs) => Ledger.Slot -> Sem effs Ledger.Slot +awaitSlot (Ledger.Slot targetSlot) = do + Ledger.Slot now <- currentSlot + waitNSlots (targetSlot - now) + +-- | Waits until the current slot becomes greater or equal to the slot +-- containing the given POSIX time. Note that that it might not wait for +-- anything if the current slot is large enough. +awaitEnclosingSlot :: (Members '[MockChainRead, MockChainWrite] effs) => Api.POSIXTime -> Sem effs Ledger.Slot +awaitEnclosingSlot time = getEnclosingSlot time >>= awaitSlot + +-- | Wait a given number of ms from the lower bound of the current slot and +-- returns the current slot after waiting. +waitNMSFromSlotLowerBound :: (Members '[MockChainRead, MockChainWrite, Fail] effs) => Integer -> Sem effs Ledger.Slot +waitNMSFromSlotLowerBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . fst + +-- | Wait a given number of ms from the upper bound of the current slot and +-- returns the current slot after waiting. +waitNMSFromSlotUpperBound :: (Members '[MockChainRead, MockChainWrite, Fail] effs) => Integer -> Sem effs Ledger.Slot +waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . snd + +-- | Generates, balances and validates a transaction from a skeleton, and +-- returns the validated transaction, alongside the created UTxOs. +validateTxSkel :: (Member MockChainWrite effs) => TxSkel -> Sem effs (Ledger.CardanoTx, Utxos) + +-- | Same as `validateTxSkel`, but only returns the generated UTxOs +validateTxSkel' :: (Members '[MockChainRead, MockChainWrite] effs) => TxSkel -> Sem effs Utxos +validateTxSkel' = fmap snd . validateTxSkel + +-- | Same as `validateTxSkel`, but discards the returned transaction +validateTxSkel_ :: (Member MockChainWrite effs) => TxSkel -> Sem effs () +validateTxSkel_ = void . validateTxSkel + +-- | Updates the current parameters +setParams :: (Member MockChainWrite effs) => Emulator.Params -> Sem effs () + +-- | Sets the current script to act as the official constitution script +setConstitutionScript :: (Member MockChainWrite effs, ToVScript s) => s -> Sem effs () + +-- | Forces the generation of utxos corresponding to certain +-- `TxSkelOut`. Returns the created UTxOs, which might differ from the original +-- list if some min ADA adjustment occured. +forceOutputs :: (Member MockChainWrite effs) => [TxSkelOut] -> Sem effs Utxos diff --git a/src/Cooked/Pretty/Class.hs b/src/Cooked/Pretty/Class.hs index 17d5ded1a..ab8d810d8 100644 --- a/src/Cooked/Pretty/Class.hs +++ b/src/Cooked/Pretty/Class.hs @@ -15,6 +15,7 @@ module Cooked.Pretty.Class ) where +import Cooked.Families import Cooked.Pretty.Hashable import Cooked.Pretty.Options import Data.ByteString qualified as ByteString @@ -51,8 +52,8 @@ instance PrettyCooked DocCooked where prettyCookedOpt _ = id -- | Type class of things that can be pretty printed as a list of --- documents. Similarly to 'PrettyCooked', at least of the functions from this --- class needs to be manually implemented to avoid infinite loops. +-- documents. Similarly to 'PrettyCooked', at least one of the functions from +-- this class needs to be manually implemented to avoid infinite loops. class PrettyCookedList a where -- | Pretty prints an element as a list on some 'PrettyCookedOpts' prettyCookedOptList :: PrettyCookedOpts -> a -> [DocCooked] @@ -62,6 +63,9 @@ class PrettyCookedList a where prettyCookedOptListMaybe :: PrettyCookedOpts -> a -> [Maybe DocCooked] prettyCookedOptListMaybe opts = fmap Just . prettyCookedOptList opts + prettyCookedListMaybe :: a -> [Maybe DocCooked] + prettyCookedListMaybe = prettyCookedOptListMaybe def + -- | Pretty prints an elements as a list prettyCookedList :: a -> [DocCooked] prettyCookedList = prettyCookedOptList def @@ -182,3 +186,21 @@ instance PrettyCooked Rational where instance PrettyCooked Text where prettyCookedOpt _ = PP.pretty + +instance PrettyCooked String where + prettyCookedOpt _ = PP.pretty + +instance PrettyCooked (HList '[]) where + prettyCookedOpt _ HEmpty = "[]" + +instance PrettyCookedList (HList '[]) where + prettyCookedOptList _ HEmpty = [] + +instance (PrettyCooked a, PrettyCooked (HList l)) => PrettyCooked (HList (a ': l)) where + prettyCookedOpt opts (HCons h t) = prettyCookedOpt opts h <+> ":" <+> prettyCookedOpt opts t + +instance (PrettyCooked a, PrettyCookedList (HList l)) => PrettyCookedList (HList (a ': l)) where + prettyCookedOptList opts (HCons h t) = prettyCookedOpt opts h : prettyCookedOptList opts t + +instance (PrettyCooked a, PrettyCooked b) => PrettyCooked (a, b) where + prettyCookedOpt opts (a, b) = "(" <+> prettyCookedOpt opts a <+> "," <+> prettyCookedOpt opts b <+> ")" diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index 38b9feac2..3d86bfadb 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -4,15 +4,18 @@ -- 'PrettyCookedMaybe' instances for data types returned by a @MockChain@ run. module Cooked.Pretty.MockChain () where -import Cooked.MockChain.BlockChain -import Cooked.MockChain.Direct -import Cooked.MockChain.UtxoState +import Cooked.MockChain.Error +import Cooked.MockChain.Journal +import Cooked.MockChain.Log +import Cooked.MockChain.Runnable +import Cooked.MockChain.State import Cooked.Pretty.Class import Cooked.Pretty.Options import Cooked.Pretty.Skeleton import Cooked.Skeleton.User import Cooked.Wallet (walletPKHashToId) import Data.Function (on) +import Data.List (intersperse) import Data.List qualified as List import Data.Map (Map) import Data.Map qualified as Map @@ -26,16 +29,27 @@ import Prettyprinter ((<+>)) import Prettyprinter qualified as PP instance (Show a) => PrettyCooked [MockChainReturn a] where - prettyCookedOpt opts = prettyItemize opts "Results:" "-" + prettyCookedOpt _ [] = "[]" + prettyCookedOpt opts [outcome] = prettyCookedOpt opts outcome + prettyCookedOpt opts outcomes = + PP.vsep $ + intersperse "" $ + zipWith + (\n d -> PP.pretty n <> "." <+> d) + ([1 ..] :: [Int]) + (PP.align . prettyCookedOpt opts <$> outcomes) instance (Show a) => PrettyCooked (MockChainReturn a) where - prettyCookedOpt opts' (MockChainReturn res outputs utxoState entries ((`addHashNames` opts') -> opts)) = + prettyCookedOpt opts' (MockChainReturn res outputs (UtxoState available consumed) (MockChainJournal entries ((`addHashNames` opts') -> opts) noteBook _)) = PP.vsep $ - [prettyCookedOpt opts (Contextualized outputs entries) | pcOptPrintLog opts] - <> prettyCookedOptList opts utxoState + [prettyItemize opts "📔 Notes:" "-" (($ opts) <$> noteBook) | pcOptPrintNotebook opts && not (null noteBook)] + <> [prettyCookedOpt opts (Contextualized outputs entries) | pcOptPrintLog opts && not (null entries)] + <> ["💰" <+> prettyCookedOpt opts available | pcOptPrintRemainingUTxOs opts] + <> ["🗑️" <+> prettyCookedOpt opts consumed | pcOptPrintConsumedUTxOs opts] <> [ case res of Left err -> "🔴 Error:" <+> prettyCookedOpt opts err Right a -> "🟢 Returned value:" <+> PP.viaShow a + | pcOptPrintReturnedValue opts ] instance PrettyCooked Peer where @@ -64,12 +78,8 @@ instance PrettyCooked MockChainError where "Percentage in params was" <+> prettyCookedOpt opts percentage, "Resulting minimal collateral value was" <+> prettyCookedOpt opts colVal ] - prettyCookedOpt opts (MCEToCardanoError msg cardanoError) = - prettyItemize @[DocCooked] - opts - "Transaction generation error:" - "-" - [PP.pretty msg, PP.pretty cardanoError] + prettyCookedOpt _ (MCEToCardanoError cardanoError) = + "Transaction generation error:" <+> PP.pretty cardanoError prettyCookedOpt opts (MCEUnknownOutRef txOutRef) = "Unknown transaction output ref:" <+> prettyCookedOpt opts txOutRef prettyCookedOpt opts (MCEWrongReferenceScriptError oRef expected got) = "Unable to fetch the following reference script:" @@ -84,7 +94,7 @@ instance PrettyCooked MockChainError where <+> PP.viaShow current <+> "; target slot:" <+> PP.viaShow target - prettyCookedOpt _ (FailWith msg) = "Failed with:" <+> PP.pretty msg + prettyCookedOpt _ (MCEFailure msg) = "Failed with:" <+> PP.pretty msg instance PrettyCooked (Contextualized [MockChainLogEntry]) where prettyCookedOpt opts (Contextualized outputs entries) = @@ -166,10 +176,6 @@ instance PrettyCooked (Contextualized MockChainLogEntry) where prettyCookedOpt opts (Contextualized _ (MCLogAutoFilledConstitution constitution)) = "New auto-filled constitution:" <+> prettyHash opts constitution -instance PrettyCookedList UtxoState where - prettyCookedOptList opts (UtxoState available consumed) = - "✅" <+> prettyCookedOpt opts available : ["❎" <+> prettyCookedOpt opts consumed | pcOptPrintConsumedUTxOs opts] - -- | Pretty print a 'UtxoState'. Print the known wallets first, then unknown -- pubkeys, then scripts. instance PrettyCooked (Map Api.Address UtxoPayloadSet) where @@ -235,7 +241,7 @@ instance PrettyCookedList UtxoPayloadSet where else Nothing, Just (prettyCookedOpt opts utxoPayloadValue), (\(dat, hashed) -> "Datum (" <> (if hashed then "hashed" else "inline") <> "):" <+> dat) <$> splitDatum utxoPayloadDatum, - ("Reference script hash:" <+>) . prettyHash opts <$> utxoPayloadReferenceScript + ("Reference script hash:" <+>) . prettyHash opts <$> utxoPayloadReferenceScriptHash ] of [] -> Nothing [doc] -> Just $ PP.align doc diff --git a/src/Cooked/Pretty/Options.hs b/src/Cooked/Pretty/Options.hs index 98bd59172..fa27369fd 100644 --- a/src/Cooked/Pretty/Options.hs +++ b/src/Cooked/Pretty/Options.hs @@ -39,7 +39,13 @@ data PrettyCookedOpts = PrettyCookedOpts pcOptHashes :: PrettyCookedHashOpts, -- | Whether to display the log pcOptPrintLog :: Bool, - -- | Whether to display consumed UTxOs in the end state. Default: False + -- | Whether to display the notebook + pcOptPrintNotebook :: Bool, + -- | Whether to display the remaining utxos + pcOptPrintRemainingUTxOs :: Bool, + -- | Whether to display the return value + pcOptPrintReturnedValue :: Bool, + -- | Whether to display the consumed utxos pcOptPrintConsumedUTxOs :: Bool } deriving (Eq, Show) @@ -53,6 +59,9 @@ instance Default PrettyCookedOpts where pcOptNumericUnderscores = True, pcOptHashes = def, pcOptPrintLog = True, + pcOptPrintNotebook = True, + pcOptPrintRemainingUTxOs = True, + pcOptPrintReturnedValue = True, pcOptPrintConsumedUTxOs = False } @@ -127,5 +136,5 @@ hashNamesFromList = Map.fromList . map (first toHash) -- mockchain runs, such as for names that depend on on-chain data, typically a -- 'Api.TxOutRef'. addHashNames :: Map Api.BuiltinByteString String -> PrettyCookedOpts -> PrettyCookedOpts -addHashNames names opts'@(PrettyCookedOpts _ _ _ _ hashOpts _ _) = +addHashNames names opts'@(pcOptHashes -> hashOpts) = opts' {pcOptHashes = hashOpts {pcOptHashNames = Map.union names (pcOptHashNames hashOpts)}} diff --git a/src/Cooked/Pretty/Skeleton.hs b/src/Cooked/Pretty/Skeleton.hs index 2dc203205..e50531b41 100644 --- a/src/Cooked/Pretty/Skeleton.hs +++ b/src/Cooked/Pretty/Skeleton.hs @@ -9,6 +9,7 @@ import Cooked.Pretty.Class import Cooked.Pretty.Options import Cooked.Pretty.Plutus () import Cooked.Skeleton +import Cooked.Wallet (Wallet) import Data.Default import Data.Map (Map) import Data.Map qualified as Map @@ -22,6 +23,9 @@ import PlutusLedgerApi.V3 qualified as Api import Prettyprinter ((<+>)) import Prettyprinter qualified as PP +instance PrettyCooked Wallet where + prettyCookedOpt opts = prettyHash opts . Script.toPubKeyHash + instance PrettyCooked TxSkelSignatory where prettyCookedOpt opts (TxSkelSignatory (Script.toPubKeyHash -> pkh) Nothing) = prettyHash opts pkh <+> "(no private key attached)" prettyCookedOpt opts (TxSkelSignatory (Script.toPubKeyHash -> pkh) Just {}) = prettyHash opts pkh @@ -95,7 +99,7 @@ instance PrettyCooked Withdrawal where prettyCookedOptList opts user ++ [maybe "Amount to be autofilled" (("Amount: " <>) . PP.pretty . Api.getLovelace) mAmount] -instance PrettyCooked ParameterChange where +instance PrettyCooked ParamChange where prettyCookedOpt opts (FeePerByte n) = "Fee per byte:" <+> prettyCookedOpt opts n prettyCookedOpt opts (FeeFixed n) = "Fee fixed:" <+> prettyCookedOpt opts n prettyCookedOpt opts (MaxBlockBodySize n) = "Max block body size:" <+> prettyCookedOpt opts n diff --git a/src/Cooked/Skeleton.hs b/src/Cooked/Skeleton.hs index 27c8dc668..cffdc57c0 100644 --- a/src/Cooked/Skeleton.hs +++ b/src/Cooked/Skeleton.hs @@ -15,7 +15,7 @@ module Cooked.Skeleton ( module X, TxSkel (..), - txSkelLabelL, + txSkelLabelsL, txSkelOptsL, txSkelMintsL, txSkelValidityRangeL, @@ -68,8 +68,9 @@ data TxSkel where TxSkel :: { -- | Labels do not influence the transaction generation at all; they are -- pretty-printed whenever cooked-validators prints a transaction, and can - -- therefore make the output more informative. - txSkelLabel :: Set TxSkelLabel, + -- therefore make the output more informative. They can also be used to + -- select skeletons to be modified during a mockchain run. + txSkelLabels :: Set TxSkelLabel, -- | Some options that control transaction generation. txSkelOpts :: TxSkelOpts, -- | Any value minted or burned by the transaction. You'll probably want @@ -112,7 +113,7 @@ data TxSkel where deriving (Show, Eq) -- | Focusing on the labels of a 'TxSkel' -makeLensesFor [("txSkelLabel", "txSkelLabelL")] ''TxSkel +makeLensesFor [("txSkelLabels", "txSkelLabelsL")] ''TxSkel -- | Focusing on the optics of a 'TxSkel' makeLensesFor [("txSkelOpts", "txSkelOptsL")] ''TxSkel @@ -150,7 +151,7 @@ makeLensesFor [("txSkelCertificates", "txSkelCertificatesL")] ''TxSkel txSkelTemplate :: TxSkel txSkelTemplate = TxSkel - { txSkelLabel = mempty, + { txSkelLabels = mempty, txSkelOpts = def, txSkelMints = mempty, txSkelValidityRange = Api.always, diff --git a/src/Cooked/Skeleton/Certificate.hs b/src/Cooked/Skeleton/Certificate.hs index 1ea3800db..21892c3ad 100644 --- a/src/Cooked/Skeleton/Certificate.hs +++ b/src/Cooked/Skeleton/Certificate.hs @@ -17,7 +17,7 @@ module Cooked.Skeleton.Certificate ) where -import Cooked.Skeleton.Families +import Cooked.Families import Cooked.Skeleton.Redeemer import Cooked.Skeleton.User import Data.Kind (Type) diff --git a/src/Cooked/Skeleton/Output.hs b/src/Cooked/Skeleton/Output.hs index fe18a1cbf..770f74244 100644 --- a/src/Cooked/Skeleton/Output.hs +++ b/src/Cooked/Skeleton/Output.hs @@ -30,8 +30,8 @@ module Cooked.Skeleton.Output ) where +import Cooked.Families import Cooked.Skeleton.Datum -import Cooked.Skeleton.Families import Cooked.Skeleton.User import Cooked.Skeleton.Value () import Cooked.Wallet diff --git a/src/Cooked/Skeleton/Proposal.hs b/src/Cooked/Skeleton/Proposal.hs index 090eb29ce..2c673e5a0 100644 --- a/src/Cooked/Skeleton/Proposal.hs +++ b/src/Cooked/Skeleton/Proposal.hs @@ -4,7 +4,7 @@ -- script govAction1, simpleProposal pk govAction2, ... ]@ module Cooked.Skeleton.Proposal ( -- * Data types - ParameterChange (..), + ParamChange (..), GovernanceAction (..), TxSkelProposal (..), @@ -40,68 +40,68 @@ import PlutusTx.Prelude qualified as PlutusTx -- | 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 ParameterChange where +data ParamChange where -- | The linear factor for the minimum fee calculation - FeePerByte :: Integer -> ParameterChange + FeePerByte :: Integer -> ParamChange -- | The constant factor for the minimum fee calculation - FeeFixed :: Integer -> ParameterChange + FeeFixed :: Integer -> ParamChange -- | Maximal block body size - MaxBlockBodySize :: Integer -> ParameterChange + MaxBlockBodySize :: Integer -> ParamChange -- | Maximal transaction size - MaxTxSize :: Integer -> ParameterChange + MaxTxSize :: Integer -> ParamChange -- | Maximal block header size - MaxBlockHeaderSize :: Integer -> ParameterChange + MaxBlockHeaderSize :: Integer -> ParamChange -- | The amount of a key registration deposit - KeyDeposit :: Integer -> ParameterChange + KeyDeposit :: Integer -> ParamChange -- | The amount of a pool registration deposit - PoolDeposit :: Integer -> ParameterChange + PoolDeposit :: Integer -> ParamChange -- | Maximum number of epochs in the future a pool retirement is allowed to -- be scheduled future for. - PoolRetirementMaxEpoch :: Integer -> ParameterChange + PoolRetirementMaxEpoch :: Integer -> ParamChange -- | Desired number of pools - PoolNumber :: Integer -> ParameterChange + PoolNumber :: Integer -> ParamChange -- | Pool influence - PoolInfluence :: Rational -> ParameterChange + PoolInfluence :: Rational -> ParamChange -- | Monetary expansion - MonetaryExpansion :: Rational -> ParameterChange + MonetaryExpansion :: Rational -> ParamChange -- | Treasury expansion - TreasuryCut :: Rational -> ParameterChange + TreasuryCut :: Rational -> ParamChange -- | Minimum Stake Pool Cost - MinPoolCost :: Integer -> ParameterChange + MinPoolCost :: Integer -> ParamChange -- | Cost in lovelace per byte of UTxO storage - CoinsPerUTxOByte :: Integer -> ParameterChange + CoinsPerUTxOByte :: Integer -> ParamChange -- | Cost models for non-native script languages CostModels :: { cmPlutusV1Costs :: [Integer], cmPlutusV2Costs :: [Integer], cmPlutusV3Costs :: [Integer] } -> - ParameterChange + ParamChange -- | Prices of execution units Prices :: { pMemoryCost :: Rational, pStepCost :: Rational } -> - ParameterChange + ParamChange -- | Max total script execution resources units allowed per tx MaxTxExUnits :: { mteuMemory :: Integer, mteuSteps :: Integer } -> - ParameterChange + ParamChange -- | Max total script execution resources units allowed per block MaxBlockExUnits :: { mbeuMemory :: Integer, mbeuSteps :: Integer } -> - ParameterChange + ParamChange -- | Max size of a Value in an output - MaxValSize :: Integer -> ParameterChange + MaxValSize :: Integer -> ParamChange -- | Percentage of the txfee which must be provided as collateral when -- including non-native scripts. - CollateralPercentage :: Integer -> ParameterChange + CollateralPercentage :: Integer -> ParamChange -- | Maximum number of collateral inputs allowed in a transaction - MaxCollateralInputs :: Integer -> ParameterChange + MaxCollateralInputs :: Integer -> ParamChange -- | Thresholds for pool votes PoolVotingThresholds :: { pvtMotionNoConfidence :: Rational, @@ -110,7 +110,7 @@ data ParameterChange where pvtHardFork :: Rational, pvtSecurityGroup :: Rational } -> - ParameterChange + ParamChange -- | Thresholds for DRep votes DRepVotingThresholds :: { drvtMotionNoConfidence :: Rational, @@ -124,22 +124,22 @@ data ParameterChange where drvtGovernanceGroup :: Rational, drvtTreasuryWithdrawal :: Rational } -> - ParameterChange + ParamChange -- | Minimum size of the Constitutional Committee - CommitteeMinSize :: Integer -> ParameterChange + CommitteeMinSize :: Integer -> ParamChange -- | The Constitutional Committee Term limit in number of Slots - CommitteeMaxTermLength :: Integer -> ParameterChange + CommitteeMaxTermLength :: Integer -> ParamChange -- | Gov action lifetime in number of Epochs - GovActionLifetime :: Integer -> ParameterChange + GovActionLifetime :: Integer -> ParamChange -- | The amount of the Gov Action deposit - GovActionDeposit :: Integer -> ParameterChange + GovActionDeposit :: Integer -> ParamChange -- | The amount of a DRep registration deposit - DRepRegistrationDeposit :: Integer -> ParameterChange + DRepRegistrationDeposit :: Integer -> ParamChange -- | The number of Epochs that a DRep can perform no activity without losing -- their @Active@ status. - DRepActivity :: Integer -> ParameterChange + DRepActivity :: Integer -> ParamChange -- | Reference scripts fee for the minimum fee calculation - MinFeeRefScriptCostPerByte :: Rational -> ParameterChange + MinFeeRefScriptCostPerByte :: Rational -> ParamChange deriving (Show, Eq) -- | This lists the various possible governance actions. Only two of these @@ -148,7 +148,7 @@ data ParameterChange where data GovernanceAction :: UserKind -> Type where -- If several parameter changes are of the same kind, only the last -- one will take effect - ParameterChange :: [ParameterChange] -> GovernanceAction IsScript + ParameterChange :: [ParamChange] -> GovernanceAction IsScript TreasuryWithdrawals :: Map Api.Credential Api.Lovelace -> GovernanceAction IsScript HardForkInitiation :: Api.ProtocolVersion -> GovernanceAction IsNone NoConfidence :: GovernanceAction IsNone diff --git a/src/Cooked/Skeleton/User.hs b/src/Cooked/Skeleton/User.hs index e4824e8c1..3bbc70e62 100644 --- a/src/Cooked/Skeleton/User.hs +++ b/src/Cooked/Skeleton/User.hs @@ -35,7 +35,7 @@ module Cooked.Skeleton.User ) where -import Cooked.Skeleton.Families +import Cooked.Families import Cooked.Skeleton.Redeemer import Data.Kind import Data.Typeable diff --git a/src/Cooked/Staged.hs b/src/Cooked/Staged.hs deleted file mode 100644 index 4ee834764..000000000 --- a/src/Cooked/Staged.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | This module exposes a simple notion of a Staged computation (or a freer --- monad) to be used when modifying mockchain runs with Ltl formulas. -module Cooked.Staged - ( Staged (..), - interpStaged, - ) -where - -import Control.Monad -import Data.Kind - --- | The freer monad on @op@. We think of this as the AST of a computation with --- operations of types @op a@. -data Staged (op :: Type -> Type) :: Type -> Type where - Return :: a -> Staged op a - Instr :: op a -> (a -> Staged op b) -> Staged op b - -instance Functor (Staged op) where - fmap f (Return x) = Return $ f x - fmap f (Instr op cont) = Instr op (fmap f . cont) - -instance Applicative (Staged op) where - pure = Return - (<*>) = ap - -instance Monad (Staged op) where - (Return x) >>= f = f x - (Instr i m) >>= f = Instr i (m >=> f) - --- | Interprets a staged computation given a interpreter of the builtins -interpStaged :: (Monad m) => (forall a. op a -> m a) -> forall a. Staged op a -> m a -interpStaged _ (Return a) = return a -interpStaged interpBuiltin (Instr op cont) = interpBuiltin op >>= interpStaged interpBuiltin . cont diff --git a/src/Cooked/Tweak.hs b/src/Cooked/Tweak.hs index 243ca9aab..0257eaa40 100644 --- a/src/Cooked/Tweak.hs +++ b/src/Cooked/Tweak.hs @@ -3,16 +3,11 @@ -- time using `Cooked.Ltl` module Cooked.Tweak (module X) where -import Cooked.Tweak.Common as X hiding - ( Tweak, - UntypedTweak, - runTweakInChain, - runTweakInChain', - ) +import Cooked.Tweak.Common as X import Cooked.Tweak.Inputs as X import Cooked.Tweak.Labels as X import Cooked.Tweak.Mint as X -import Cooked.Tweak.OutPermutations as X hiding (distinctPermutations) +import Cooked.Tweak.OutPermutations as X import Cooked.Tweak.Outputs as X import Cooked.Tweak.Signatories as X import Cooked.Tweak.ValidityRange as X diff --git a/src/Cooked/Tweak/Common.hs b/src/Cooked/Tweak/Common.hs index 838b56e13..eef5704e0 100644 --- a/src/Cooked/Tweak/Common.hs +++ b/src/Cooked/Tweak/Common.hs @@ -1,160 +1,126 @@ --- | This module defines 'Tweak's which are the fundamental building blocks of --- our "domain specific language" for attacks. They are essentially skeleton --- modifications aware of the mockchain state. +{-# LANGUAGE TemplateHaskell #-} + +-- | This module defines 'Tweak's which are the building blocks of our DSL for +-- attacks. They are skeleton modifications aware of the mockchain state. module Cooked.Tweak.Common - ( runTweak, - runTweakFrom, - runTweakInChain, - runTweakInChain', - Tweak, - UntypedTweak (..), + ( -- * Tweak effect + Tweak (..), + runTweak, + evalTweak, + execTweak, + + -- * Optics + selectP, + + -- * Tweak primitives + getTxSkel, + putTxSkel, - -- * User API - MonadTweak (..), - failingTweak, - doNothingTweak, + -- * Optics tweaks viewTweak, viewAllTweak, setTweak, overTweak, overMaybeTweak, overMaybeSelectingTweak, - selectP, combineModsTweak, iviewTweak, - ensureFailingTweak, ) where import Control.Arrow (second) import Control.Monad -import Control.Monad.State -import Cooked.InitialDistribution -import Cooked.MockChain.BlockChain -import Cooked.MockChain.Direct import Cooked.Skeleton -import Data.Default import Data.Either.Combinators (rightToMaybe) import Data.List (mapAccumL) import Data.Maybe -import ListT (ListT) -import ListT qualified import Optics.Core +import Polysemy +import Polysemy.NonDet +import Polysemy.State --- * The type of tweaks - --- | A 'MonadTweak' is a 'MonadBlockChainWithoutValidation' where you can also --- retrieve and store a 'TxSkel' -class (MonadPlus m, MonadBlockChainWithoutValidation m) => MonadTweak m where - -- | Retrieves the stored 'TxSkel' - getTxSkel :: m TxSkel - - -- | Stores a 'TxSkel' - putTxSkel :: TxSkel -> m () - --- | A 'Tweak' is the most natural instance of 'MonadTweak' where the storing --- and retrieving of the 'TxSkel' is performed through a state monad -type Tweak m = StateT TxSkel (ListT m) +-- | An effet that allows to store or retrieve a `TxSkel` from a context +data Tweak :: Effect where + -- | Retrieves the `TxSkel` from the context + GetTxSkel :: Tweak m TxSkel + -- | Overrides the `TxSkel` in the context + PutTxSkel :: TxSkel -> Tweak m () -instance (MonadBlockChainWithoutValidation m) => MonadTweak (Tweak m) where - getTxSkel = get - putTxSkel = put - --- * Running tweaks - --- | This is the function that gives a meaning to 'Tweak's: A 'Tweak' is a --- computation that, depending on the state of the chain, looks at a transaction --- and returns zero or more modified transactions, together with some additional --- values. --- --- Our intuition (and also the language of the comments pertaining to 'Tweak's) --- is that a 'Tweak' @t@ --- --- - /fails/ if @runTweakInChain t skel@ is @mzero@. --- --- - /returns/ the value in the first component of the pair returned by this --- function (which is also the value it returns in the monad @Tweak m@). --- --- - /modifies/ a 'TxSkel'. Since it can use every method of --- 'MonadBlockChainWithoutValidation' to do so, this also includes stateful --- lookups or even things like waiting for a certain amount of time before --- submitting the transaction. --- --- If you're using tweaks in a 'Cooked.MockChain.Staged.MonadModalBlockChain' --- together with mechanisms like 'Cooked.MockChain.Staged.withTweak', --- 'Cooked.MockChain.Staged.somewhere', or 'Cooked.MockChain.Staged.everywhere', --- you should never have a reason to use this function. -runTweakInChain :: (MonadPlus m) => Tweak m a -> TxSkel -> m (a, TxSkel) -runTweakInChain tweak = ListT.alternate . runStateT tweak +makeSem ''Tweak --- | Like 'runTweakInChain', but for when you want to explicitly apply a tweak --- to a transaction skeleton and get all results as a list. --- --- If you're trying to apply a tweak to a transaction directly before it's --- modified, consider using 'Cooked.MockChain.Staged.MonadModalBlockChain' and --- idioms like 'Cooked.MockChain.Staged.withTweak', --- 'Cooked.MockChain.Staged.somewhere', or 'Cooked.MockChain.Staged.everywhere'. -runTweakInChain' :: (MonadPlus m) => Tweak m a -> TxSkel -> m [(a, TxSkel)] -runTweakInChain' tweak = ListT.toList . runStateT tweak - --- | Runs a 'Tweak' from a given 'TxSkel' within a mockchain -runTweak :: (MonadPlus m) => Tweak (MockChainT m) a -> TxSkel -> m (MockChainReturn (a, TxSkel)) -runTweak = runTweakFrom def - --- | Runs a 'Tweak' from a given 'TxSkel' and 'InitialDistribution' within a --- mockchain -runTweakFrom :: (MonadPlus m) => InitialDistribution -> Tweak (MockChainT m) a -> TxSkel -> m (MockChainReturn (a, TxSkel)) -runTweakFrom initDist tweak = runMockChainTFromInitDist initDist . runTweakInChain tweak - --- | This is a wrapper type used in the implementation of the Staged monad. You --- will probably never use it while you're building 'Tweak's. -data UntypedTweak m where - UntypedTweak :: Tweak m a -> UntypedTweak m - --- * A few fundamental tweaks - --- | The never-applicable 'Tweak'. -failingTweak :: (MonadTweak m) => m a -failingTweak = mzero - --- | The 'Tweak' that always applies and leaves the transaction unchanged. -doNothingTweak :: (MonadTweak m) => m () -doNothingTweak = return () +-- | Running a Tweak is equivalent to running a state monad storing a `TxSkel` +runTweak :: + TxSkel -> + Sem (Tweak : effs) a -> + Sem effs (TxSkel, a) +runTweak txSkel = + runState txSkel + . reinterpret + ( \case + GetTxSkel -> get + PutTxSkel skel -> put skel + ) --- | The 'Tweak' that ensures a given tweak fails -ensureFailingTweak :: (MonadPlus m) => Tweak m a -> Tweak m () -ensureFailingTweak comp = do - skel <- get - res <- lift $ lift $ runTweakInChain' comp skel - guard $ null res +-- | Same as `runTweak` but discards the returned `TxSkel` +evalTweak :: + TxSkel -> + Sem (Tweak : effs) a -> + Sem effs a +evalTweak skel = (snd <$>) . runTweak skel --- * Constructing Tweaks from Optics +-- | Same as `runTweak` but discards the returned value +execTweak :: + TxSkel -> + Sem (Tweak : effs) a -> + Sem effs TxSkel +execTweak skel = (fst <$>) . runTweak skel -- | Retrieves some value from the 'TxSkel' -viewTweak :: (MonadTweak m, Is k A_Getter) => Optic' k is TxSkel a -> m a +viewTweak :: + (Member Tweak effs, Is k A_Getter) => + Optic' k is TxSkel a -> + Sem effs a viewTweak optic = getTxSkel <&> view optic -- | Like 'viewTweak', only for indexed optics. -iviewTweak :: (MonadTweak m, Is k A_Getter) => Optic' k (WithIx is) TxSkel a -> m (is, a) +iviewTweak :: + (Member Tweak effs, Is k A_Getter) => + Optic' k (WithIx is) TxSkel a -> + Sem effs (is, a) iviewTweak optic = getTxSkel <&> iview optic -- | Like the 'viewTweak', but returns a list of all foci -viewAllTweak :: (MonadTweak m, Is k A_Fold) => Optic' k is TxSkel a -> m [a] +viewAllTweak :: + (Member Tweak effs, Is k A_Fold) => + Optic' k is TxSkel a -> + Sem effs [a] viewAllTweak optic = getTxSkel <&> toListOf optic -- | The tweak that sets a certain value in the 'TxSkel'. -setTweak :: (MonadTweak m, Is k A_Setter) => Optic' k is TxSkel a -> a -> m () +setTweak :: + (Member Tweak effs, Is k A_Setter) => + Optic' k is TxSkel a -> + a -> + Sem effs () setTweak optic = overTweak optic . const -- | The tweak that modifies a certain value in the 'TxSkel'. -overTweak :: (MonadTweak m, Is k A_Setter) => Optic' k is TxSkel a -> (a -> a) -> m () +overTweak :: + (Member Tweak effs, Is k A_Setter) => + Optic' k is TxSkel a -> + (a -> a) -> + Sem effs () overTweak optic change = getTxSkel >>= putTxSkel . over optic change -- | Like 'overTweak', but only modifies foci on which the argument function -- returns @Just@ the new focus. Returns a list of the foci that were modified, -- as they were /before/ the tweak, and in the order in which they occurred on -- the original transaction. -overMaybeTweak :: (MonadTweak m, Is k A_Traversal) => Optic' k is TxSkel a -> (a -> Maybe a) -> m [a] +overMaybeTweak :: + (Member Tweak effs, Is k A_Traversal) => + Optic' k is TxSkel a -> + (a -> Maybe a) -> + Sem effs [a] overMaybeTweak optic mChange = overMaybeSelectingTweak optic mChange (const True) -- | Sometimes 'overMaybeTweak' modifies too many foci. This might be the case @@ -163,16 +129,14 @@ overMaybeTweak optic mChange = overMaybeSelectingTweak optic mChange (const True -- argument can be used to select which of the modifiable foci should be -- actually modified. overMaybeSelectingTweak :: - forall a m k is. - (MonadTweak m, Is k A_Traversal) => + (Member Tweak effs, Is k A_Traversal) => Optic' k is TxSkel a -> (a -> Maybe a) -> (Integer -> Bool) -> - m [a] + Sem effs [a] overMaybeSelectingTweak optic mChange select = do allFoci <- viewTweak $ partsOf optic - let evaluatedFoci :: [(a, Maybe a)] - evaluatedFoci = + let evaluatedFoci = snd $ mapAccumL ( \i unmodifiedFocus -> @@ -207,7 +171,7 @@ overMaybeSelectingTweak optic mChange select = do -- - Each of the foci of the @Optic k (WithIx is) TxSkel x@ argument is -- something in the transaction that we might want to modify. -- --- - The @is -> x -> m [(x, l)]@ argument computes a list of possible +-- - The @is -> x -> Sem effs [(x, l)]@ argument computes a list of possible -- modifications for each focus, depending on its index. For each modified -- focus, it also returns a "label" of type @l@, which somehow describes the -- modification that was made. @@ -285,11 +249,11 @@ overMaybeSelectingTweak optic mChange select = do -- So you see that tweaks constructed like this can branch quite wildly. Use -- with caution! combineModsTweak :: - (Eq is, Is k A_Traversal, MonadTweak m) => + (Eq is, Is k A_Traversal, Members '[Tweak, NonDet] effs) => ([is] -> [[is]]) -> Optic' k (WithIx is) TxSkel x -> - (is -> x -> m [(x, l)]) -> - m [l] + (is -> x -> Sem effs [(x, l)]) -> + Sem effs [l] combineModsTweak groupings optic changes = do (indexes, foci) <- iviewTweak (ipartsOf optic) msum $ diff --git a/src/Cooked/Tweak/Inputs.hs b/src/Cooked/Tweak/Inputs.hs index c2359e7d5..ea5941a52 100644 --- a/src/Cooked/Tweak/Inputs.hs +++ b/src/Cooked/Tweak/Inputs.hs @@ -14,11 +14,17 @@ import Cooked.Tweak.Common import Data.Map qualified as Map import Optics.Core import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.NonDet -- | Ensure that a given 'Api.TxOutRef' is being spent with a given -- 'TxSkelRedeemer'. The return value will be @Just@ the added data, if anything -- changed. -ensureInputTweak :: (MonadTweak m) => Api.TxOutRef -> TxSkelRedeemer -> m (Maybe (Api.TxOutRef, TxSkelRedeemer)) +ensureInputTweak :: + (Member Tweak effs) => + Api.TxOutRef -> + TxSkelRedeemer -> + Sem effs (Maybe (Api.TxOutRef, TxSkelRedeemer)) ensureInputTweak oref howConsumed = do presentInputs <- viewTweak txSkelInsL if presentInputs Map.!? oref == Just howConsumed @@ -29,7 +35,11 @@ ensureInputTweak oref howConsumed = do -- | Add an input to a transaction. If the given 'Api.TxOutRef' is already being -- consumed by the transaction, fail. -addInputTweak :: (MonadTweak m) => Api.TxOutRef -> TxSkelRedeemer -> m () +addInputTweak :: + (Members '[Tweak, NonDet] effs) => + Api.TxOutRef -> + TxSkelRedeemer -> + Sem effs () addInputTweak oref howConsumed = do presentInputs <- viewTweak txSkelInsL guard (Map.notMember oref presentInputs) @@ -37,7 +47,10 @@ addInputTweak oref howConsumed = do -- | Remove transaction inputs according to a given predicate. The returned list -- contains all removed inputs. -removeInputTweak :: (MonadTweak m) => (Api.TxOutRef -> TxSkelRedeemer -> Bool) -> m [(Api.TxOutRef, TxSkelRedeemer)] +removeInputTweak :: + (Member Tweak effs) => + (Api.TxOutRef -> TxSkelRedeemer -> Bool) -> + Sem effs [(Api.TxOutRef, TxSkelRedeemer)] removeInputTweak removePred = do presentInputs <- viewTweak txSkelInsL let (removed, kept) = Map.partitionWithKey removePred presentInputs @@ -46,7 +59,14 @@ removeInputTweak removePred = do -- | Applies an optional modification to all spend redeemers of type a. Returns -- the list of modified spending redemeers, as they were before being modified. -modifySpendRedeemersOfTypeTweak :: forall a b m. (RedeemerConstrs a, RedeemerConstrs b, MonadTweak m) => (a -> Maybe b) -> m [TxSkelRedeemer] +modifySpendRedeemersOfTypeTweak :: + forall a b effs. + ( RedeemerConstrs a, + RedeemerConstrs b, + Member Tweak effs + ) => + (a -> Maybe b) -> + Sem effs [TxSkelRedeemer] modifySpendRedeemersOfTypeTweak f = overMaybeTweak (txSkelInsL % iso Map.toList Map.fromList % traversed % _2) $ \red -> do typedRedeemer <- red ^? txSkelRedeemerTypedAT diff --git a/src/Cooked/Tweak/Labels.hs b/src/Cooked/Tweak/Labels.hs index 91d8816f2..9216b3b44 100644 --- a/src/Cooked/Tweak/Labels.hs +++ b/src/Cooked/Tweak/Labels.hs @@ -15,24 +15,46 @@ import Cooked.Tweak.Common import Data.Functor import Data.Set qualified as Set import Data.Text (Text) +import Polysemy +import Polysemy.NonDet -- | Adds a label to a 'TxSkel'. -addLabelTweak :: (LabelConstrs lbl, MonadTweak m) => lbl -> m () -addLabelTweak = overTweak txSkelLabelL . Set.insert . TxSkelLabel +addLabelTweak :: + ( LabelConstrs lbl, + Member Tweak effs + ) => + lbl -> + Sem effs () +addLabelTweak = overTweak txSkelLabelsL . Set.insert . TxSkelLabel -- | Checks if a given label is present in the 'TxSkel' -hasLabelTweak :: (LabelConstrs lbl, MonadTweak m) => lbl -> m Bool -hasLabelTweak = (viewTweak txSkelLabelL <&>) . Set.member . TxSkelLabel +hasLabelTweak :: + ( LabelConstrs lbl, + Member Tweak effs + ) => + lbl -> + Sem effs Bool +hasLabelTweak = (viewTweak txSkelLabelsL <&>) . Set.member . TxSkelLabel -- | Ensures a given label is present in the 'TxSkel' -ensureLabelTweak :: (LabelConstrs lbl, MonadTweak m) => lbl -> m () +ensureLabelTweak :: + ( LabelConstrs lbl, + Members '[Tweak, NonDet] effs + ) => + lbl -> + Sem effs () ensureLabelTweak = hasLabelTweak >=> guard -- | Removes a label from a 'TxSkel' when possible, fails otherwise -removeLabelTweak :: (LabelConstrs lbl, MonadTweak m) => lbl -> m () +removeLabelTweak :: + ( LabelConstrs lbl, + Members '[Tweak, NonDet] effs + ) => + lbl -> + Sem effs () removeLabelTweak lbl = do ensureLabelTweak lbl - overTweak txSkelLabelL . Set.delete $ TxSkelLabel lbl + overTweak txSkelLabelsL . Set.delete $ TxSkelLabel lbl -- | Apply a tweak to a given transaction if it has a specific label. Fails if -- it does not. @@ -49,7 +71,13 @@ removeLabelTweak lbl = do -- > -- > someTest = someEndpoint & eveywhere (labelled SomeLabelType someTweak) -- > anotherTest = someEndpoint & somewhere (labelled SomeLabelType someTweak) -labelled :: (LabelConstrs lbl, MonadTweak m) => lbl -> m a -> m a +labelled :: + ( LabelConstrs lbl, + Members '[Tweak, NonDet] effs + ) => + lbl -> + Sem effs a -> + Sem effs a labelled lbl = (ensureLabelTweak lbl >>) -- | `labelled` specialised to Text labels @@ -66,5 +94,9 @@ labelled lbl = (ensureLabelTweak lbl >>) -- > } -- > -- > someTest = someEndpoint & somewhere (labelled' "Spending" doubleSatAttack) -labelled' :: (MonadTweak m) => Text -> m a -> m a +labelled' :: + (Members '[Tweak, NonDet] effs) => + Text -> + Sem effs a -> + Sem effs a labelled' = labelled diff --git a/src/Cooked/Tweak/Mint.hs b/src/Cooked/Tweak/Mint.hs index 81b3c1fe5..2c3f02864 100644 --- a/src/Cooked/Tweak/Mint.hs +++ b/src/Cooked/Tweak/Mint.hs @@ -9,15 +9,22 @@ import Cooked.Skeleton import Cooked.Tweak.Common import Data.List (partition) import Optics.Core +import Polysemy -- | Adds new entries to the 'TxSkelMints' of the transaction skeleton under -- modification. -addMintsTweak :: (MonadTweak m) => [Mint] -> m () +addMintsTweak :: + (Member Tweak effs) => + [Mint] -> + Sem effs () addMintsTweak newMints = overTweak (txSkelMintsL % txSkelMintsListI) (++ newMints) -- | Remove some entries from the 'TxSkelMints' of a transaction, according to -- some predicate. The returned list holds the removed entries. -removeMintTweak :: (MonadTweak m) => (Mint -> Bool) -> m [Mint] +removeMintTweak :: + (Member Tweak effs) => + (Mint -> Bool) -> + Sem effs [Mint] removeMintTweak removePred = do presentMints <- viewTweak $ txSkelMintsL % txSkelMintsListI let (removed, kept) = partition removePred presentMints diff --git a/src/Cooked/Tweak/OutPermutations.hs b/src/Cooked/Tweak/OutPermutations.hs index 30ec5bb3e..1785fc705 100644 --- a/src/Cooked/Tweak/OutPermutations.hs +++ b/src/Cooked/Tweak/OutPermutations.hs @@ -14,6 +14,8 @@ where import Control.Monad import Cooked.Skeleton import Cooked.Tweak.Common +import Polysemy +import Polysemy.NonDet import System.Random import System.Random.Shuffle @@ -39,7 +41,10 @@ data PermutOutTweakMode = KeepIdentity (Maybe Int) | OmitIdentity (Maybe Int) -- -- (In particular, this is clever enough to generate only the distinct -- permutations, even if some outputs are identical.) -allOutPermutsTweak :: (MonadTweak m) => PermutOutTweakMode -> m () +allOutPermutsTweak :: + (Members '[Tweak, NonDet] effs) => + PermutOutTweakMode -> + Sem effs () allOutPermutsTweak mode = do oldOut <- viewTweak txSkelOutsL msum $ @@ -90,7 +95,10 @@ nonIdentityPermutations l = removeFirst l $ distinctPermutations l -- | This randomly permutes the outputs of a transaction with a given seed. Can -- be used to assess if a certain validator is order-dependant -singleOutPermutTweak :: (MonadTweak m) => Int -> m () +singleOutPermutTweak :: + (Members '[Tweak, NonDet] effs) => + Int -> + Sem effs () singleOutPermutTweak seed = do outputs <- viewTweak txSkelOutsL let outputs' = shuffle' outputs (length outputs) (mkStdGen seed) diff --git a/src/Cooked/Tweak/Outputs.hs b/src/Cooked/Tweak/Outputs.hs index 198a384b9..207abdd97 100644 --- a/src/Cooked/Tweak/Outputs.hs +++ b/src/Cooked/Tweak/Outputs.hs @@ -19,10 +19,15 @@ import Data.List (partition) import Data.Maybe import Optics.Core import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.NonDet -- | Ensures that a certain output is produced by a transaction. The return -- value will be @Just@ the added output, when applicable. -ensureOutputTweak :: (MonadTweak m) => TxSkelOut -> m (Maybe TxSkelOut) +ensureOutputTweak :: + (Member Tweak effs) => + TxSkelOut -> + Sem effs (Maybe TxSkelOut) ensureOutputTweak txSkelOut = do presentOutputs <- viewTweak txSkelOutsL if txSkelOut `elem` presentOutputs @@ -33,12 +38,18 @@ ensureOutputTweak txSkelOut = do -- | Adds a transaction output, at the end of the current list of outputs, thus -- retaining the initial outputs order. -addOutputTweak :: (MonadTweak m) => TxSkelOut -> m () +addOutputTweak :: + (Member Tweak effs) => + TxSkelOut -> + Sem effs () addOutputTweak txSkelOut = overTweak txSkelOutsL (++ [txSkelOut]) -- | Removes transaction outputs according to some predicate. The returned list -- contains all the removed outputs. -removeOutputTweak :: (MonadTweak m) => (TxSkelOut -> Bool) -> m [TxSkelOut] +removeOutputTweak :: + (Member Tweak effs) => + (TxSkelOut -> Bool) -> + Sem effs [TxSkelOut] removeOutputTweak removePred = do presentOutputs <- viewTweak txSkelOutsL let (removed, kept) = partition removePred presentOutputs @@ -58,7 +69,13 @@ instance PrettyCooked TamperDatumLbl where -- -- The tweak returns a list of the modified datums, as they were *before* the -- modification was applied to them. -tamperDatumTweak :: forall a m. (MonadTweak m, DatumConstrs a) => (a -> Maybe a) -> m [a] +tamperDatumTweak :: + forall a effs. + ( Members '[Tweak, NonDet] effs, + DatumConstrs a + ) => + (a -> Maybe a) -> + Sem effs [a] tamperDatumTweak change = do beforeModification <- overMaybeTweak (txSkelOutsL % traversed % txSkelOutDatumL % txSkelOutDatumTypedAT) change guard . not . null $ beforeModification @@ -83,7 +100,13 @@ tamperDatumTweak change = do -- > == (k_1 + 1) * ... * (k_n + 1) - 1 -- -- modified transactions. -malformDatumTweak :: forall a m. (MonadTweak m, DatumConstrs a) => (a -> [Api.BuiltinData]) -> m () +malformDatumTweak :: + forall a effs. + ( Members '[Tweak, NonDet] effs, + DatumConstrs a + ) => + (a -> [Api.BuiltinData]) -> + Sem effs () malformDatumTweak change = do outputs <- viewAllTweak (txSkelOutsL % traversed) let modifiedOutputs = map (\output -> output : changeOutput output) outputs diff --git a/src/Cooked/Tweak/Signatories.hs b/src/Cooked/Tweak/Signatories.hs index bb15b54aa..8c71e3c4b 100644 --- a/src/Cooked/Tweak/Signatories.hs +++ b/src/Cooked/Tweak/Signatories.hs @@ -17,63 +17,98 @@ module Cooked.Tweak.Signatories ) where -import Cooked.Skeleton (TxSkelSignatory, txSkelSignatoriesL) -import Cooked.Tweak.Common (MonadTweak, setTweak, viewTweak) +import Cooked.Skeleton +import Cooked.Tweak.Common import Data.List (delete, (\\)) +import Polysemy -- | Returns the current list of signatories -getSignatoriesTweak :: (MonadTweak m) => m [TxSkelSignatory] +getSignatoriesTweak :: + (Member Tweak effs) => + Sem effs [TxSkelSignatory] getSignatoriesTweak = viewTweak txSkelSignatoriesL -- | Apply a function to the list of signatories and return the old ones -modifySignatoriesTweak :: (MonadTweak m) => ([TxSkelSignatory] -> [TxSkelSignatory]) -> m [TxSkelSignatory] +modifySignatoriesTweak :: + (Member Tweak effs) => + ([TxSkelSignatory] -> [TxSkelSignatory]) -> + Sem effs [TxSkelSignatory] modifySignatoriesTweak f = do oldSignatories <- getSignatoriesTweak setTweak txSkelSignatoriesL (f oldSignatories) return oldSignatories -- | Change the current signatories and return the old ones -setSignatoriesTweak :: (MonadTweak m) => [TxSkelSignatory] -> m [TxSkelSignatory] +setSignatoriesTweak :: + (Member Tweak effs) => + [TxSkelSignatory] -> + Sem effs [TxSkelSignatory] setSignatoriesTweak = modifySignatoriesTweak . const -- | Check if the signatories satisfy a certain predicate -signatoriesSatisfyTweak :: (MonadTweak m) => ([TxSkelSignatory] -> Bool) -> m Bool +signatoriesSatisfyTweak :: + (Member Tweak effs) => + ([TxSkelSignatory] -> Bool) -> + Sem effs Bool signatoriesSatisfyTweak = (<$> getSignatoriesTweak) -- | Check if a signatory signs a transaction -isSignatoryTweak :: (MonadTweak m) => TxSkelSignatory -> m Bool +isSignatoryTweak :: + (Member Tweak effs) => + TxSkelSignatory -> + Sem effs Bool isSignatoryTweak = signatoriesSatisfyTweak . elem -- | Check if the transaction has at least a signatory -hasSignatoriesTweak :: (MonadTweak m) => m Bool +hasSignatoriesTweak :: + (Member Tweak effs) => + Sem effs Bool hasSignatoriesTweak = signatoriesSatisfyTweak (not . null) -- | Add a signatory to the transaction, at the head of the list of signatories, and -- return the old list of signatories -addFirstSignatoryTweak :: (MonadTweak m) => TxSkelSignatory -> m [TxSkelSignatory] +addFirstSignatoryTweak :: + (Member Tweak effs) => + TxSkelSignatory -> + Sem effs [TxSkelSignatory] addFirstSignatoryTweak = modifySignatoriesTweak . (:) -- | Add signatories at the end of the list of signatories, and return the old list of -- signatories -addSignatoriesTweak :: (MonadTweak m) => [TxSkelSignatory] -> m [TxSkelSignatory] +addSignatoriesTweak :: + (Member Tweak effs) => + [TxSkelSignatory] -> + Sem effs [TxSkelSignatory] addSignatoriesTweak = modifySignatoriesTweak . (<>) -- | Add a signatory to the transaction, at the end of the list of signatories, and -- return the old list of signatories -addLastSignatoryTweak :: (MonadTweak m) => TxSkelSignatory -> m [TxSkelSignatory] +addLastSignatoryTweak :: + (Member Tweak effs) => + TxSkelSignatory -> + Sem effs [TxSkelSignatory] addLastSignatoryTweak = addSignatoriesTweak . (: []) -- | Remove signatories from the transaction and return the old list of signatories -removeSignatoriesTweak :: (MonadTweak m) => [TxSkelSignatory] -> m [TxSkelSignatory] +removeSignatoriesTweak :: + (Member Tweak effs) => + [TxSkelSignatory] -> + Sem effs [TxSkelSignatory] removeSignatoriesTweak = modifySignatoriesTweak . (\\) -- | Remove a signatory from the transaction and return the old list of signatories -removeSignatoryTweak :: (MonadTweak m) => TxSkelSignatory -> m [TxSkelSignatory] +removeSignatoryTweak :: + (Member Tweak effs) => + TxSkelSignatory -> + Sem effs [TxSkelSignatory] removeSignatoryTweak = modifySignatoriesTweak . delete -- | Changes the first signatory (adds it if there are no signatories) and return the -- old list of signatories. -replaceFirstSignatoryTweak :: (MonadTweak m) => TxSkelSignatory -> m [TxSkelSignatory] +replaceFirstSignatoryTweak :: + (Member Tweak effs) => + TxSkelSignatory -> + Sem effs [TxSkelSignatory] replaceFirstSignatoryTweak = modifySignatoriesTweak . ( \newSignatory -> \case diff --git a/src/Cooked/Tweak/ValidityRange.hs b/src/Cooked/Tweak/ValidityRange.hs index efc8fe268..b735b41a8 100644 --- a/src/Cooked/Tweak/ValidityRange.hs +++ b/src/Cooked/Tweak/ValidityRange.hs @@ -1,64 +1,122 @@ -- | This module defines 'Tweak's revolving around the validity range of a -- transaction -module Cooked.Tweak.ValidityRange where +module Cooked.Tweak.ValidityRange + ( getValidityRangeTweak, + setValidityRangeTweak, + setAlwaysValidRangeTweak, + setValidityStartTweak, + setValidityEndTweak, + validityRangeSatisfiesTweak, + isValidAtTweak, + isValidNowTweak, + isValidDuringTweak, + hasEmptyTimeRangeTweak, + hasFullTimeRangeTweak, + intersectValidityRangeTweak, + centerAroundValidityRangeTweak, + makeValidityRangeSingletonTweak, + makeValidityRangeNowTweak, + ) +where import Control.Monad -import Cooked.MockChain +import Cooked.MockChain.Read import Cooked.Skeleton import Cooked.Tweak.Common import Ledger.Slot qualified as Ledger import PlutusLedgerApi.V1.Interval qualified as Api +import Polysemy +import Polysemy.NonDet -- | Looks up the current validity range of the transaction -getValidityRangeTweak :: (MonadTweak m) => m Ledger.SlotRange +getValidityRangeTweak :: + (Member Tweak effs) => + Sem effs Ledger.SlotRange getValidityRangeTweak = viewTweak txSkelValidityRangeL -- | Changes the current validity range, returning the old one -setValidityRangeTweak :: (MonadTweak m) => Ledger.SlotRange -> m Ledger.SlotRange +setValidityRangeTweak :: + (Member Tweak effs) => + Ledger.SlotRange -> + Sem effs Ledger.SlotRange setValidityRangeTweak newRange = do oldRange <- getValidityRangeTweak setTweak txSkelValidityRangeL newRange return oldRange -- | Ensures the skeleton makes for an unconstrained validity range -setAlwaysValidRangeTweak :: (MonadTweak m) => m Ledger.SlotRange +setAlwaysValidRangeTweak :: + (Member Tweak effs) => + Sem effs Ledger.SlotRange setAlwaysValidRangeTweak = setValidityRangeTweak Api.always -- | Sets the left bound of the validity range. Leaves the right bound unchanged -setValidityStartTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange -setValidityStartTweak left = getValidityRangeTweak >>= setValidityRangeTweak . Api.Interval (Api.LowerBound (Api.Finite left) True) . Api.ivTo +setValidityStartTweak :: + (Member Tweak effs) => + Ledger.Slot -> + Sem effs Ledger.SlotRange +setValidityStartTweak left = + getValidityRangeTweak + >>= setValidityRangeTweak + . Api.Interval (Api.LowerBound (Api.Finite left) True) + . Api.ivTo -- | Sets the right bound of the validity range. Leaves the left bound unchanged -setValidityEndTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange -setValidityEndTweak right = getValidityRangeTweak >>= setValidityRangeTweak . flip Api.Interval (Api.UpperBound (Api.Finite right) True) . Api.ivFrom +setValidityEndTweak :: + (Member Tweak effs) => + Ledger.Slot -> + Sem effs Ledger.SlotRange +setValidityEndTweak right = + getValidityRangeTweak + >>= setValidityRangeTweak + . flip Api.Interval (Api.UpperBound (Api.Finite right) True) + . Api.ivFrom -- | Checks if the validity range satisfies a certain predicate -validityRangeSatisfiesTweak :: (MonadTweak m) => (Ledger.SlotRange -> Bool) -> m Bool +validityRangeSatisfiesTweak :: + (Member Tweak effs) => + (Ledger.SlotRange -> Bool) -> + Sem effs Bool validityRangeSatisfiesTweak = (<$> getValidityRangeTweak) -- | Checks if a given time belongs to the validity range of a transaction -isValidAtTweak :: (MonadTweak m) => Ledger.Slot -> m Bool +isValidAtTweak :: + (Member Tweak effs) => + Ledger.Slot -> + Sem effs Bool isValidAtTweak = validityRangeSatisfiesTweak . Api.member -- | Checks if the current validity range includes the current time -isValidNowTweak :: (MonadTweak m) => m Bool +isValidNowTweak :: + (Members '[Tweak, MockChainRead] effs) => + Sem effs Bool isValidNowTweak = currentSlot >>= isValidAtTweak -- | Checks if a given range is included in the validity range of a transaction -isValidDuringTweak :: (MonadTweak m) => Ledger.SlotRange -> m Bool +isValidDuringTweak :: + (Member Tweak effs) => + Ledger.SlotRange -> + Sem effs Bool isValidDuringTweak = validityRangeSatisfiesTweak . flip Api.contains -- | Checks if the validity range is empty -hasEmptyTimeRangeTweak :: (MonadTweak m) => m Bool +hasEmptyTimeRangeTweak :: + (Member Tweak effs) => + Sem effs Bool hasEmptyTimeRangeTweak = validityRangeSatisfiesTweak Api.isEmpty -- | Checks if the validity range is unconstrained -hasFullTimeRangeTweak :: (MonadTweak m) => m Bool +hasFullTimeRangeTweak :: + (Member Tweak effs) => + Sem effs Bool hasFullTimeRangeTweak = validityRangeSatisfiesTweak (Api.always ==) -- | Adds a constraint to the current validity range. Returns the old range, and -- fails is the resulting interval is empty -intersectValidityRangeTweak :: (MonadTweak m) => Ledger.SlotRange -> m Ledger.SlotRange +intersectValidityRangeTweak :: + (Members '[Tweak, NonDet] effs) => + Ledger.SlotRange -> + Sem effs Ledger.SlotRange intersectValidityRangeTweak newRange = do oldRange <- viewTweak txSkelValidityRangeL let combinedRange = Api.intersection newRange oldRange @@ -67,37 +125,23 @@ intersectValidityRangeTweak newRange = do return oldRange -- | Centers the validity range around a value with a certain radius -centerAroundValidityRangeTweak :: (MonadTweak m) => Ledger.Slot -> Integer -> m Ledger.SlotRange -centerAroundValidityRangeTweak t r = do - let radius = Ledger.Slot r - left = t - radius - right = t + radius - newRange = Api.interval left right - setValidityRangeTweak newRange +centerAroundValidityRangeTweak :: + (Member Tweak effs) => + Ledger.Slot -> + Integer -> + Sem effs Ledger.SlotRange +centerAroundValidityRangeTweak t (Ledger.Slot -> radius) = do + setValidityRangeTweak $ Api.interval (t - radius) (t + radius) -- | Makes a transaction range equal to a singleton -makeValidityRangeSingletonTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange +makeValidityRangeSingletonTweak :: + (Member Tweak effs) => + Ledger.Slot -> + Sem effs Ledger.SlotRange makeValidityRangeSingletonTweak = setValidityRangeTweak . Api.singleton -- | Makes the transaction validity range comply with the current time -makeValidityRangeNowTweak :: (MonadTweak m) => m Ledger.SlotRange +makeValidityRangeNowTweak :: + (Members '[Tweak, MockChainRead] effs) => + Sem effs Ledger.SlotRange makeValidityRangeNowTweak = currentSlot >>= makeValidityRangeSingletonTweak - --- | Makes current time comply with the validity range of the transaction under --- modification. Returns the new current time after the modification; fails if --- current time is already after the validity range. -waitUntilValidTweak :: (MonadTweak m) => m Ledger.Slot -waitUntilValidTweak = do - now <- currentSlot - vRange <- getValidityRangeTweak - if Api.member now vRange - then return now - else do - guard $ Api.before now vRange - guard $ not $ Api.isEmpty vRange - later <- case Api.ivFrom vRange of - Api.LowerBound (Api.Finite left) isClosed -> - return $ left + fromIntegral (fromEnum $ not isClosed) - _ -> fail "Unexpected left-finite interval without left border: please report a bug at https://github.com/tweag/cooked-validators/issues" - void $ awaitSlot later - return later diff --git a/tests/Spec.hs b/tests/Spec.hs index 5ef3a09d9..59a72ab31 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -11,6 +11,7 @@ import Spec.ProposingScript qualified as ProposingScript import Spec.ReferenceInputs qualified as ReferenceInputs import Spec.ReferenceScripts qualified as ReferenceScripts import Spec.Slot qualified as Slot +import Spec.StagedRun qualified as Staged import Spec.Tweak qualified as Tweak import Spec.Withdrawals qualified as Withdrawals import Test.Tasty @@ -33,6 +34,7 @@ main = ReferenceInputs.tests, ReferenceScripts.tests, Slot.tests, + Staged.tests, Tweak.tests, Withdrawals.tests ] diff --git a/tests/Spec/Attack/DatumHijacking.hs b/tests/Spec/Attack/DatumHijacking.hs index f8065a7fc..2ba2d2201 100644 --- a/tests/Spec/Attack/DatumHijacking.hs +++ b/tests/Spec/Attack/DatumHijacking.hs @@ -3,13 +3,14 @@ module Spec.Attack.DatumHijacking (tests) where import Cooked -import Data.Bifunctor import Data.Map qualified as Map import Optics.Core import Plutus.Attack.DatumHijacking import Plutus.Script.Utils.V3 qualified as Script import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.NonDet import Prettyprinter import Test.Tasty import Test.Tasty.HUnit @@ -27,10 +28,10 @@ lockTxSkel o v = txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } -txLock :: (MonadBlockChain m) => Script.MultiPurposeScript DHContract -> m Api.TxOutRef +txLock :: Script.MultiPurposeScript DHContract -> StagedMockChain Api.TxOutRef txLock v = do - (oref, _) : _ <- runUtxoSearch $ utxosOwnedBySearch (wallet 1) `filterWithValuePred` (`Api.geq` lockValue) - head <$> validateTxSkel' (lockTxSkel oref v) + oref : _ <- getTxOutRefs $ utxosAtSearch (wallet 1) $ ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` lockValue)) + fst . head <$> validateTxSkel' (lockTxSkel oref v) relockTxSkel :: Script.MultiPurposeScript DHContract -> Api.TxOutRef -> TxSkel relockTxSkel v o = @@ -41,19 +42,15 @@ relockTxSkel v o = } txRelock :: - (MonadBlockChain m) => Script.MultiPurposeScript DHContract -> Api.TxOutRef -> - m () + StagedMockChain () txRelock v oref = validateTxSkel_ $ relockTxSkel v oref -datumHijackingTrace :: (MonadBlockChain m) => Script.MultiPurposeScript DHContract -> m () +datumHijackingTrace :: Script.MultiPurposeScript DHContract -> StagedMockChain () datumHijackingTrace v = do txLock v >>= txRelock v -txSkelFromOuts :: [TxSkelOut] -> TxSkel -txSkelFromOuts os = txSkelTemplate {txSkelOuts = os, txSkelSignatories = txSkelSignatoriesFromList [wallet 1]} - -- * TestTree for the datum hijacking attack thief :: Script.MultiPurposeScript DHContract @@ -64,72 +61,60 @@ tests = testGroup "datum hijacking attack" [ testGroup "unit tests on a 'TxSkel'" $ - let x1 = Script.lovelace 10001 - x2 = Script.lovelace 10000 - x3 = Script.lovelace 9999 - skelIn = - txSkelFromOuts - [ carelessValidator `receives` InlineDatum SecondLock <&&> Value x1, - carelessValidator `receives` InlineDatum SecondLock <&&> Value x3, - carefulValidator `receives` InlineDatum SecondLock <&&> Value x1, - carelessValidator `receives` InlineDatum FirstLock <&&> Value x2, - carelessValidator `receives` InlineDatum SecondLock <&&> Value x2 - ] - skelOut bound select = - ( fmap (second txSkelOuts) - <$> runTweak - ( datumHijackingAttack $ - ( txSkelOutPredDatumHijackingParams - ( \out -> - preview (txSkelOutOwnerL % userScriptHashAF) out == Just (Script.toScriptHash carelessValidator) - && view txSkelOutDatumL out == SomeTxSkelOutDatum SecondLock Inline - && bound `Api.geq` view txSkelOutValueL out - ) - thief + let value_10_001 = Script.lovelace 10_001 + value_10_000 = Script.lovelace 10000 + value_9_999 = Script.lovelace 9999 + inSkel = + txSkelTemplate + { txSkelOuts = + [ carelessValidator `receives` InlineDatum SecondLock <&&> Value value_10_001, + carelessValidator `receives` InlineDatum SecondLock <&&> Value value_9_999, + carefulValidator `receives` InlineDatum SecondLock <&&> Value value_10_001, + carelessValidator `receives` InlineDatum FirstLock <&&> Value value_10_000, + carelessValidator `receives` InlineDatum SecondLock <&&> Value value_10_000 + ], + txSkelSignatories = txSkelSignatoriesFromList [wallet 1] + } + outSkelOutputs :: Api.Value -> (Integer -> Bool) -> [[TxSkelOut]] + outSkelOutputs bound select = + (fmap txSkelOuts . run . runNonDet . execTweak inSkel) + ( datumHijackingAttack $ + ( outPredDatumHijackingParams + ( \out -> + preview (txSkelOutOwnerL % userScriptHashAF) out == Just (Script.toScriptHash carelessValidator) + && view txSkelOutDatumL out == SomeTxSkelOutDatum SecondLock Inline + && bound `Api.geq` view txSkelOutValueL out ) - { dhpAllOutputs = True, - dhpIndexPred = select - } + thief ) - skelIn - ) + { dhpAllOutputs = True, + dhpIndexPred = select + } + ) outsExpected a b = - [ carelessValidator `receives` InlineDatum SecondLock <&&> Value x1, - a `receives` InlineDatum SecondLock <&&> Value x3, - carefulValidator `receives` InlineDatum SecondLock <&&> Value x1, - carelessValidator `receives` InlineDatum FirstLock <&&> Value x2, - b `receives` InlineDatum SecondLock <&&> Value x2 + [ carelessValidator `receives` InlineDatum SecondLock <&&> Value value_10_001, + a `receives` InlineDatum SecondLock <&&> Value value_9_999, + carefulValidator `receives` InlineDatum SecondLock <&&> Value value_10_001, + carelessValidator `receives` InlineDatum FirstLock <&&> Value value_10_000, + b `receives` InlineDatum SecondLock <&&> Value value_10_000 ] - in [ testCase "no modified transactions if no interesting outputs to steal" $ [] @=? mcrValue <$> skelOut mempty (const True), + in [ testCase "no modified transactions if no interesting outputs to steal" $ + [] @=? outSkelOutputs mempty (const True), testCase "one modified transaction for one interesting output" $ - [ Right - ( [carelessValidator `receives` (InlineDatum SecondLock <&&> Value x3)], - outsExpected thief carelessValidator - ) - ] - @=? mcrValue <$> skelOut x2 (0 ==), + [outsExpected thief carelessValidator] + @=? outSkelOutputs value_10_000 (0 ==), testCase "two modified transactions for two interesting outputs" $ - [ Right - ( [ carelessValidator `receives` (InlineDatum SecondLock <&&> Value x3), - carelessValidator `receives` (InlineDatum SecondLock <&&> Value x2) - ], - outsExpected thief thief - ) - ] - @=? mcrValue <$> skelOut x2 (const True), + [outsExpected thief thief] + @=? outSkelOutputs value_10_000 (const True), testCase "select second interesting output to get one modified transaction" $ - [ Right - ( [carelessValidator `receives` (InlineDatum SecondLock <&&> Value x2)], - outsExpected carelessValidator thief - ) - ] - @=? mcrValue <$> skelOut x2 (1 ==) + [outsExpected carelessValidator thief] + @=? outSkelOutputs value_10_000 (1 ==) ], testCooked "careful validator" $ mustFailInPhase2Test $ somewhere ( datumHijackingAttack $ - ( txSkelOutPredDatumHijackingParams + ( outPredDatumHijackingParams ( \out -> preview (txSkelOutOwnerL % userScriptHashAF) out == Just (Script.toScriptHash carefulValidator) && view txSkelOutDatumL out == SomeTxSkelOutDatum SecondLock Inline @@ -144,7 +129,7 @@ tests = mustSucceedTest $ somewhere ( datumHijackingAttack $ - ( txSkelOutPredDatumHijackingParams + ( outPredDatumHijackingParams ( \out -> preview (txSkelOutOwnerL % userScriptHashAF) out == Just (Script.toScriptHash carelessValidator) && view txSkelOutDatumL out == SomeTxSkelOutDatum SecondLock Inline diff --git a/tests/Spec/Attack/DoubleSat.hs b/tests/Spec/Attack/DoubleSat.hs index 4c4d4c370..00cb4a82f 100644 --- a/tests/Spec/Attack/DoubleSat.hs +++ b/tests/Spec/Attack/DoubleSat.hs @@ -5,9 +5,9 @@ module Spec.Attack.DoubleSat (tests) where import Control.Arrow import Cooked import Data.Default +import Data.Either import Data.List (subsequences) import Data.Map qualified as Map -import Data.Maybe import Data.Set qualified as Set import Data.Tuple (swap) import Optics.Core @@ -35,18 +35,24 @@ instance PrettyCooked BRedeemer where customInitDist :: InitialDistribution customInitDist = def - <> InitialDistribution ((\n -> aValidator `receives` VisibleHashedDatum ADatum <&&> Value (Script.ada n)) <$> [2, 3, 4, 5]) - <> InitialDistribution ((\n -> bValidator `receives` VisibleHashedDatum BDatum <&&> Value (Script.ada n)) <$> [6, 7]) + <> InitialDistribution + ( ((\n -> aValidator `receives` VisibleHashedDatum ADatum <&&> Value (Script.ada n)) <$> [2, 3, 4, 5]) + <> ((\n -> bValidator `receives` VisibleHashedDatum BDatum <&&> Value (Script.ada n)) <$> [6, 7]) + ) -- | Utxos generated from the initial distribution aUtxo1, aUtxo2, aUtxo3, aUtxo4, bUtxo1, bUtxo2 :: (V3.TxOutRef, TxSkelOut) (aUtxo1, aUtxo2, aUtxo3, aUtxo4, bUtxo1, bUtxo2) = - case mcrValue $ runMockChainFromInitDist customInitDist $ do - [a1, a2, a3, a4] <- runUtxoSearch $ utxosOwnedBySearch aValidator - [b1, b2] <- runUtxoSearch $ utxosOwnedBySearch bValidator - return (a1, a2, a3, a4, b1, b2) of - Left _ -> error "Initial distribution error" - Right a -> a + case mcrValue + <$> runMockChainFromInitDist @DirectEffs + customInitDist + ( do + [a1, a2, a3, a4] <- utxosAt aValidator + [b1, b2] <- utxosAt bValidator + return (a1, a2, a3, a4, b1, b2) + ) of + [Right a] -> a + _ -> error "Initial distribution error" tests :: TestTree tests = @@ -80,47 +86,45 @@ tests = -- on the focused input 'aValidator' UTxO. skelsOut :: ([V3.TxOutRef] -> [[V3.TxOutRef]]) -> [(ARedeemer, V3.TxOutRef)] -> [TxSkel] skelsOut splitMode aInputs = - mapMaybe - ((\case Right (_, skel') -> Just skel'; _ -> Nothing) . mcrValue) - ( runTweakFrom - customInitDist - ( doubleSatAttack - splitMode - (txSkelInsL % itraversed) -- we know that every 'TxOutRef' in the inputs points to a UTxO that the 'aValidator' owns - ( \aOref _aRedeemer -> do - bUtxos <- runUtxoSearch $ utxosOwnedBySearch bValidator - if - | aOref == fst aUtxo1 -> - return - [ (someTxSkelRedeemer ARedeemer2, toDelta bOref $ someTxSkelRedeemer BRedeemer1) - | (bOref, bOut) <- bUtxos, - view txSkelOutValueL bOut == Script.lovelace 123 -- not satisfied by any UTxO in 'dsTestMockChain' - ] - | aOref == fst aUtxo2 -> - return - [ (someTxSkelRedeemer ARedeemer2, toDelta bOref $ someTxSkelRedeemer BRedeemer1) - | (bOref, _) <- bUtxos, - bOref == fst bUtxo1 - ] - | aOref == fst aUtxo3 -> - return $ - concatMap - ( \(bOref, _) -> - if - | bOref == fst bUtxo1 -> - [(someTxSkelRedeemer ARedeemer2, toDelta bOref $ someTxSkelRedeemer BRedeemer1)] - | bOref == fst bUtxo2 -> - [ (someTxSkelRedeemer ARedeemer2, toDelta bOref $ someTxSkelRedeemer BRedeemer1), - (someTxSkelRedeemer ARedeemer3, toDelta bOref $ someTxSkelRedeemer BRedeemer2) - ] - | otherwise -> [] - ) - bUtxos - | otherwise -> return [] - ) - (wallet 6) - ) - (skelIn aInputs) + rights + ( fmap mcrValue $ + runMockChainFromInitDist @StagedEffs customInitDist $ + execTweak (skelIn aInputs) $ + doubleSatAttack + splitMode + (txSkelInsL % itraversed) -- we know that every 'TxOutRef' in the inputs points to a UTxO that the 'aValidator' owns + ( \aOref _aRedeemer -> do + bUtxos <- utxosAt bValidator + if + | aOref == fst aUtxo1 -> + return + [ (someTxSkelRedeemer ARedeemer2, toDelta bOref $ someTxSkelRedeemer BRedeemer1) + | (bOref, bOut) <- bUtxos, + view txSkelOutValueL bOut == Script.lovelace 123 -- not satisfied by any UTxO in 'dsTestMockChain' + ] + | aOref == fst aUtxo2 -> + return + [ (someTxSkelRedeemer ARedeemer2, toDelta bOref $ someTxSkelRedeemer BRedeemer1) + | (bOref, _) <- bUtxos, + bOref == fst bUtxo1 + ] + | aOref == fst aUtxo3 -> + return $ + concatMap + ( \(bOref, _) -> + if + | bOref == fst bUtxo1 -> + [(someTxSkelRedeemer ARedeemer2, toDelta bOref $ someTxSkelRedeemer BRedeemer1)] + | bOref == fst bUtxo2 -> + [ (someTxSkelRedeemer ARedeemer2, toDelta bOref $ someTxSkelRedeemer BRedeemer1), + (someTxSkelRedeemer ARedeemer3, toDelta bOref $ someTxSkelRedeemer BRedeemer2) + ] + | otherwise -> [] + ) + bUtxos + | otherwise -> return [] + ) + (wallet 6) ) where toDelta :: V3.TxOutRef -> TxSkelRedeemer -> DoubleSatDelta @@ -134,7 +138,7 @@ tests = skelExpected :: [(ARedeemer, V3.TxOutRef)] -> [(BRedeemer, (V3.TxOutRef, TxSkelOut))] -> TxSkel skelExpected aInputs bInputs = txSkelTemplate - { txSkelLabel = Set.singleton $ TxSkelLabel DoubleSatLbl, + { txSkelLabels = Set.singleton $ TxSkelLabel DoubleSatLbl, txSkelIns = Map.fromList ( ( \(bRedeemer, (bOref, _)) -> diff --git a/tests/Spec/Attack/DupToken.hs b/tests/Spec/Attack/DupToken.hs index b51a4f02d..dc9a9fe47 100644 --- a/tests/Spec/Attack/DupToken.hs +++ b/tests/Spec/Attack/DupToken.hs @@ -8,10 +8,12 @@ import Optics.Core import Plutus.Attack.DupToken import Plutus.Script.Utils.V3 qualified as Script import PlutusLedgerApi.V1.Value qualified as Api +import Polysemy +import Polysemy.NonDet import Test.Tasty import Test.Tasty.HUnit -dupTokenTrace :: (MonadBlockChain m) => Script.Versioned Script.MintingPolicy -> Api.TokenName -> Integer -> Wallet -> m () +dupTokenTrace :: Script.Versioned Script.MintingPolicy -> Api.TokenName -> Integer -> Wallet -> StagedMockChain () dupTokenTrace pol tName amount recipient = validateTxSkel_ skel where skel = @@ -49,34 +51,33 @@ tests = ], txSkelSignatories = txSkelSignatoriesFromList [wallet 3] } - skelOut select = runTweak (dupTokenAttack select attacker) skelIn + skelOut select = (run . runNonDet . runTweak skelIn) (dupTokenAttack select attacker) skelExpected v1 v2 = let increment = Api.assetClassValue ac1 (v1 - 5) <> Api.assetClassValue ac2 (v2 - 7) - in [ Right - ( increment, - txSkelTemplate - { txSkelLabel = Set.singleton $ TxSkelLabel DupTokenLbl, - txSkelMints = - review - txSkelMintsListI - [ mint pol1 () tName1 v1, - mint pol2 () tName2 v2 - ], - txSkelOuts = - [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Script.lovelace 1234), - wallet 2 `receives` Value (Api.assetClassValue ac2 2), - attacker `receives` Value increment + in [ ( txSkelTemplate + { txSkelLabels = Set.singleton $ TxSkelLabel DupTokenLbl, + txSkelMints = + review + txSkelMintsListI + [ mint pol1 () tName1 v1, + mint pol2 () tName2 v2 ], - txSkelSignatories = txSkelSignatoriesFromList [wallet 3] - } - ) + txSkelOuts = + [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Script.lovelace 1234), + wallet 2 `receives` Value (Api.assetClassValue ac2 2), + attacker `receives` Value increment + ], + txSkelSignatories = txSkelSignatoriesFromList [wallet 3] + }, + increment + ) ] in [ testCase "add one token in every asset class" $ - skelExpected 6 8 @=? mcrValue <$> skelOut (\_ _ n -> n + 1), + skelExpected 6 8 @=? skelOut (\_ _ n -> n + 1), testCase "no modified transaction if no increase in value specified" $ - [] @=? mcrValue <$> skelOut (\_ _ n -> n), + [] @=? skelOut (\_ _ n -> n), testCase "add tokens depending on the asset class" $ - skelExpected 10 7 @=? mcrValue <$> skelOut (\mp tk n -> if Api.assetClass (Script.toCurrencySymbol mp) tk == ac1 then n + 5 else n) + skelExpected 10 7 @=? skelOut (\mp tk n -> if Api.assetClass (Script.toCurrencySymbol mp) tk == ac1 then n + 5 else n) ], testCooked "careful minting policy" $ let tName = Api.TokenName "MockToken" @@ -103,19 +104,18 @@ tests = txSkelSignatories = txSkelSignatoriesFromList [wallet 2] } skelExpected = - [ Right - ( Api.assetClassValue ac1 1, - txSkelTemplate - { txSkelLabel = Set.singleton $ TxSkelLabel DupTokenLbl, - txSkelMints = review txSkelMintsListI [mint pol () tName1 2], - txSkelOuts = - [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Api.assetClassValue ac2 2), - attacker `receives` Value (Api.assetClassValue ac1 1) - ], - txSkelSignatories = txSkelSignatoriesFromList [wallet 2] - } - ) + [ ( txSkelTemplate + { txSkelLabels = Set.singleton $ TxSkelLabel DupTokenLbl, + txSkelMints = review txSkelMintsListI [mint pol () tName1 2], + txSkelOuts = + [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Api.assetClassValue ac2 2), + attacker `receives` Value (Api.assetClassValue ac1 1) + ], + txSkelSignatories = txSkelSignatoriesFromList [wallet 2] + }, + Api.assetClassValue ac1 1 + ) ] - skelOut = runTweak (dupTokenAttack (\_ _ i -> i + 1) attacker) skelIn - in skelExpected @=? mcrValue <$> skelOut + skelOut = (run . runNonDet . runTweak skelIn) (dupTokenAttack (\_ _ i -> i + 1) attacker) + in skelExpected @=? skelOut ] diff --git a/tests/Spec/Balancing.hs b/tests/Spec/Balancing.hs index 12166fd50..6668af1af 100644 --- a/tests/Spec/Balancing.hs +++ b/tests/Spec/Balancing.hs @@ -8,7 +8,6 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text (isInfixOf) import Ledger.Index qualified as Ledger -import ListT import Optics.Core import Optics.Core.Extras import Plutus.Script.Utils.V3 qualified as Script @@ -41,35 +40,34 @@ initialDistributionBalancing = type TestBalancingOutcome = (TxSkel, TxSkel, Fee, Collaterals, [Api.TxOutRef]) -spendsScriptUtxo :: (MonadBlockChain m) => Bool -> m (Map Api.TxOutRef TxSkelRedeemer) +spendsScriptUtxo :: Bool -> FullMockChain (Map Api.TxOutRef TxSkelRedeemer) spendsScriptUtxo False = return Map.empty spendsScriptUtxo True = do - (scriptOutRef, _) : _ <- runUtxoSearch $ utxosOwnedBySearch $ Script.trueSpendingMPScript @() + (scriptOutRef, _) : _ <- utxosAt $ Script.trueSpendingMPScript @() return $ Map.singleton scriptOutRef emptyTxSkelRedeemerNoAutoFill testingBalancingTemplate :: - (MonadBlockChain m) => -- Value to pay to bob Api.Value -> -- Value to pay back to alice Api.Value -> - -- Search for utxos to be spent - UtxoSearch m a -> - -- Search for utxos to be used for balancing - UtxoSearch m b -> - -- Search for utxos to be used for collaterals - UtxoSearch m c -> + -- utxos to be spent + FullMockChain [Api.TxOutRef] -> + -- utxos to be used for balancing + FullMockChain [Api.TxOutRef] -> + -- utxos to be used for collaterals + FullMockChain [Api.TxOutRef] -> -- Whether to consum the script utxo Bool -> -- Option modifications (TxSkelOpts -> TxSkelOpts) -> -- Wether to adjust the output with min ada Bool -> - m TestBalancingOutcome + FullMockChain TestBalancingOutcome testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch collateralSearch consumeScriptUtxo optionsMod adjust = do - ((fst <$>) -> toSpendUtxos) <- runUtxoSearch spendSearch - ((fst <$>) -> toBalanceUtxos) <- runUtxoSearch balanceSearch - ((fst <$>) -> toCollateralUtxos) <- runUtxoSearch collateralSearch + toSpendUtxos <- spendSearch + toBalanceUtxos <- balanceSearch + toCollateralUtxos <- collateralSearch additionalSpend <- spendsScriptUtxo consumeScriptUtxo let valueConstr = if adjust then Value else FixedValue skel = @@ -97,25 +95,33 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla } (skel', fee, mCols) <- balanceTxSkel skel validateTxSkel_ skel - nonOnlyValueUtxos <- runUtxoSearch aliceNonOnlyValueUtxos - return (skel, skel', fee, mCols, fst <$> nonOnlyValueUtxos) + nonOnlyValueUtxos <- aliceNonOnlyValueUtxos + return (skel, skel', fee, mCols, nonOnlyValueUtxos) -aliceNonOnlyValueUtxos :: (MonadBlockChain m) => UtxoSearch m TxSkelOut +aliceNonOnlyValueUtxos :: FullMockChain [Api.TxOutRef] aliceNonOnlyValueUtxos = - utxosOwnedBySearch alice `filterWithPred` \o -> - is txSkelOutReferenceScriptAT o - || is (txSkelOutDatumL % txSkelOutDatumKindAT) o - -aliceNAdaUtxos :: (MonadBlockChain m) => Integer -> UtxoSearch m TxSkelOut -aliceNAdaUtxos n = utxosOwnedBySearch alice `filterWithValuePred` ((== Api.Lovelace (n * 1_000_000)) . Api.lovelaceValueOf) - -aliceRefScriptUtxos :: (MonadBlockChain m) => UtxoSearch m TxSkelOut -aliceRefScriptUtxos = utxosOwnedBySearch alice `filterWithPred` is txSkelOutReferenceScriptAT - -emptySearch :: (MonadBlockChain m) => UtxoSearch m TxSkelOut -emptySearch = ListT.fromFoldable [] - -simplePaymentToBob :: (MonadBlockChain m) => Integer -> Integer -> Integer -> Integer -> Bool -> (TxSkelOpts -> TxSkelOpts) -> Bool -> m TestBalancingOutcome + getTxOutRefs $ + utxosAtSearch alice $ + ensurePure $ \skel -> + is txSkelOutReferenceScriptAT skel + || is (txSkelOutDatumL % txSkelOutDatumKindAT) skel + +aliceNAdaUtxos :: Integer -> FullMockChain [Api.TxOutRef] +aliceNAdaUtxos n = + getTxOutRefs $ + utxosAtSearch alice $ + ensureAFoldIs (txSkelOutValueL % valueLovelaceL % filtered (== Api.Lovelace (n * 1_000_000))) + +aliceRefScriptUtxos :: FullMockChain [Api.TxOutRef] +aliceRefScriptUtxos = + getTxOutRefs $ + utxosAtSearch alice $ + ensureAFoldIs txSkelOutReferenceScriptAT + +emptySearch :: FullMockChain [Api.TxOutRef] +emptySearch = return [] + +simplePaymentToBob :: Integer -> Integer -> Integer -> Integer -> Bool -> (TxSkelOpts -> TxSkelOpts) -> Bool -> FullMockChain TestBalancingOutcome simplePaymentToBob lv apples oranges bananas = testingBalancingTemplate (Script.lovelace lv <> apple apples <> orange oranges <> banana bananas) @@ -124,7 +130,7 @@ simplePaymentToBob lv apples oranges bananas = emptySearch emptySearch -bothPaymentsToBobAndAlice :: (MonadBlockChain m) => Integer -> Bool -> (TxSkelOpts -> TxSkelOpts) -> Bool -> m TestBalancingOutcome +bothPaymentsToBobAndAlice :: Integer -> Bool -> (TxSkelOpts -> TxSkelOpts) -> Bool -> FullMockChain TestBalancingOutcome bothPaymentsToBobAndAlice val = testingBalancingTemplate (Script.lovelace val) @@ -133,10 +139,10 @@ bothPaymentsToBobAndAlice val = emptySearch emptySearch -noBalanceMaxFee :: (MonadBlockChain m) => m () +noBalanceMaxFee :: FullMockChain () noBalanceMaxFee = do maxFee <- snd <$> getMinAndMaxFee 0 - ((txOutRef, _) : _) <- runUtxoSearch $ utxosOwnedBySearch alice `filterWithValuePred` (== Script.ada 30) + (txOutRef : _) <- aliceNAdaUtxos 30 validateTxSkel_ $ txSkelTemplate { txSkelOuts = [bob `receives` Value (Script.lovelace (30_000_000 - maxFee))], @@ -149,7 +155,7 @@ noBalanceMaxFee = do txSkelSignatories = txSkelSignatoriesFromList [alice] } -balanceReduceFee :: (MonadBlockChain m) => m (Integer, Integer, Integer, Integer) +balanceReduceFee :: FullMockChain (Integer, Integer, Integer, Integer) balanceReduceFee = do let skelAutoFee = txSkelTemplate @@ -169,9 +175,9 @@ balanceReduceFee = do feeBalancedManual' <- estimateTxSkelFee skelBalancedManual feeBalancedManual mColsManual return (feeBalanced, feeBalanced', feeBalancedManual, feeBalancedManual') -reachingMagic :: (MonadBlockChain m) => m () +reachingMagic :: FullMockChain () reachingMagic = do - bananaOutRefs <- (fst <$>) <$> runUtxoSearch (utxosOwnedBySearch alice `filterWithValuePred` (banana 1 `Api.leq`)) + bananaOutRefs <- getTxOutRefs $ utxosAtSearch alice $ ensureAFoldIs (txSkelOutValueL % filtered (banana 1 `Api.leq`)) validateTxSkel_ $ txSkelTemplate { txSkelOuts = [bob `receives` Value (Script.ada 106 <> banana 12)], @@ -185,22 +191,22 @@ reachingMagic = do type ResProp = TestBalancingOutcome -> Assertion hasFee :: Integer -> ResProp -hasFee fee (_, _, fee', _, _) = testBool $ fee == fee' +hasFee fee (_, _, fee', _, _) = testBoolMsg "hasFee" $ fee == fee' additionalOutsNb :: Int -> ResProp -additionalOutsNb ao (txSkel1, txSkel2, _, _, _) = testBool $ length (txSkelOuts txSkel2) - length (txSkelOuts txSkel1) == ao +additionalOutsNb ao (txSkel1, txSkel2, _, _, _) = testBoolMsg "AdditionalOutsNb" $ length (txSkelOuts txSkel2) - length (txSkelOuts txSkel1) == ao insNb :: Int -> ResProp -insNb n (_, TxSkel {..}, _, _, _) = testBool $ length txSkelIns == n +insNb n (_, TxSkel {..}, _, _, _) = testBoolMsg "insNb" $ length txSkelIns == n colInsNb :: Int -> ResProp -colInsNb cis (_, _, _, Nothing, _) = testBool $ cis == 0 -colInsNb cis (_, _, _, Just (refs, _), _) = testBool $ cis == length refs +colInsNb cis (_, _, _, Nothing, _) = testBoolMsg "colInsNb" $ cis == 0 +colInsNb cis (_, _, _, Just (refs, _), _) = testBoolMsg "colInsNb" $ cis == length refs retOutsNb :: Int -> ResProp -retOutsNb ros (_, _, _, _, refs) = testBool $ ros == length refs +retOutsNb ros (_, _, _, _, refs) = testBoolMsg "retOutsNb" $ ros == length refs -testBalancingSucceedsWith :: String -> [ResProp] -> StagedMockChain TestBalancingOutcome -> TestTree +testBalancingSucceedsWith :: String -> [ResProp] -> FullMockChain TestBalancingOutcome -> TestTree testBalancingSucceedsWith msg props run = testCooked msg $ mustSucceedTest run @@ -239,7 +245,7 @@ failsLackOfCollateralWallet :: MockChainError -> Assertion failsLackOfCollateralWallet (MCEMissingBalancingUser msg) = "Collateral utxos should be taken from the balancing user, but it does not exist." .==. msg failsLackOfCollateralWallet _ = testBool False -testBalancingFailsWith :: (Show a) => String -> (MockChainError -> Assertion) -> StagedMockChain a -> TestTree +testBalancingFailsWith :: (Show a) => String -> (MockChainError -> Assertion) -> FullMockChain a -> TestTree testBalancingFailsWith msg p smc = testCooked msg $ mustFailTest smc @@ -451,7 +457,7 @@ tests = ( testingBalancingTemplate (Script.ada 142) mempty - (utxosOwnedBySearch alice) + ((fst <$>) <$> utxosAt alice) emptySearch (aliceNAdaUtxos 1) True @@ -635,7 +641,7 @@ tests = (apple 2 <> orange 5 <> banana 4) mempty emptySearch - (utxosOwnedBySearch alice) + ((fst <$>) <$> utxosAt alice) emptySearch False (setFixedFee 1_000_000) @@ -647,7 +653,7 @@ tests = ( testingBalancingTemplate mempty mempty - (onlyValueOutputsAtSearch alice) + (getTxOutRefs $ utxosAtSearch alice ensureOnlyValueOutputs) emptySearch emptySearch False diff --git a/tests/Spec/BasicUsage.hs b/tests/Spec/BasicUsage.hs index f24e4fa1d..7baaa5fe4 100644 --- a/tests/Spec/BasicUsage.hs +++ b/tests/Spec/BasicUsage.hs @@ -12,7 +12,7 @@ alice = wallet 1 bob = wallet 2 carrie = wallet 3 -pkToPk :: (MonadBlockChain m) => Wallet -> Wallet -> Integer -> m () +pkToPk :: Wallet -> Wallet -> Integer -> StagedMockChain () pkToPk sender recipient amount = validateTxSkel_ $ txSkelTemplate @@ -20,14 +20,14 @@ pkToPk sender recipient amount = txSkelSignatories = txSkelSignatoriesFromList [sender] } -multiplePksToPks :: (MonadBlockChain m) => m () +multiplePksToPks :: StagedMockChain () multiplePksToPks = do pkToPk alice bob 10 pkToPk bob carrie 10 pkToPk carrie alice 10 -mintingQuickValue :: (MonadBlockChain m) => m () +mintingQuickValue :: StagedMockChain () mintingQuickValue = validateTxSkel_ txSkelTemplate @@ -36,9 +36,9 @@ mintingQuickValue = txSkelSignatories = txSkelSignatoriesFromList [alice] } -payToAlwaysTrueValidator :: (MonadBlockChain m) => m Api.TxOutRef +payToAlwaysTrueValidator :: StagedMockChain Api.TxOutRef payToAlwaysTrueValidator = - head + fst . head <$> ( validateTxSkel' $ txSkelTemplate { txSkelOuts = [Script.trueSpendingMPScript @() `receives` Value (Script.ada 10)], @@ -46,7 +46,7 @@ payToAlwaysTrueValidator = } ) -consumeAlwaysTrueValidator :: (MonadBlockChain m) => m () +consumeAlwaysTrueValidator :: StagedMockChain () consumeAlwaysTrueValidator = do outref <- payToAlwaysTrueValidator validateTxSkel_ $ diff --git a/tests/Spec/Certificates.hs b/tests/Spec/Certificates.hs index 2eb2eb278..1f932e631 100644 --- a/tests/Spec/Certificates.hs +++ b/tests/Spec/Certificates.hs @@ -12,7 +12,7 @@ alice = wallet 1 bob :: Wallet bob = wallet 1 -publishCertificate :: (MonadModalBlockChain m) => TxSkelCertificate -> m () +publishCertificate :: TxSkelCertificate -> DirectMockChain () publishCertificate cert = validateTxSkel_ $ txSkelTemplate @@ -20,7 +20,7 @@ publishCertificate cert = txSkelCertificates = [cert] } -withdraw :: (MonadBlockChain m) => User IsEither Redemption -> m () +withdraw :: User IsEither Redemption -> DirectMockChain () withdraw user = validateTxSkel_ $ txSkelTemplate diff --git a/tests/Spec/InitialDistribution.hs b/tests/Spec/InitialDistribution.hs index cb0426a7d..c98448697 100644 --- a/tests/Spec/InitialDistribution.hs +++ b/tests/Spec/InitialDistribution.hs @@ -2,7 +2,6 @@ module Spec.InitialDistribution where import Cooked import Data.Map qualified as Map -import Data.Maybe (catMaybes) import Optics.Core import Plutus.Script.Utils.V3 qualified as Script import Test.Tasty @@ -25,15 +24,14 @@ initialDistributionWithReferenceScript = (alice `receives` Value (Script.ada 2) <&&> ReferenceScript (Script.trueSpendingMPScript @())) : replicate 2 (bob `receives` Value (Script.ada 100)) -getValueFromInitialDatum :: (MonadBlockChain m) => m [Integer] +getValueFromInitialDatum :: DirectMockChain [Integer] getValueFromInitialDatum = do - aliceUtxos <- runUtxoSearch $ utxosOwnedBySearch alice - catMaybes <$> mapM (previewByRef (txSkelOutDatumL % txSkelOutDatumTypedAT @Integer) . fst) aliceUtxos + fmap hHead <$> getExtracts (utxosAtSearch alice (extractAFold (txSkelOutDatumL % txSkelOutDatumTypedAT @Integer))) -spendReferenceAlwaysTrueValidator :: (MonadBlockChain m) => m () +spendReferenceAlwaysTrueValidator :: DirectMockChain () spendReferenceAlwaysTrueValidator = do - [(referenceScriptTxOutRef, _)] <- runUtxoSearch $ utxosOwnedBySearch alice - (scriptTxOutRef : _) <- + [(referenceScriptTxOutRef, _)] <- utxosAt alice + ((scriptTxOutRef, _) : _) <- validateTxSkel' $ txSkelTemplate { txSkelOuts = [Script.trueSpendingMPScript @() `receives` Value (Script.ada 2)], diff --git a/tests/Spec/InlineDatums.hs b/tests/Spec/InlineDatums.hs index 91ad48e62..16914e5da 100644 --- a/tests/Spec/InlineDatums.hs +++ b/tests/Spec/InlineDatums.hs @@ -19,13 +19,12 @@ instance PrettyCooked SimpleContractDatum where -- pay a script with an inline datum, while @listUtxosTestTrace False@ will use -- a datum hash. listUtxosTestTrace :: - (MonadBlockChain m) => Bool -> Script.Versioned Script.Validator -> - m (Api.TxOutRef, TxSkelOut) + DirectMockChain (Api.TxOutRef, TxSkelOut) listUtxosTestTrace useInlineDatum validator = - (\oref -> (oref,) <$> txSkelOutByRef oref) . head - =<< validateTxSkel' + head + <$> validateTxSkel' txSkelTemplate { txSkelOuts = [validator `receives` (if useInlineDatum then InlineDatum else VisibleHashedDatum) FirstPaymentDatum], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -39,10 +38,9 @@ listUtxosTestTrace useInlineDatum validator = -- This is used to test whether a validator will correctly see the -- _input data_ of a transaction as inline datums or datum hashes. spendOutputTestTrace :: - (MonadBlockChain m) => Bool -> Script.Versioned Script.Validator -> - m () + DirectMockChain () spendOutputTestTrace useInlineDatum validator = do (theTxOutRef, _) <- listUtxosTestTrace useInlineDatum validator validateTxSkel_ @@ -62,10 +60,9 @@ spendOutputTestTrace useInlineDatum validator = do -- This is used to test whether a validator will correctly see the _output data_ -- of atransaction as inline datums or datum hashes. continuingOutputTestTrace :: - (MonadBlockChain m) => OutputDatumKind -> Script.Versioned Script.Validator -> - m () + DirectMockChain () continuingOutputTestTrace datumKindOnSecondPayment validator = do (theTxOutRef, theOutput) <- listUtxosTestTrace True validator validateTxSkel_ diff --git a/tests/Spec/Ltl.hs b/tests/Spec/Ltl.hs index 486fd34d1..7aa73b9b6 100644 --- a/tests/Spec/Ltl.hs +++ b/tests/Spec/Ltl.hs @@ -1,16 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + module Spec.Ltl where -import Control.Monad -import Control.Monad.Writer +import Control.Monad (MonadPlus (..), guard, replicateM, void) import Cooked.Ltl import Cooked.MockChain.Testing import Data.Maybe +import Polysemy +import Polysemy.NonDet +import Polysemy.State +import Polysemy.Writer import Test.Tasty import Test.Tasty.HUnit -data TestBuiltin a where - EmitInteger :: Integer -> TestBuiltin () - GetInteger :: TestBuiltin Integer +data TestBuiltin :: Effect where + EmitInteger :: Integer -> TestBuiltin m () + GetInteger :: TestBuiltin m Integer + +makeSem ''TestBuiltin data TestModification = Add Integer @@ -23,11 +30,14 @@ applyMod _ Fail = Nothing applyMod i (Add i') = if i == i' then Nothing else Just $ i + i' applyMod i (Mul i') = if i == i' then Nothing else Just $ i * i' -type TestStaged = StagedLtl TestModification TestBuiltin - -instance (MonadPlus m, MonadWriter [Integer] m) => ModInterpBuiltin TestModification TestBuiltin m where - modifyAndInterpBuiltin GetInteger = Left (return 42) - modifyAndInterpBuiltin (EmitInteger i) = Right $ \now -> +runTestEffect :: + (Members '[Writer [Integer], ModifyLocally TestModification, NonDet] effs) => + Sem (TestBuiltin : effs) a -> + Sem effs a +runTestEffect = interpret $ \case + GetInteger -> return 42 + EmitInteger i -> do + now <- getRequirements maybe mzero (tell . (: [])) $ foldl ( \acc el -> do @@ -41,14 +51,27 @@ instance (MonadPlus m, MonadWriter [Integer] m) => ModInterpBuiltin TestModifica (Just i) now -emitInteger :: Integer -> TestStaged () -emitInteger = singletonBuiltin . EmitInteger - -getInteger :: TestStaged Integer -getInteger = singletonBuiltin GetInteger +type TestStaged a = + Sem + '[ ModifyGlobally TestModification, + TestBuiltin, + Writer [Integer], + ModifyLocally TestModification, + State [Ltl TestModification], + NonDet + ] + a go :: TestStaged a -> [[Integer]] -go = execWriterT . interpStagedLtl +go = + run + . runNonDet + . evalState [] + . runModifyLocally + . fmap fst + . runWriter + . runTestEffect + . runModifyGlobally nonemptyTraces :: [TestStaged ()] nonemptyTraces = diff --git a/tests/Spec/MinAda.hs b/tests/Spec/MinAda.hs index f269c91d4..0593ea407 100644 --- a/tests/Spec/MinAda.hs +++ b/tests/Spec/MinAda.hs @@ -21,17 +21,16 @@ heavyDatum = HeavyDatum (take 100 [0 ..]) instance PrettyCooked HeavyDatum where prettyCookedOpt opts (HeavyDatum ints) = prettyItemizeNoTitle opts "-" ints -paymentWithMinAda :: (MonadBlockChain m) => m Integer +paymentWithMinAda :: DirectMockChain Integer paymentWithMinAda = do - tx <- - validateTxSkel + view (txSkelOutValueL % valueLovelaceL % lovelaceIntegerI) . snd . (!! 0) + <$> validateTxSkel' txSkelTemplate { txSkelOuts = [wallet 2 `receives` VisibleHashedDatum heavyDatum], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } - view (txSkelOutValueL % valueLovelaceL % lovelaceIntegerI) . snd . (!! 0) <$> utxosFromCardanoTx tx -paymentWithoutMinAda :: (MonadBlockChain m) => Integer -> m () +paymentWithoutMinAda :: Integer -> DirectMockChain () paymentWithoutMinAda paidLovelaces = do validateTxSkel_ txSkelTemplate diff --git a/tests/Spec/MultiPurpose.hs b/tests/Spec/MultiPurpose.hs index 0c69c7af1..61a32d3b5 100644 --- a/tests/Spec/MultiPurpose.hs +++ b/tests/Spec/MultiPurpose.hs @@ -22,9 +22,9 @@ alice, bob :: Wallet alice = wallet 1 bob = wallet 2 -runScript :: (MonadModalBlockChain m) => m () +runScript :: StagedMockChain () runScript = do - [oRef@(Api.TxOutRef txId _), oRef', oRef''] <- + [(oRef@(Api.TxOutRef txId _), _), (oRef', _), (oRef'', _)] <- validateTxSkel' $ txSkelTemplate { txSkelOuts = @@ -39,11 +39,11 @@ runScript = do (mintSkel2, mintValue2, tn2) = mkMintSkel alice oRef' script (mintSkel3, mintValue3, tn3) = mkMintSkel bob oRef'' script - (oRefScript : _) <- validateTxSkel' mintSkel1 - (oRefScript1 : _) <- validateTxSkel' mintSkel2 - (oRefScript2 : _) <- validateTxSkel' mintSkel3 + ((oRefScript, _) : _) <- validateTxSkel' mintSkel1 + ((oRefScript1, _) : _) <- validateTxSkel' mintSkel2 + ((oRefScript2, _) : _) <- validateTxSkel' mintSkel3 - (oRefScript1' : oRefScript2' : _) <- + ((oRefScript1', _) : (oRefScript2', _) : _) <- validateTxSkel' $ txSkelTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], @@ -60,7 +60,7 @@ runScript = do txSkelMints = review txSkelMintsListI [burn script BurnToken tn1 1] } - (oRefScript2'' : _) <- + ((oRefScript2'', _) : _) <- validateTxSkel' $ txSkelTemplate { txSkelSignatories = txSkelSignatoriesFromList [bob], diff --git a/tests/Spec/ProposingScript.hs b/tests/Spec/ProposingScript.hs index 16be65b92..ce83ece0e 100644 --- a/tests/Spec/ProposingScript.hs +++ b/tests/Spec/ProposingScript.hs @@ -9,7 +9,6 @@ alice :: Wallet alice = wallet 1 testProposingScript :: - (MonadBlockChain m) => -- | Whether or not to automatically fetch a reference script Bool -> -- | Whether or not to automatically attach the constitution @@ -20,7 +19,7 @@ testProposingScript :: Maybe VScript -> -- | The governance action to propose GovernanceAction IsScript -> - m () + DirectMockChain () testProposingScript autoRefScript autoConstitution constitution mScript govAction = do setConstitutionScript constitution validateTxSkel_ $ @@ -69,37 +68,37 @@ tests = mustFailTest (testProposingScript False False checkProposingScript (Just alwaysTrueProposingValidator) (ParameterChange [FeePerByte 100])) `withFailureProp` isPhase1FailureWithMsg "InvalidPolicyHash" - `withJournalProp` didNotHappen "MCLogAutoFilledConstitution", + `withLogProp` didNotHappen "MCLogAutoFilledConstitution", testCooked "Success when executing the right constitution script" $ mustSucceedTest (testProposingScript False False alwaysTrueProposingValidator (Just alwaysTrueProposingValidator) (ParameterChange [FeePerByte 100])) - `withJournalProp` didNotHappen "MCLogAutoFilledConstitution", + `withLogProp` didNotHappen "MCLogAutoFilledConstitution", testCooked "Success when executing a more complex constitution script" $ mustSucceedTest (testProposingScript False False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 100])) - `withJournalProp` didNotHappen "MCLogAutoFilledConstitution", + `withLogProp` didNotHappen "MCLogAutoFilledConstitution", testCooked "Failure when executing a more complex constitution script with the wrong proposal" $ mustFailInPhase2Test (testProposingScript False False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 50])) - `withJournalProp` didNotHappen "MCLogAutoFilledConstitution", + `withLogProp` didNotHappen "MCLogAutoFilledConstitution", testCooked "Success when executing a more complex constitution script as a reference script" $ mustSucceedTest (testProposingScript True False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 100])) - `withJournalProp` happened "MCLogAddedReferenceScript" - `withJournalProp` didNotHappen "MCLogAutoFilledConstitution" + `withLogProp` happened "MCLogAddedReferenceScript" + `withLogProp` didNotHappen "MCLogAutoFilledConstitution" ], testGroup "Automated constitution attachment" [ testCooked "Success when auto assigning the constitution script" $ mustSucceedTest (testProposingScript False True checkProposingScript Nothing (ParameterChange [FeePerByte 100])) - `withJournalProp` happened "MCLogAutoFilledConstitution", + `withLogProp` happened "MCLogAutoFilledConstitution", testCooked "Success when auto assigning the constitution script and using it as a reference script" $ mustSucceedTest (testProposingScript True True checkProposingScript Nothing (ParameterChange [FeePerByte 100])) - `withJournalProp` happened "MCLogAddedReferenceScript" - `withJournalProp` happened "MCLogAutoFilledConstitution", + `withLogProp` happened "MCLogAddedReferenceScript" + `withLogProp` happened "MCLogAutoFilledConstitution", testCooked "Success when auto assigning the constitution script while overriding an existing one" $ mustSucceedTest (testProposingScript False True checkProposingScript (Just alwaysFalseProposingValidator) (ParameterChange [FeePerByte 100])) - `withJournalProp` happened "MCLogAutoFilledConstitution" + `withLogProp` happened "MCLogAutoFilledConstitution" ] ] diff --git a/tests/Spec/ReferenceInputs.hs b/tests/Spec/ReferenceInputs.hs index e9a618394..c4b144cc4 100644 --- a/tests/Spec/ReferenceInputs.hs +++ b/tests/Spec/ReferenceInputs.hs @@ -13,9 +13,9 @@ import Test.Tasty qualified as Tasty instance PrettyCooked FooDatum where prettyCookedOpt opts (FooDatum pkh) = "FooDatum" PP.<+> prettyHash opts pkh -trace1 :: (MonadBlockChain m) => m () +trace1 :: DirectMockChain () trace1 = do - txOutRefFoo : txOutRefBar : _ <- + (txOutRefFoo, _) : (txOutRefBar, _) : _ <- validateTxSkel' txSkelTemplate { txSkelOuts = @@ -32,9 +32,9 @@ trace1 = do txSkelSignatories = txSkelSignatoriesFromList [wallet 3] } -trace2 :: (MonadBlockChain m) => m () +trace2 :: DirectMockChain () trace2 = do - refORef : scriptORef : _ <- + (refORef, _) : (scriptORef, _) : _ <- validateTxSkel' ( txSkelTemplate { txSkelOuts = diff --git a/tests/Spec/ReferenceScripts.hs b/tests/Spec/ReferenceScripts.hs index 7b06199f2..c5d477714 100644 --- a/tests/Spec/ReferenceScripts.hs +++ b/tests/Spec/ReferenceScripts.hs @@ -14,12 +14,11 @@ import PlutusLedgerApi.V3 qualified as V3 import Test.Tasty putRefScriptOnWalletOutput :: - (MonadBlockChain m) => Wallet -> Script.Versioned Script.Validator -> - m V3.TxOutRef + DirectMockChain V3.TxOutRef putRefScriptOnWalletOutput recipient referenceScript = - head + fst . head <$> validateTxSkel' txSkelTemplate { txSkelOuts = [recipient `receives` ReferenceScript referenceScript], @@ -27,12 +26,11 @@ putRefScriptOnWalletOutput recipient referenceScript = } putRefScriptOnScriptOutput :: - (MonadBlockChain m) => Script.Versioned Script.Validator -> Script.Versioned Script.Validator -> - m V3.TxOutRef + DirectMockChain V3.TxOutRef putRefScriptOnScriptOutput recipient referenceScript = - head + fst . head <$> validateTxSkel' txSkelTemplate { txSkelOuts = [recipient `receives` ReferenceScript referenceScript], @@ -40,12 +38,11 @@ putRefScriptOnScriptOutput recipient referenceScript = } checkReferenceScriptOnOref :: - (MonadBlockChain m) => Api.ScriptHash -> V3.TxOutRef -> - m () + DirectMockChain () checkReferenceScriptOnOref expectedScriptHash refScriptOref = do - oref : _ <- + (oref, _) : _ <- validateTxSkel' txSkelTemplate { txSkelOuts = [requireRefScriptValidator expectedScriptHash `receives` Value (Script.ada 42)], @@ -62,28 +59,29 @@ checkReferenceScriptOnOref expectedScriptHash refScriptOref = do -- should be consumed in the transaction or not. If it should, then at -- transaction generation no reference input should appear, as inputs also act -- as reference inputs. -useReferenceScript :: (MonadBlockChain m) => Wallet -> Bool -> Script.Versioned Script.Validator -> m Ledger.CardanoTx +useReferenceScript :: Wallet -> Bool -> Script.Versioned Script.Validator -> DirectMockChain Ledger.CardanoTx useReferenceScript spendingSubmitter consumeScriptOref theScript = do scriptOref <- putRefScriptOnWalletOutput (wallet 3) theScript - oref : _ <- + (oref, _) : _ <- validateTxSkel' txSkelTemplate { txSkelOuts = [theScript `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } - validateTxSkel - txSkelTemplate - { txSkelIns = - Map.fromList $ - (oref, TxSkelRedeemer () (Just scriptOref) False) - : [(scriptOref, emptyTxSkelRedeemer) | consumeScriptOref], - txSkelSignatories = txSkelSignatoriesFromList $ spendingSubmitter : [wallet 3 | consumeScriptOref] - } + fst + <$> validateTxSkel + txSkelTemplate + { txSkelIns = + Map.fromList $ + (oref, TxSkelRedeemer () (Just scriptOref) False) + : [(scriptOref, emptyTxSkelRedeemer) | consumeScriptOref], + txSkelSignatories = txSkelSignatoriesFromList $ spendingSubmitter : [wallet 3 | consumeScriptOref] + } -useReferenceScriptInInputs :: (MonadBlockChain m) => Wallet -> Script.Versioned Script.Validator -> m () +useReferenceScriptInInputs :: Wallet -> Script.Versioned Script.Validator -> DirectMockChain () useReferenceScriptInInputs spendingSubmitter theScript = do scriptOref <- putRefScriptOnWalletOutput (wallet 1) theScript - oref : _ <- + (oref, _) : _ <- validateTxSkel' txSkelTemplate { txSkelOuts = [theScript `receives` Value (Script.ada 42)], @@ -95,9 +93,9 @@ useReferenceScriptInInputs spendingSubmitter theScript = do txSkelSignatories = txSkelSignatoriesFromList [spendingSubmitter] } -referenceMint :: (MonadBlockChain m) => Script.Versioned Script.MintingPolicy -> Script.Versioned Script.MintingPolicy -> Int -> Bool -> m () +referenceMint :: Script.Versioned Script.MintingPolicy -> Script.Versioned Script.MintingPolicy -> Int -> Bool -> DirectMockChain () referenceMint mp1 mp2 n autoRefScript = do - ((!! n) -> mpOutRef) <- + ((!! n) -> (mpOutRef, _)) <- validateTxSkel' $ txSkelTemplate { txSkelOuts = @@ -147,14 +145,11 @@ tests = ], testGroup "using reference scripts" - [ testCooked "fail from transaction generation for missing reference scripts" $ + [ testCooked @DirectEffs "fail from transaction generation for missing reference scripts" $ mustFailTest ( do - (consumedOref, _) : _ <- - runUtxoSearch $ - utxosOwnedBySearch (wallet 1) - `filterWithValuePred` (`Api.geq` Script.lovelace 42_000_000) - oref : _ <- + consumedOref : _ <- getTxOutRefs $ utxosAtSearch (wallet 1) $ ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` Script.lovelace 42_000_000)) + (oref, _) : _ <- validateTxSkel' txSkelTemplate { txSkelOuts = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], @@ -174,7 +169,7 @@ tests = mustFailTest ( do scriptOref <- putRefScriptOnWalletOutput (wallet 3) Script.alwaysFailValidatorVersioned - oref : _ <- + (oref, _) : _ <- validateTxSkel' txSkelTemplate { txSkelOuts = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], @@ -192,7 +187,7 @@ tests = testCooked "phase 1 - fail if using a reference script with 'someRedeemer'" $ mustFailInPhase1Test $ do scriptOref <- putRefScriptOnWalletOutput (wallet 3) Script.alwaysSucceedValidatorVersioned - oref : _ <- + (oref, _) : _ <- validateTxSkel' txSkelTemplate { txSkelOuts = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], @@ -244,7 +239,7 @@ tests = referenceMint Script.alwaysSucceedPolicyVersioned Script.alwaysSucceedPolicyVersioned 0 False, testCooked "succeed if relying on automated finding of reference minting policy" $ mustSucceedTest (referenceMint Script.alwaysSucceedPolicyVersioned Script.alwaysSucceedPolicyVersioned 0 True) - `withJournalProp` happened "MCLogAddedReferenceScript", + `withLogProp` happened "MCLogAddedReferenceScript", testCooked "fail if given the wrong reference minting policy" $ mustFailTest (referenceMint Script.alwaysFailPolicyVersioned Script.alwaysSucceedPolicyVersioned 0 False) `withErrorProp` \case diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index 24190593d..9d4445d32 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -1,19 +1,44 @@ module Spec.Slot (tests) where -import Cooked.MockChain.BlockChain -import Cooked.MockChain.Direct +import Cooked.MockChain.Error +import Cooked.MockChain.Read +import Cooked.MockChain.State +import Data.Default import Ledger.Slot qualified as Ledger +import Ledger.Tx qualified as Ledger import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.State import Test.Tasty import Test.Tasty.QuickCheck +runSlot :: + Sem + '[ MockChainRead, + State MockChainState, + Fail, + Error Ledger.ToCardanoError, + Error MockChainError + ] + a -> + Either MockChainError a +runSlot = + run + . runError + . runToCardanoErrorInMockChainError + . runFailInMockChainError + . evalState def + . runMockChainRead + tests :: TestTree tests = testGroup "time handling" [ testProperty "bounds computed by slotToMSRange are included in slot" $ \n -> - case mcrValue $ runMockChain $ do + case runSlot $ do (l, r) <- slotToMSRange $ Ledger.Slot n Ledger.Slot nl <- getEnclosingSlot l Ledger.Slot nr <- getEnclosingSlot r @@ -22,7 +47,7 @@ tests = Right (nl, nr) -> nl == n && nr == n, testProperty "bounds computed by slotToMSRange are maximal" $ \n -> - case mcrValue $ runMockChain $ do + case runSlot $ do (l, r) <- slotToMSRange $ Ledger.Slot n Ledger.Slot nl <- getEnclosingSlot (l - 1) Ledger.Slot nr <- getEnclosingSlot (r + 1) @@ -30,7 +55,7 @@ tests = Left _err -> False Right (nl, nr) -> nl == n - 1 && nr == n + 1, testProperty "time is always included in enclosing slot" $ - \t -> case mcrValue $ runMockChain $ slotToMSRange =<< getEnclosingSlot (Api.POSIXTime t) of + \t -> case runSlot $ slotToMSRange =<< getEnclosingSlot (Api.POSIXTime t) of Left _err -> False Right (Api.POSIXTime a, Api.POSIXTime b) -> a <= t && a <= b ] diff --git a/tests/Spec/StagedRun.hs b/tests/Spec/StagedRun.hs new file mode 100644 index 000000000..c9568c41c --- /dev/null +++ b/tests/Spec/StagedRun.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Spec.StagedRun where + +import Control.Monad +import Cooked +import Optics.Core +import Plutus.Script.Utils.V3.Generators +import Plutus.Script.Utils.Value +import PlutusLedgerApi.V3 qualified as Api +import Polysemy.Bundle +import Polysemy.State +import Test.Tasty (TestTree) + +instance Interpret (Bundle '[State Integer]) where + runInterpret = evalState 0 . runBundle + +stagedRun :: StagedInjectMockChain (Bundle '[State Integer]) Integer +stagedRun = do + -- Defining some aliases for wallets + alice <- define "alice" $ wallet 1 + bob <- define "bob" $ wallet 2 + carrie <- define "carrie" $ wallet 3 + -- Defining some aliases for scripts + trueScript <- define "trueScript" $ trueMPScript @() + falseScript <- define "falseScript" $ falseMPScript @() + -- Defining some aliases for tokens + permanent <- define "permanent" $ Api.TokenName "permanent" + quick <- define "quick" $ Api.TokenName "quick" + -- Some values + let permanentValue = Value . review (valueAssetClassAmountP falseScript permanent) + quickValue = Value . review (valueAssetClassAmountP trueScript quick) + -- Providing an initial distribution of funds + outputs <- + forceOutputs $ + replicate 4 (bob `receives` Value (ada 10)) + ++ replicate 4 (carrie `receives` Value (ada 10)) + ++ replicate 4 (alice `receives` Value (ada 10)) + ++ [ alice `receives` permanentValue 3 <&&> InlineDatum (3 :: Integer), + alice `receives` permanentValue 5 <&&> HiddenHashedDatum (15 :: Integer), + alice `receives` quickValue 4, + alice `receives` quickValue 10 <&&> VisibleHashedDatum (25 :: Integer), + alice `receives` permanentValue 12 <&&> VisibleHashedDatum (10 :: Integer), + alice `receives` InlineDatum (20 :: Integer) + ] + noteS "We have given a few assets to Alice, Bob and Carry to begin the run" + -- Ensuring that "Alice" got 10 utxos out of the "forceOutputs" call + aliceUtxos <- + beginSearch (return outputs) + & ensureAFoldIs (txSkelOutOwnerL % userEitherPubKeyP % userTypedPubKeyAT @Wallet % filtered (== alice)) + assert' $ length aliceUtxos == 10 + forM_ (zip [(1 :: Integer) ..] aliceUtxos) $ \(i, (_, output)) -> noteL ("Alice UTxO number " <> show i) output + -- Ensuring that Alice has 2 utxos with quick values with the right amount + aliceQuickValueExtracts <- + getExtracts $ + beginSearch (return outputs) + & ensureAFoldIs (txSkelOutOwnerL % userEitherPubKeyP % userTypedPubKeyAT @Wallet % filtered (== alice)) + . extractAFold (txSkelOutValueL % valueAssetClassAmountP trueScript quick) + assert' $ aliceQuickValueExtracts == ((`HCons` HEmpty) <$> [4, 10]) + -- Ensuring that Alice has 2 utxos created with hashed datums with permanent + -- values, and retrieving the typed content of those datums. + aliceHashedDatums <- + getExtracts $ + beginSearch (return outputs) + & ensureAFoldIs (txSkelOutOwnerL % userEitherPubKeyP % userTypedPubKeyAT @Wallet % filtered (== alice)) + . extractAFold (txSkelOutValueL % valueAssetClassAmountP falseScript permanent) + . extractAFold (txSkelOutDatumL % txSkelOutDatumKindAT % datumKindResolvedP) + . extractAFold (txSkelOutDatumL % txSkelOutDatumTypedAT @Integer) + assert' $ + aliceHashedDatums + == [ HCons 5 (HCons NotResolved (HCons 15 HEmpty)), + HCons 12 (HCons Resolved (HCons 10 HEmpty)) + ] + mplus (sendBundle $ put 10) (sendBundle $ put 20) + sendBundle get + +tests :: TestTree +tests = testCooked "Full staged run" $ mustSucceedTest stagedRun `withInitDist` InitialDistribution [] diff --git a/tests/Spec/Tweak/Common.hs b/tests/Spec/Tweak/Common.hs index a1f8e26bd..d6c21ef0e 100644 --- a/tests/Spec/Tweak/Common.hs +++ b/tests/Spec/Tweak/Common.hs @@ -5,6 +5,8 @@ import Data.List (subsequences) import Optics.Core import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V1.Value qualified as Api +import Polysemy +import Polysemy.NonDet import Test.Tasty import Test.Tasty.HUnit @@ -20,44 +22,45 @@ tests = "building blocks for tweaks" [ testGroup "overMaybeSelectingTweak" $ let skel = mkSkel [123, 234, 345] - in [ testCase "return empty list and don't change anything if no applicable modifications" $ -- this one is a regression test - [Right ([], skel)] - @=? mcrValue - <$> runTweak - ( overMaybeSelectingTweak - (txSkelOutsL % traversed % txSkelOutValueL) - (const Nothing) - (const True) - ) - skel, + in [ testCase "return empty list and don't change anything if no applicable modifications" $ -- this one is a regression test -- this one is a regression test + -- this one is a regression test + [skel] + @=? run + ( runNonDet $ + execTweak skel $ + overMaybeSelectingTweak + (txSkelOutsL % traversed % txSkelOutValueL) + (const Nothing) + (const True) + ), testCase "select applied modification by index" $ - [Right ([Script.lovelace 345], mkSkel [123, 234, 789])] - @=? mcrValue - <$> runTweak - ( overMaybeSelectingTweak - (txSkelOutsL % traversed % txSkelOutValueL) - ( \value -> - if value `Api.geq` Script.lovelace 200 - then Just $ Script.lovelace 789 - else Nothing - ) - (== 1) - ) - skel, + [(mkSkel [123, 234, 789], [Script.lovelace 345])] + @=? run + ( runNonDet $ + runTweak skel $ + overMaybeSelectingTweak + (txSkelOutsL % traversed % txSkelOutValueL) + ( \value -> + if value `Api.geq` Script.lovelace 200 + then Just $ Script.lovelace 789 + else Nothing + ) + (== 1) + ), testCase "return unmodified foci in the right order" $ - [Right ([Script.lovelace 123, Script.lovelace 345], mkSkel [789, 234, 789])] - @=? mcrValue - <$> runTweak - ( overMaybeSelectingTweak - (txSkelOutsL % traversed % txSkelOutValueL) - (const $ Just $ Script.lovelace 789) - (`elem` [0, 2]) - ) - skel + [(mkSkel [789, 234, 789], [Script.lovelace 123, Script.lovelace 345])] + @=? run + ( runNonDet $ + runTweak skel $ + overMaybeSelectingTweak + (txSkelOutsL % traversed % txSkelOutValueL) + (const $ Just $ Script.lovelace 789) + (`elem` [0, 2]) + ) ], testGroup "combineModsTweak" $ let skelIn = mkSkel [0, 0, 0] - skelOut x y z = Right ([0 | x /= 0] ++ [1 | y /= 0] ++ [2 | z /= 0], mkSkel [x, y, z]) + skelOut x y z = (mkSkel [x, y, z], [0 | x /= 0] ++ [1 | y /= 0] ++ [2 | z /= 0]) in [ testCase "all combinations of modifications" $ assertSameSets [ -- one changed focus @@ -90,14 +93,13 @@ tests = skelOut 2 2 1, skelOut 2 2 2 ] - ( mcrValue - <$> runTweak - ( combineModsTweak + ( run $ + runNonDet $ + runTweak skelIn $ + combineModsTweak (tail . subsequences) (txSkelOutsL % itraversed % txSkelOutValueL % valueLovelaceL) (\i x -> return [(x + 1, i), (x + 2, i)]) - ) - skelIn ), testCase "separate modifications" $ assertSameSets @@ -109,14 +111,13 @@ tests = skelOut 0 0 1, skelOut 0 0 2 ] - ( mcrValue - <$> runTweak - ( combineModsTweak + ( run $ + runNonDet $ + runTweak skelIn $ + combineModsTweak (map (: [])) (txSkelOutsL % itraversed % txSkelOutValueL % valueLovelaceL) (\i x -> return [(x + 1, i), (x + 2, i)]) - ) - skelIn ) ] ] diff --git a/tests/Spec/Tweak/Labels.hs b/tests/Spec/Tweak/Labels.hs index 8c2190acd..d23ed366c 100644 --- a/tests/Spec/Tweak/Labels.hs +++ b/tests/Spec/Tweak/Labels.hs @@ -14,7 +14,7 @@ alice = wallet 1 bob = wallet 2 carrie = wallet 3 -payTo :: (MonadBlockChain m) => Wallet -> Integer -> m () +payTo :: Wallet -> Integer -> StagedMockChain () payTo target amount = do validateTxSkel_ $ txSkelTemplate @@ -22,7 +22,7 @@ payTo target amount = do txSkelOuts = [target `receives` Value (Script.ada amount)] } -payments :: (MonadBlockChain m) => m () +payments :: StagedMockChain () payments = do payTo alice 10 payTo bob 5 @@ -30,12 +30,12 @@ payments = do payTo alice 25 payTo alice 32 -labelAmountTweak :: (MonadTweak m) => m () +labelAmountTweak :: StagedTweak () labelAmountTweak = do [target] <- viewAllTweak (txSkelOutsL % _head % txSkelOutValueL % valueLovelaceL) addLabelTweak $ Api.getLovelace target -labelNameTweak :: (MonadTweak m) => m () +labelNameTweak :: StagedTweak () labelNameTweak = do target <- viewAllTweak @@ -50,7 +50,7 @@ labelNameTweak = do [t] | t == bob -> addLabelTweak @Text "Bob" _ -> mzero -labelNames :: (MonadModalBlockChain m) => m () +labelNames :: StagedMockChain () labelNames = everywhere labelNameTweak payments tests :: TestTree @@ -80,7 +80,7 @@ tests = $ mustSucceedTest $ everywhere ( do - txSkelLabels <- viewAllTweak $ txSkelLabelL % to Set.toList % traversed % txSkelLabelTypedP @Text + txSkelLabels <- viewAllTweak $ txSkelLabelsL % to Set.toList % traversed % txSkelLabelTypedP @Text guard $ not $ null txSkelLabels labelAmountTweak ) diff --git a/tests/Spec/Tweak/OutPermutations.hs b/tests/Spec/Tweak/OutPermutations.hs index f215eb5df..935192510 100644 --- a/tests/Spec/Tweak/OutPermutations.hs +++ b/tests/Spec/Tweak/OutPermutations.hs @@ -1,10 +1,10 @@ module Spec.Tweak.OutPermutations (tests) where import Cooked -import Cooked.Tweak.OutPermutations -import Data.Either (rights) import Data.List (group) import Plutus.Script.Utils.Value qualified as Script +import Polysemy +import Polysemy.NonDet import Test.Tasty import Test.Tasty.HUnit @@ -66,24 +66,24 @@ tests = skel x y z = txSkelTemplate {txSkelOuts = [x, y, z]} in [ testCase "KeepIdentity (Just 2)" $ assertSameSets - (map (Right . ((),)) [skel a b c, skel b a c]) - (mcrValue <$> runTweak (allOutPermutsTweak $ KeepIdentity $ Just 2) (skel a b c)), + [skel a b c, skel b a c] + (run $ runNonDet $ execTweak (skel a b c) $ allOutPermutsTweak $ KeepIdentity $ Just 2), testCase "KeepIdentity Nothing" $ assertSameSets - (map (Right . ((),)) [skel a b c, skel a c b, skel b a c, skel b c a, skel c a b, skel c b a]) - (mcrValue <$> runTweak (allOutPermutsTweak $ KeepIdentity Nothing) (skel a b c)), + [skel a b c, skel a c b, skel b a c, skel b c a, skel c a b, skel c b a] + (run $ runNonDet $ execTweak (skel a b c) $ allOutPermutsTweak $ KeepIdentity Nothing), testCase "OmitIdentity (Just 2)" $ assertSameSets - [Right ((), skel b a c)] - (mcrValue <$> runTweak (allOutPermutsTweak $ OmitIdentity $ Just 2) (skel a b c)), + [skel b a c] + (run $ runNonDet $ execTweak (skel a b c) $ allOutPermutsTweak $ OmitIdentity $ Just 2), testCase "OmitIdentity Nothing" $ assertSameSets - (map (Right . ((),)) [skel a c b, skel b a c, skel b c a, skel c a b, skel c b a]) - (mcrValue <$> runTweak (allOutPermutsTweak $ OmitIdentity Nothing) (skel a b c)) + [skel a c b, skel b a c, skel b c a, skel c a b, skel c b a] + (run $ runNonDet $ execTweak (skel a b c) $ allOutPermutsTweak $ OmitIdentity Nothing) ], testGroup "tests for a single random outputs permutation:" $ let l = (\i -> wallet i `receives` Value (Script.lovelace 123)) <$> [1 .. 5] - runs = txSkelOuts . snd <$> rights (mcrValue <$> ((\i -> runTweak (singleOutPermutTweak i) txSkelTemplate {txSkelOuts = l}) =<< [1 .. 5])) + runs = txSkelOuts <$> ([1 .. 5] >>= (run . runNonDet . execTweak (txSkelTemplate {txSkelOuts = l}) . singleOutPermutTweak)) in [ testCase "All permutations contain the correct elements" $ mapM_ (assertSameSets l) runs, testCase "All permutations are different from the initial distribution" $ diff --git a/tests/Spec/Tweak/TamperDatum.hs b/tests/Spec/Tweak/TamperDatum.hs index 9ff4770d4..5ea8df4d4 100644 --- a/tests/Spec/Tweak/TamperDatum.hs +++ b/tests/Spec/Tweak/TamperDatum.hs @@ -4,49 +4,45 @@ module Spec.Tweak.TamperDatum where import Cooked -import Data.Either import Data.Set qualified as Set import Optics.Core import Plutus.Script.Utils.Value qualified as Script import PlutusTx qualified -import Prettyprinter (viaShow) +import Polysemy +import Polysemy.NonDet import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@=?)) -instance PrettyCooked (Integer, Integer) where - prettyCookedOpt _ = viaShow - alice :: Wallet alice = wallet 1 tamperDatumTweakTest :: TestTree tamperDatumTweakTest = testCase "tamperDatumTweak" $ - [ Right - ( [(52, 53)], - txSkelTemplate - { txSkelLabel = Set.singleton $ TxSkelLabel TamperDatumLbl, - txSkelOuts = - [ alice `receives` VisibleHashedDatum (52 :: Integer, 54 :: Integer), - alice `receives` Value (Script.lovelace 234), - alice `receives` VisibleHashedDatum (76 :: Integer, 77 :: Integer) - ] - } - ) + [ ( txSkelTemplate + { txSkelLabels = Set.singleton $ TxSkelLabel TamperDatumLbl, + txSkelOuts = + [ alice `receives` VisibleHashedDatum (52 :: Integer, 54 :: Integer), + alice `receives` Value (Script.lovelace 234), + alice `receives` VisibleHashedDatum (76 :: Integer, 77 :: Integer) + ] + }, + [(52, 53)] + ) ] - @=? mcrValue - <$> runTweak - ( tamperDatumTweak @(Integer, Integer) - (\(x, y) -> if y == 77 then Nothing else Just (x, y + 1)) - ) - ( txSkelTemplate + @=? (run . runNonDet) + ( runTweak + txSkelTemplate { txSkelOuts = [ alice `receives` VisibleHashedDatum (52 :: Integer, 53 :: Integer), alice `receives` Value (Script.lovelace 234), alice `receives` VisibleHashedDatum (76 :: Integer, 77 :: Integer) ] } - ) + ( tamperDatumTweak @(Integer, Integer) + (\(x, y) -> if y == 77 then Nothing else Just (x, y + 1)) + ) + ) malformDatumTweakTest :: TestTree malformDatumTweakTest = @@ -70,9 +66,17 @@ malformDatumTweakTest = txSkelWithDatums1And4 (52 :: Integer, 53 :: Integer) (84 :: Integer, ()), -- datum1 untouched, datum4 changed txSkelWithDatums1And4 (52 :: Integer, 53 :: Integer) False -- datum1 untouched, datum4 changed ] - ( fmap (allBuiltinData . snd) . rights $ - mcrValue - <$> runTweak + ( (fmap allBuiltinData . run . runNonDet) + ( execTweak + ( txSkelTemplate + { txSkelOuts = + [ alice `receives` VisibleHashedDatum (52 :: Integer, 53 :: Integer), + alice `receives` Value (Script.lovelace 234), + alice `receives` VisibleHashedDatum (76 :: Integer, 77 :: Integer), + alice `receives` VisibleHashedDatum (84 :: Integer, 85 :: Integer) + ] + } + ) ( malformDatumTweak @(Integer, Integer) ( \(x, y) -> if y == 77 @@ -83,15 +87,7 @@ malformDatumTweakTest = ] ) ) - ( txSkelTemplate - { txSkelOuts = - [ alice `receives` VisibleHashedDatum (52 :: Integer, 53 :: Integer), - alice `receives` Value (Script.lovelace 234), - alice `receives` VisibleHashedDatum (76 :: Integer, 77 :: Integer), - alice `receives` VisibleHashedDatum (84 :: Integer, 85 :: Integer) - ] - } - ) + ) ) tests :: TestTree diff --git a/tests/Spec/Tweak/ValidityRange.hs b/tests/Spec/Tweak/ValidityRange.hs index 8378fb196..a77a4aa37 100644 --- a/tests/Spec/Tweak/ValidityRange.hs +++ b/tests/Spec/Tweak/ValidityRange.hs @@ -1,11 +1,27 @@ module Spec.Tweak.ValidityRange (tests) where -import Control.Monad -import Cooked +import Control.Monad (void) +import Cooked.MockChain.Error +import Cooked.MockChain.Log +import Cooked.MockChain.Read +import Cooked.MockChain.State +import Cooked.MockChain.Testing +import Cooked.MockChain.Write +import Cooked.Skeleton +import Cooked.Tweak.Common +import Cooked.Tweak.ValidityRange +import Data.Default (def) import Data.Either (rights) import Data.Function (on) import Ledger.Slot qualified as Ledger +import Ledger.Tx qualified as Ledger import PlutusLedgerApi.V1.Interval qualified as Api +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.NonDet +import Polysemy.State +import Polysemy.Writer import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, testCase) @@ -18,7 +34,7 @@ toSlotRangeTranslate translation a b = (Ledger.getSlot translation + a) (Ledger.getSlot translation + b) -checkIsValidDuring :: (MonadTweak m) => m Assertion +checkIsValidDuring :: (Member Tweak effs) => Sem effs Assertion checkIsValidDuring = do b <- hasFullTimeRangeTweak b1 <- isValidDuringTweak $ toSlotRange 101 1015 @@ -29,7 +45,7 @@ checkIsValidDuring = do assertBool "interval inclusions are wrong" $ b && b1 && b2 && not b3 -checkAddToValidityRange :: (MonadTweak m) => m Assertion +checkAddToValidityRange :: (Members '[Tweak, MockChainRead, MockChainWrite, NonDet] effs) => Sem effs Assertion checkAddToValidityRange = do timeOrigin <- currentSlot void $ centerAroundValidityRangeTweak (timeOrigin + Ledger.Slot 100) 80 @@ -47,22 +63,41 @@ checkAddToValidityRange = do assertBool "interval intersection is wrong" $ b && b1 && b2 && b3 && not b4 && b5 -checkMoveCurrentSlot :: (MonadTweak m) => m Assertion -checkMoveCurrentSlot = do - void $ setValidityRangeTweak $ toSlotRange 10 20 - void waitUntilValidTweak - b1 <- (\now -> now >= 10 && now <= 20) <$> currentSlot - b2 <- isValidNowTweak - void $ setValidityRangeTweak $ toSlotRange 15 25 - void waitUntilValidTweak - b3 <- (\now -> now >= 15 && now <= 25) <$> currentSlot - return $ assertBool "Time shift did not occur" $ b1 && b2 && b3 +type ValidityRangeEffs = + '[ Tweak, + MockChainWrite, + MockChainRead, + NonDet + ] + +interpretValidityRange :: Sem ValidityRangeEffs a -> [a] +interpretValidityRange = + run + . fmap rights + . runNonDet + . fmap snd + . runWriter + . runMockChainLog (: []) + . evalState def + . runError + . runFailInMockChainError + . runToCardanoErrorInMockChainError + . runMockChainRead + . runMockChainWrite + . evalTweak txSkelTemplate + . insertAt @3 + @'[ Error Ledger.ToCardanoError, + Fail, + Error MockChainError, + State MockChainState, + MockChainLog, + Writer [MockChainLogEntry] + ] tests :: TestTree tests = testGroup "Validity range tweaks" - [ testCase "Validity inclusion" $ fst . head . rights $ mcrValue <$> runTweak checkIsValidDuring txSkelTemplate, - testCase "Validity intersection" $ fst . head . rights $ mcrValue <$> runTweak checkAddToValidityRange txSkelTemplate, - testCase "Time shifting in validity range" $ fst . head . rights $ mcrValue <$> runTweak checkMoveCurrentSlot txSkelTemplate + [ testCase "Validity inclusion" $ testConjoin $ interpretValidityRange checkIsValidDuring, + testCase "Validity intersection" $ testConjoin $ interpretValidityRange checkAddToValidityRange ] diff --git a/tests/Spec/Withdrawals.hs b/tests/Spec/Withdrawals.hs index f23f041c5..9f07e5b70 100644 --- a/tests/Spec/Withdrawals.hs +++ b/tests/Spec/Withdrawals.hs @@ -12,11 +12,10 @@ alice :: Wallet alice = wallet 1 testWithdrawingScript :: - (MonadModalBlockChain m) => Maybe (User IsEither Redemption) -> User IsEither Redemption -> Maybe Integer -> - m () + StagedMockChain () testWithdrawingScript userCertifying userRewarding mAmount = do when (isJust userCertifying) $ validateTxSkel_ $ @@ -63,7 +62,7 @@ tests = (scriptUserWithdrawing 0) Nothing ) - `withJournalProp` happened "MCLogAutoFilledWithdrawalAmount", + `withLogProp` happened "MCLogAutoFilledWithdrawalAmount", testCooked ".. but the script's logic might say No" $ mustFailTest ( testWithdrawingScript @@ -72,7 +71,7 @@ tests = Nothing ) `withFailureProp` isPhase2FailureWithMsg "Wrong quantity: 0 instead of 2000000" - `withJournalProp` happened "MCLogAutoFilledWithdrawalAmount", + `withLogProp` happened "MCLogAutoFilledWithdrawalAmount", testCooked "We cannot withdraw more than our rewards (0)" $ mustFailTest ( testWithdrawingScript @@ -81,7 +80,7 @@ tests = (Just 2) ) `withFailureProp` isPhase1FailureWithMsg "WithdrawalsNotInRewardsCERTS" - `withJournalProp` didNotHappen "MCLogAutoFilledWithdrawalAmount", + `withLogProp` didNotHappen "MCLogAutoFilledWithdrawalAmount", testCooked "A peer can also make a withdrawal" $ mustSucceedTest ( testWithdrawingScript @@ -89,5 +88,5 @@ tests = aliceUser Nothing ) - `withJournalProp` happened "MCLogAutoFilledWithdrawalAmount" + `withLogProp` happened "MCLogAutoFilledWithdrawalAmount" ]