├── .git-blame-ignore-revs ├── .gitattributes ├── .github ├── dependabot.yml └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── cabal.project ├── cooked-validators.cabal ├── doc ├── BALANCING.md ├── CHEATSHEET.md ├── CONWAY.md └── IMPORTS.md ├── flake.lock ├── flake.nix ├── hie.yaml ├── package.yaml ├── src ├── Cooked.hs └── Cooked │ ├── Attack.hs │ ├── Attack │ ├── AddToken.hs │ ├── DatumHijacking.hs │ ├── DoubleSat.hs │ └── DupToken.hs │ ├── InitialDistribution.hs │ ├── Ltl.hs │ ├── MockChain.hs │ ├── MockChain │ ├── AutoReferenceScripts.hs │ ├── Balancing.hs │ ├── BlockChain.hs │ ├── Direct.hs │ ├── GenerateTx.hs │ ├── GenerateTx │ │ ├── Body.hs │ │ ├── Collateral.hs │ │ ├── Common.hs │ │ ├── Input.hs │ │ ├── Mint.hs │ │ ├── Output.hs │ │ ├── Proposal.hs │ │ ├── ReferenceInputs.hs │ │ ├── Withdrawals.hs │ │ └── Witness.hs │ ├── MinAda.hs │ ├── MockChainState.hs │ ├── Staged.hs │ ├── Testing.hs │ ├── UtxoSearch.hs │ └── UtxoState.hs │ ├── Pretty.hs │ ├── Pretty │ ├── Class.hs │ ├── Hashable.hs │ ├── MockChain.hs │ ├── Options.hs │ ├── Plutus.hs │ └── Skeleton.hs │ ├── ShowBS.hs │ ├── Skeleton.hs │ ├── Skeleton │ ├── Datum.hs │ ├── Label.hs │ ├── Mint.hs │ ├── Option.hs │ ├── Output.hs │ ├── Payable.hs │ ├── Proposal.hs │ ├── Redeemer.hs │ ├── ReferenceScript.hs │ ├── Value.hs │ └── Withdrawal.hs │ ├── Tweak.hs │ ├── Tweak │ ├── Common.hs │ ├── Inputs.hs │ ├── Labels.hs │ ├── Mint.hs │ ├── OutPermutations.hs │ ├── Outputs.hs │ ├── Signers.hs │ └── ValidityRange.hs │ └── Wallet.hs └── tests ├── Plutus ├── Attack │ ├── DatumHijacking.hs │ ├── DoubleSat.hs │ └── DupToken.hs ├── InlineDatums.hs ├── MultiPurpose.hs ├── ProposingScript.hs ├── ReferenceInputs.hs ├── ReferenceScripts.hs └── Withdrawals.hs ├── Spec.hs └── Spec ├── Attack.hs ├── Attack ├── DatumHijacking.hs ├── DoubleSat.hs └── DupToken.hs ├── Balancing.hs ├── BasicUsage.hs ├── InitialDistribution.hs ├── InlineDatums.hs ├── Ltl.hs ├── MinAda.hs ├── MultiPurpose.hs ├── ProposingScript.hs ├── ReferenceInputs.hs ├── ReferenceScripts.hs ├── Slot.hs ├── Tweak.hs ├── Tweak ├── Common.hs ├── OutPermutations.hs ├── TamperDatum.hs └── ValidityRange.hs └── Withdrawals.hs /.git-blame-ignore-revs: -------------------------------------------------------------------------------- 1 | ## .git-blame-ignore-revs 2 | 3 | ## run ormolu & hpack 4 | 550c27cff4e96e8726bfe2a256971d9024625726 5 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # The *.pir files are not parrot intermediate representation, as the linguist 2 | # thought, but plutus intermetidate representation, and they should be ignored 3 | # on the languages pane. This also hides diffs over *.pir files. 4 | *.pir linguist-generated -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | version: 2 4 | 5 | updates: 6 | - package-ecosystem: github-actions 7 | directory: / 8 | schedule: 9 | interval: daily 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | .direnv 3 | .envrc 4 | .projectile 5 | .vscode 6 | .#* 7 | *# 8 | *.artifact 9 | *.swp 10 | docs/ 11 | .pre-commit-config.yaml 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) Tweag I/O Limited. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # [Cooked Validators](https://github.com/tweag/cooked-validators/) 2 | 3 | Copyright Tweag I/O 2025 4 | 5 | `cooked-validators` is a Haskell library to conveniently and efficiently write 6 | off-chain code for Cardano smart contracts. This offchain code will be 7 | specifically geared to testing and auditing the smart contract in question with 8 | further builtin capabilities of the library. 9 | 10 | In particular, `cooked-validators` allows the user to: 11 | - interact with smart contracts written in Plutus or any other language that 12 | compiles to [UPLC](https://plutonomicon.github.io/plutonomicon/uplc), like for 13 | example [Plutarch](https://github.com/Plutonomicon/plutarch-plutus) or 14 | [Aiken](https://aiken-lang.org/), by loading contracts from byte strings 15 | - define transactions in a high level, type-retaining data structure 16 | - submit transactions for validation, while automatically taking care of missing 17 | inputs and outputs, balancing, minimum-Ada constraints, collaterals and fees 18 | - construct sequences of transactions in an easy-to-understand abstraction of 19 | "the blockchain", which can be instantiated to different actual 20 | implementations 21 | - run sequences of transactions in a simulated blockchain 22 | - apply "tweaks" to transactions right before submitting them, where "tweaks" 23 | are modifications that are aware of the current state of the simulated 24 | blockchain 25 | - compose and deploy tweaks with flexible idioms inspired by linear temporal 26 | logic, in order to turn one sequence of transactions into many sequences that 27 | might be useful test cases, generalized in 28 | [Graft](https://github.com/tweag/graft) 29 | - deploy automated attacks over existing sequences of transactions, such as 30 | datum hijacking or double satisfaction attacks, in an attempt to uncover 31 | vulnerabilities 32 | 33 | You are free to copy, modify, and distribute `cooked-validators` under the terms 34 | of the MIT license. We provide `cooked-validators` as a research prototype under 35 | active development, and it comes _as is_ with no guarantees whatsoever. Check 36 | the [license](LICENSE) for details. 37 | 38 | ## How to integrate `cooked-validators` in a project 39 | 40 | To use `cooked-validators`, you need 41 | - [GHC](https://www.haskell.org/ghc/download_ghc_9_6_6.html) version 9.6.6 42 | - [Cabal](https://www.haskell.org/cabal) version 3.10 or later 43 | 44 | 1. `cooked-validators` depends on 45 | [cardano-haskell-packages](https://github.com/input-output-hk/cardano-haskell-packages) 46 | to get cardano-related packages and on 47 | [cardano-node-emulator](https://github.com/tweag/cardano-node-emulator-forked) 48 | directly. If you have no constraint on the version of this package, copy the 49 | file [`cabal.project`](./cabal.project) to your project and 50 | [adapt](https://cabal.readthedocs.io/en/stable/cabal-project-description-file.html#specifying-the-local-packages) 51 | the `packages` stanza. 52 | 53 | 2. Add the following stanza to the file `cabal.project` 54 | ```cabal.project 55 | source-repository-package 56 | type: git 57 | location: https://github.com/tweag/cooked-validators 58 | tag: myTag 59 | subdir: 60 | . 61 | ``` 62 | where `myTag` is either a commit hash in the repo, or a tag, such as v5.0.0 63 | (see [available 64 | releases](https://github.com/tweag/cooked-validators/releases)). 65 | 66 | ## Example 67 | 68 | 1. Make your project 69 | [depend](https://cabal.readthedocs.io/en/stable/getting-started.html#adding-dependencies) 70 | on `cooked-validators` and `plutus-script-utils` 71 | 72 | 2. Enter a Cabal read-eval-print-loop (with `cabal repl`) 73 | and create and validate a transaction which transfers 10 Ada 74 | from wallet 1 to wallet 2: 75 | ```haskell 76 | > import Cooked 77 | > import qualified Plutus.Script.Utils.Value as Script 78 | > printCooked . runMockChain . validateTxSkel $ 79 | txSkelTemplate 80 | { txSkelOuts = [wallet 2 `receives` Value (Script.ada 10)], 81 | txSkelSigners = [wallet 1] 82 | } 83 | [...] 84 | - UTxO state: 85 | • pubkey wallet 1 86 | - Lovelace: 89_828_471 87 | - (×4) Lovelace: 100_000_000 88 | • pubkey wallet 2 89 | - Lovelace: 10_000_000 90 | - (×5) Lovelace: 100_000_000 91 | • pubkey wallet 3 92 | - (×5) Lovelace: 100_000_000 93 | • pubkey wallet 4 94 | - (×5) Lovelace: 100_000_000 95 | [...] 96 | ``` 97 | 98 | ## Documentation 99 | 100 | - The rendered Haddock for the current `main` branch can be found 101 | [here](https://tweag.github.io/cooked-validators/). 102 | 103 | - The [CHEATSHEET](doc/CHEATSHEET.md) contains many code snippets to quickly get 104 | an intuition of how to do things. Use it to discover or search for how to use 105 | features of `cooked-validators`. Note that this is not a tutorial nor a 106 | ready-to-use recipes book. 107 | 108 | - The [IMPORTS](doc/IMPORTS.md) file describes and helps to understand our 109 | dependencies and naming conventions for imports. 110 | 111 | - The [BALANCING](doc/BALANCING.md) file thorougly describes cooked-validator's 112 | automated balancing mechanism and associated options (including options 113 | revolving around fees and collaterals). 114 | 115 | - The [CONWAY](doc/CONWAY.md) file describes the Conway features that are 116 | currently supported by `cooked-validators`. 117 | 118 | ## Additional resources 119 | 120 | - We have a [repository](https://github.com/tweag/cooked-smart-contracts) of 121 | example contracts with offchain code and tests written using 122 | `cooked-validators`. Note that these examples are not maintained and thus 123 | written using older versions of the library. 124 | 125 | - Feel free to visit our [issue 126 | tracker](https://github.com/tweag/cooked-validators/issues) to seek help about 127 | known problems, or report new issues! 128 | 129 | - `cooked-validators` is regularly used to audit Cardano smart contracts. You 130 | can see some of the products with have audited on [this 131 | page](https://www.tweag.io/audits/) and can get access to a sample of our 132 | audit reports on [this 133 | repository](https://github.com/tweag/tweag-audit-reports). 134 | 135 | - `cooked-validators` comes with a [template 136 | repository](https://github.com/tweag/cooked-template) which can be used to 137 | develop offchain code and/or audit code with the tool. 138 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | . 3 | 4 | package cooked-validators 5 | coverage: True 6 | library-coverage: True 7 | 8 | package cardano-crypto-praos 9 | flags: -external-libsodium-vrf 10 | 11 | -- Custom repository for cardano haskell packages 12 | -- See https://github.com/IntersectMBO/cardano-haskell-packages 13 | -- on how to use CHaP in a Haskell project. 14 | repository cardano-haskell-packages 15 | url: https://chap.intersectmbo.org/ 16 | secure: True 17 | root-keys: 18 | 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f 19 | 443abb7fb497a134c343faf52f0b659bd7999bc06b7f63fa76dc99d631f9bea1 20 | a86a1f6ce86c449c46666bda44268677abf29b5b2d2eb5ec7af903ec2f117a82 21 | bcec67e8e99cabfa7764d75ad9b158d72bfacf70ca1d0ec8bc6b4406d1bf8413 22 | c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56 23 | d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee 24 | 25 | index-state: 26 | , hackage.haskell.org 2025-04-16T16:04:13Z 27 | , cardano-haskell-packages 2025-05-16T15:25:35Z 28 | 29 | -- We never, ever, want this. 30 | write-ghc-environment-files: never 31 | 32 | -- The only sensible test display option, since it allows us to have colourized 33 | -- 'tasty' output. 34 | test-show-details: direct 35 | 36 | -- These packages appear in our dependency tree and are very slow to build. 37 | -- Empirically, turning off optimization shaves off ~50% build time. 38 | -- It also mildly improves recompilation avoidance. 39 | -- For dev work we don't care about performance so much, so this is okay. 40 | package cardano-ledger-alonzo 41 | optimization: False 42 | package ouroboros-consensus-cardano 43 | optimization: False 44 | package cardano-api 45 | optimization: False 46 | package cardano-crypto-praos 47 | flags: -external-libsodium-vrf 48 | 49 | constraints: 50 | cardano-api == 10.16.1.0 51 | 52 | source-repository-package 53 | type: git 54 | location: https://github.com/intersectMBO/cardano-node-emulator 55 | tag: 6d65996418d2b00fa791407ec47e2fe77c208790 56 | subdir: 57 | plutus-script-utils 58 | plutus-ledger 59 | cardano-node-emulator 60 | freer-extras 61 | -------------------------------------------------------------------------------- /doc/CONWAY.md: -------------------------------------------------------------------------------- 1 | # Supported Conway features 2 | 3 | With the arrival of the Conway era, the Cardano blockchain is being enriched 4 | with a significant set of features revolving around governance. Governance can 5 | be defined as the ability for ada holders to take part in various on-chain 6 | decisions as described in 7 | [CIP-1694](https://github.com/cardano-foundation/CIPs/tree/master/CIP-1694). These 8 | new features have brought a substantial set of changes, such as new script 9 | purposes, new centralized data like committee, and new transaction 10 | features. This documents describes which of those features are currently being 11 | supported by cooked-validators, and to which extent. Each of the following items 12 | describes a feature that is currently supported. The reader can assume that 13 | everything that is not directly mentioned here about Conway is not yet 14 | supported. 15 | 16 | ## Proposal procedures 17 | 18 | It is currently possible to describe proposal procedures and attach an arbitrary 19 | number of those in transaction skeletons. The balancing mechanism will take into 20 | account the required deposit for each of these procedures. If those proposal 21 | procedure involve scripts (i.e. they proposal a withdrawal or a parameter 22 | change) those script will be ran during the validation process. However, the 23 | proposal will not be enacted. 24 | 25 | ## Multipurpose scripts 26 | 27 | Multipurpose scripts, from 28 | [CIP-0069](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0069) are 29 | fully supported by cooked-validators. 30 | 31 | ## Withdrawals 32 | 33 | It is currently possible to register a staking credential with a certain deposit 34 | and reward (either a script or a wallet) and to later on withdraw this 35 | reward. If the reward is associated with a script, this script will be ran 36 | during the validation process. 37 | -------------------------------------------------------------------------------- /doc/IMPORTS.md: -------------------------------------------------------------------------------- 1 | # Imports convention 2 | 3 | The Cardano and Plutus ecosystem is enormous. There are dozens of packages 4 | exporting various definitions, and many of them are either deprecated or 5 | outdated. From within those packages, many modules re-export various definitions 6 | from other modules alongside new definitions, which means that two similar 7 | definitions could be imported in different ways. In addition, various 8 | definitions with similar names are actually different based on where they are 9 | defined. Overall, this makes for a very tedious process of importing the right 10 | definitions from the right places, and having a somewhat homogeneous process is 11 | a challenge. This is why this file exists. We detail here the two main keys to 12 | have a standardized way of importing definition in cooked-validators: qualified 13 | modules and preferred import locations. 14 | 15 | ## Names of qualified modules related to Cardano 16 | 17 | Here is the correspondance between package and prefix for each of our main 18 | dependencies: 19 | 20 | ### [`cardano-node-emulator`](https://github.com/IntersectMBO/cardano-node-emulator) 21 | 22 | - package `plutus-script-utils`, prefix `Script` 23 | - package `plutus-ledger`, prefix `Ledger` 24 | - package `cardano-node-emulator`, prefix `Emulator` 25 | 26 | ### [`plutus`](https://github.com/IntersectMBO/plutus) 27 | 28 | - package `plutus-tx`, prefix `PlutusTx` 29 | - package `plutus-ledger-api`, prefix `Api` 30 | 31 | ### [`cardano-api`](https://github.com/IntersectMBO/cardano-api) 32 | 33 | - package `cardano-api`, prefix `Cardano` 34 | 35 | ### [`cardano-crypto`](https://github.com/IntersectMBO/cardano-crypto) 36 | 37 | - own package, prefix `Crypto` 38 | 39 | ### [`cardano-ledger`](https://github.com/IntersectMBO/cardano-ledger) 40 | 41 | - package `cardano-ledger-shelley`, prefix `Shelley` 42 | - package `cardano-ledger-conway`, prefix `Conway` 43 | 44 | ### Exception 45 | 46 | When using `PlutusTx.Prelude` (from `plutus-tx`) in conjunction with the 47 | `NoImplicitPrelude` language extension, no prefix should be used. Instead, 48 | functions coming from the usual prelude should be prefixed `Haskell` in those 49 | modules instead. 50 | 51 | ## Names of qualifed modules unrelated to Cardano 52 | 53 | `cooked-validators` uses optics in various places of the codebase. These optics 54 | come from the module `Optics.Core` of the `optics` package and are used 55 | unqualified in the code. Some of our dependencies however use optics coming from 56 | the `lens` or `microlens` packages. When using those, we should make very clear 57 | that they do not come from our default optics library, and thus prefix them with 58 | `Lens` or `Microlens` respectively. 59 | 60 | ## Preferred import locations rules 61 | 62 | Here is a list of preferred rules to ensure each definition always comes from a 63 | unique location. 64 | 65 | ### Stick to imports closer to the root definition 66 | 67 | When importing definitions that could be found in various modules from the list 68 | above, we always stick to the more close-to-actual-definition module. In 69 | particular, everything that can be imported from `PlutusLedgerApi.V3` (from 70 | plutus-ledger) should. For instance, `Value` should always be coming from 71 | `Api.Value` instead of `Script.Value`. 72 | 73 | ### Avoid directly importing `Ledger` 74 | 75 | `Ledger` is a big module coming from `plutus-ledger` that re-exports many 76 | definitions. It re-exports too many definitions so that it hides where they 77 | really come from, but not enough so that importing `Ledger` alone sufficies in 78 | most projects. Thus, we avoid importing it altogher and instead rely on 79 | `PlutusLedger.V3` and sub-modules `Ledger.*`. 80 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-compat": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1696426674, 7 | "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", 8 | "owner": "edolstra", 9 | "repo": "flake-compat", 10 | "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "edolstra", 15 | "repo": "flake-compat", 16 | "type": "github" 17 | } 18 | }, 19 | "flake-utils": { 20 | "inputs": { 21 | "systems": "systems" 22 | }, 23 | "locked": { 24 | "lastModified": 1731533236, 25 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 26 | "owner": "numtide", 27 | "repo": "flake-utils", 28 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 29 | "type": "github" 30 | }, 31 | "original": { 32 | "owner": "numtide", 33 | "repo": "flake-utils", 34 | "type": "github" 35 | } 36 | }, 37 | "gitignore": { 38 | "inputs": { 39 | "nixpkgs": [ 40 | "pre-commit-hooks", 41 | "nixpkgs" 42 | ] 43 | }, 44 | "locked": { 45 | "lastModified": 1709087332, 46 | "narHash": "sha256-HG2cCnktfHsKV0s4XW83gU3F57gaTljL9KNSuG6bnQs=", 47 | "owner": "hercules-ci", 48 | "repo": "gitignore.nix", 49 | "rev": "637db329424fd7e46cf4185293b9cc8c88c95394", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "hercules-ci", 54 | "repo": "gitignore.nix", 55 | "type": "github" 56 | } 57 | }, 58 | "nixpkgs": { 59 | "locked": { 60 | "lastModified": 1747919418, 61 | "narHash": "sha256-LHQHk4GNuzhqnnO6JxGOXZPpYGtex5oc6/KxAYV0O8I=", 62 | "owner": "NixOS", 63 | "repo": "nixpkgs", 64 | "rev": "053bdd80dd362baf11a798e11a57d511b1641478", 65 | "type": "github" 66 | }, 67 | "original": { 68 | "owner": "NixOS", 69 | "repo": "nixpkgs", 70 | "type": "github" 71 | } 72 | }, 73 | "pre-commit-hooks": { 74 | "inputs": { 75 | "flake-compat": "flake-compat", 76 | "gitignore": "gitignore", 77 | "nixpkgs": [ 78 | "nixpkgs" 79 | ] 80 | }, 81 | "locked": { 82 | "lastModified": 1747372754, 83 | "narHash": "sha256-2Y53NGIX2vxfie1rOW0Qb86vjRZ7ngizoo+bnXU9D9k=", 84 | "owner": "cachix", 85 | "repo": "pre-commit-hooks.nix", 86 | "rev": "80479b6ec16fefd9c1db3ea13aeb038c60530f46", 87 | "type": "github" 88 | }, 89 | "original": { 90 | "owner": "cachix", 91 | "repo": "pre-commit-hooks.nix", 92 | "type": "github" 93 | } 94 | }, 95 | "root": { 96 | "inputs": { 97 | "flake-utils": "flake-utils", 98 | "nixpkgs": "nixpkgs", 99 | "pre-commit-hooks": "pre-commit-hooks" 100 | } 101 | }, 102 | "systems": { 103 | "locked": { 104 | "lastModified": 1681028828, 105 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 106 | "owner": "nix-systems", 107 | "repo": "default", 108 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 109 | "type": "github" 110 | }, 111 | "original": { 112 | "owner": "nix-systems", 113 | "repo": "default", 114 | "type": "github" 115 | } 116 | } 117 | }, 118 | "root": "root", 119 | "version": 7 120 | } 121 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs.nixpkgs.url = "github:NixOS/nixpkgs"; 3 | inputs.flake-utils.url = "github:numtide/flake-utils"; 4 | inputs.pre-commit-hooks.url = "github:cachix/pre-commit-hooks.nix"; 5 | inputs.pre-commit-hooks.inputs.nixpkgs.follows = "nixpkgs"; 6 | 7 | outputs = { self, nixpkgs, flake-utils, pre-commit-hooks }: 8 | flake-utils.lib.eachDefaultSystem (system: 9 | let 10 | pkgs = nixpkgs.legacyPackages.${system}; 11 | hpkgs = pkgs.haskell.packages.ghc96; 12 | 13 | ## We change the way 'blst' is built so that it takes into 14 | ## account the current architecture of the processor. This 15 | ## is due to a bug where older processors (>= 10 years) 16 | ## would not be supported. This should not change anything 17 | ## on newer machines. This could be revised in the future. 18 | blst-portable = pkgs.blst.overrideAttrs (_: _: { 19 | buildPhase = '' 20 | runHook preBuild 21 | ./build.sh -shared -D__BLST_PORTABLE__ ${ 22 | pkgs.lib.optionalString pkgs.stdenv.hostPlatform.isWindows 23 | "flavour=mingw64" 24 | } 25 | runHook postBuild 26 | ''; 27 | }); 28 | 29 | pre-commit = pre-commit-hooks.lib.${system}.run { 30 | src = ./.; 31 | hooks = { 32 | nixfmt-classic.enable = true; 33 | ormolu.enable = true; 34 | hpack.enable = true; 35 | }; 36 | tools = { 37 | ## This setting specifies which tools to use in the `pre-commit` 38 | ## hooks. Since we take our tools (`nixfmt`, `ormolu`, `hpack`) from 39 | ## `nixpkgs`, then we can simply make sure that 40 | ## `pre-commit-hooks.nix`'s `nixpkgs` input follows ours, so there 41 | ## is nothing to see here. 42 | ## 43 | ## NOTE: Configuring `hpack` here would have no effect. See 44 | ## https://github.com/cachix/pre-commit-hooks.nix/issues/255 45 | ## for more information. 46 | }; 47 | }; 48 | in { 49 | formatter = pkgs.nixfmt-classic; 50 | 51 | devShells = let 52 | ## The minimal dependency set to build the project with `cabal`. 53 | buildInputs = [ 54 | blst-portable 55 | pkgs.pkg-config 56 | pkgs.glibcLocales 57 | pkgs.zlib 58 | pkgs.libsodium 59 | pkgs.secp256k1 60 | pkgs.lmdb 61 | hpkgs.ghc 62 | hpkgs.cabal-install 63 | ]; 64 | 65 | ## Folders in which to find ".so" files 66 | LD_LIBRARY_PATH = pkgs.lib.strings.makeLibraryPath [ 67 | pkgs.xz 68 | pkgs.zlib 69 | pkgs.openssl_3_4 70 | pkgs.postgresql # For cardano-node-emulator 71 | pkgs.openldap # For freer-extras‽ 72 | pkgs.libsodium 73 | pkgs.secp256k1 74 | pkgs.lmdb 75 | blst-portable 76 | ]; 77 | 78 | LANG = "C.UTF-8"; 79 | 80 | in { 81 | ci = pkgs.mkShell { 82 | inherit buildInputs; 83 | inherit LD_LIBRARY_PATH; 84 | inherit LANG; 85 | }; 86 | 87 | default = pkgs.mkShell { 88 | buildInputs = buildInputs ++ [ 89 | pkgs.hpack 90 | pkgs.hlint 91 | hpkgs.ormolu 92 | hpkgs.haskell-language-server 93 | ]; 94 | 95 | inherit LD_LIBRARY_PATH; 96 | inherit LANG; 97 | 98 | # In addition to the pre-commit hooks, this redefines a cabal 99 | # command that gets rid of annoying "Writing: .....*.html" output 100 | # when running cabal test. 101 | shellHook = pre-commit.shellHook + '' 102 | function cabal() { 103 | if [ "$1" != "test" ]; then 104 | command cabal "$@" 105 | else 106 | command cabal --test-option=--color=always "$@" | grep -vE --color=never "^Writing:.*html$" 107 | fi 108 | } 109 | export -f cabal 110 | ''; 111 | }; 112 | }; 113 | 114 | checks = { inherit pre-commit; }; 115 | }); 116 | 117 | nixConfig = { 118 | extra-trusted-substituters = [ 119 | "https://tweag-cooked-validators.cachix.org/" 120 | "https://pre-commit-hooks.cachix.org/" 121 | "https://cache.iog.io" 122 | ]; 123 | extra-trusted-public-keys = [ 124 | "tweag-cooked-validators.cachix.org-1:g1TP7YtXjkBGXP/VbSTGBOGONSzdfzYwNJM27bn8pik=" 125 | "pre-commit-hooks.cachix.org-1:Pkk3Panw5AW24TOv6kz3PvLhlH8puAsJTBbOPmBo7Rc=" 126 | "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" 127 | ]; 128 | allow-import-from-derivation = true; 129 | accept-flake-config = true; 130 | }; 131 | } 132 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "./src" 4 | component: "lib:cooked-validators" 5 | 6 | - path: "./tests/" 7 | component: "cooked-validators:test:spec" 8 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | verbatim: 2 | cabal-version: 3.4 3 | 4 | name: cooked-validators 5 | version: 6.0.0 6 | 7 | dependencies: 8 | - QuickCheck 9 | - base >= 4.9 && < 5 10 | - bytestring 11 | - cardano-api 12 | - cardano-crypto 13 | - cardano-data 14 | - cardano-ledger-alonzo 15 | - cardano-ledger-core 16 | - cardano-ledger-shelley 17 | - cardano-ledger-conway 18 | - cardano-node-emulator 19 | - cardano-strict-containers 20 | - containers 21 | - data-default 22 | - either 23 | - exceptions 24 | - flat 25 | - http-conduit 26 | - lens 27 | - list-t 28 | - microlens 29 | - monad-control 30 | - mtl 31 | - nonempty-containers 32 | - optics-core 33 | - optics-th 34 | - ordered-containers 35 | - plutus-core 36 | - plutus-ledger 37 | - plutus-ledger-api 38 | - plutus-script-utils 39 | - plutus-tx 40 | - plutus-tx-plugin 41 | - prettyprinter 42 | - random 43 | - random-shuffle 44 | - strict-sop-core 45 | - tasty 46 | - tasty-hunit 47 | - tasty-quickcheck 48 | - text 49 | - transformers 50 | 51 | library: 52 | source-dirs: src 53 | ghc-options: &ghc-options 54 | -Wall 55 | -Wcompat 56 | -Wincomplete-record-updates 57 | -Wincomplete-uni-patterns 58 | -Wredundant-constraints 59 | -Wno-missed-extra-shared-lib 60 | -fobject-code 61 | -fno-ignore-interface-pragmas 62 | -fignore-hpc-changes 63 | -fno-omit-interface-pragmas 64 | -fplugin-opt PlutusTx.Plugin:defer-errors 65 | -fplugin-opt PlutusTx.Plugin:conservative-optimisation 66 | default-extensions: &default-extensions 67 | - ConstraintKinds 68 | - DataKinds 69 | - DerivingStrategies 70 | - DerivingVia 71 | - FlexibleContexts 72 | - FlexibleInstances 73 | - GADTs 74 | - GeneralizedNewtypeDeriving 75 | - ImportQualifiedPost 76 | - LambdaCase 77 | - MultiParamTypeClasses 78 | - MultiWayIf 79 | - NamedFieldPuns 80 | - NumericUnderscores 81 | - OverloadedStrings 82 | - PolyKinds 83 | - RankNTypes 84 | - RecordWildCards 85 | - ScopedTypeVariables 86 | - StandaloneDeriving 87 | - TemplateHaskell 88 | - TupleSections 89 | - TypeApplications 90 | - TypeFamilies 91 | - TypeOperators 92 | - ViewPatterns 93 | 94 | tests: 95 | spec: 96 | main: Spec.hs 97 | source-dirs: 98 | - tests/ 99 | ghc-options: *ghc-options 100 | dependencies: 101 | - cooked-validators 102 | default-extensions: *default-extensions 103 | -------------------------------------------------------------------------------- /src/Cooked.hs: -------------------------------------------------------------------------------- 1 | -- | Re-exports the entirety of the library, which is always eventually necessary 2 | -- when writing large test-suites. 3 | module Cooked 4 | ( module X, 5 | Ltl.MonadModal (..), 6 | Ltl.Ltl (..), 7 | ) 8 | where 9 | 10 | import Cooked.Attack as X 11 | import Cooked.InitialDistribution as X 12 | import Cooked.Ltl qualified as Ltl 13 | import Cooked.MockChain as X 14 | import Cooked.Pretty as X 15 | import Cooked.ShowBS as X 16 | import Cooked.Skeleton as X 17 | import Cooked.Tweak as X 18 | import Cooked.Wallet as X 19 | -------------------------------------------------------------------------------- /src/Cooked/Attack.hs: -------------------------------------------------------------------------------- 1 | -- | Centralized module with automated attacks: 2 | -- 3 | -- - Add extraneous tokens to transactions 4 | -- 5 | -- - Hijack outputs be redirecting them to some address 6 | -- 7 | -- - Perform double satisfaction on outputs 8 | -- 9 | -- - Duplicate minted tokens 10 | -- 11 | -- These attacks usually rely on applying specific tweaks from `Cooked.Tweak` 12 | -- at specific position in traces using Ltl formulae using `Cooked.Ltl` 13 | module Cooked.Attack (module X) where 14 | 15 | import Cooked.Attack.AddToken as X 16 | import Cooked.Attack.DatumHijacking as X 17 | import Cooked.Attack.DoubleSat as X 18 | import Cooked.Attack.DupToken as X 19 | -------------------------------------------------------------------------------- /src/Cooked/Attack/AddToken.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides an automated attack to mint and give extra tokens to a 2 | -- certain wallet. 3 | module Cooked.Attack.AddToken (addTokenAttack, AddTokenLbl (..)) where 4 | 5 | import Control.Monad 6 | import Cooked.Pretty 7 | import Cooked.Skeleton 8 | import Cooked.Tweak 9 | import Optics.Core 10 | import Plutus.Script.Utils.Scripts qualified as Script 11 | import PlutusLedgerApi.V3 qualified as Api 12 | import PlutusTx.AssocMap qualified as PMap 13 | import Prettyprinter qualified as PP 14 | 15 | -- | This attack adds extra tokens, depending on the minting policy. It is 16 | -- different from the 'Cooked.Attack.DupToken.dupTokenAttack' in that it does 17 | -- not merely try to increase the amount of tokens minted: It tries to mint 18 | -- tokens of asset classes that were not necessarily present on the unmodified 19 | -- transaction. 20 | -- 21 | -- This attack adds an 'AddTokenLbl' label. 22 | addTokenAttack :: 23 | (MonadTweak m, OwnerConstrs o) => 24 | -- | For each policy that occurs in some 'Mint' constraint, return a list of 25 | -- token names together with how many tokens with that name should be minted. 26 | (Script.Versioned Script.MintingPolicy -> [(Api.TokenName, Integer)]) -> 27 | -- | The wallet of the attacker where extra tokens will be paid to 28 | o -> 29 | m Api.Value 30 | addTokenAttack extraTokens attacker = do 31 | oldMintsList <- viewTweak $ txSkelMintsL % to txSkelMintsToList 32 | let (newMintsList, totalIncrement) = 33 | foldl 34 | ( \(newMs, addVal) (Mint mp@(Script.toVersioned @Script.MintingPolicy -> mp') red tks) -> 35 | let change = extraTokens mp' 36 | in ( Mint mp red (tks ++ change) : newMs, 37 | Api.Value (PMap.singleton (Script.toCurrencySymbol mp') (PMap.unsafeFromList change)) <> addVal 38 | ) 39 | ) 40 | ([], mempty) 41 | oldMintsList 42 | guard (totalIncrement /= mempty) 43 | setTweak txSkelMintsL $ txSkelMintsFromList newMintsList 44 | addOutputTweak $ attacker `receives` Value totalIncrement 45 | addLabelTweak AddTokenLbl 46 | return totalIncrement 47 | 48 | -- | A label that is added to a 'TxSkel' that has successfully been modified by 49 | -- 'addTokenAttack' 50 | data AddTokenLbl = AddTokenLbl deriving (Show, Eq, Ord) 51 | 52 | instance PrettyCooked AddTokenLbl where 53 | prettyCooked = PP.viaShow 54 | -------------------------------------------------------------------------------- /src/Cooked/Attack/DatumHijacking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | -- | This module provides an automated attack to try and redirect outputs to a 4 | -- certain target with a similar datum type. 5 | module Cooked.Attack.DatumHijacking 6 | ( redirectOutputTweakAny, 7 | datumHijackingAttackAny, 8 | datumHijackingAttack, 9 | redirectOutputTweakAll, 10 | datumHijackingAttackAll, 11 | DatumHijackingLbl (..), 12 | ) 13 | where 14 | 15 | import Control.Monad 16 | import Cooked.Pretty.Class 17 | import Cooked.Skeleton 18 | import Cooked.Tweak 19 | import Data.Maybe 20 | import Optics.Core 21 | import Plutus.Script.Utils.Address qualified as Script 22 | import PlutusLedgerApi.V3 qualified as Api 23 | import Prettyprinter ((<+>)) 24 | 25 | -- | Redirects some outputs from one owner to another owner, which can be of 26 | -- different types. 27 | redirectOutputTweakAll :: 28 | forall owner owner' m. 29 | (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => 30 | -- | Return 'Just' the new owner, or 'Nothing' if you want to leave this 31 | -- output unchanged. 32 | (TxSkelOut -> Maybe owner') -> 33 | -- | The redirection described by the previous argument might apply to more 34 | -- than one of the outputs of the transaction. Use this predicate to select 35 | -- which of the redirectable outputs to actually redirect. We count the 36 | -- redirectable outputs from the left to the right, starting with zero. 37 | (Integer -> Bool) -> 38 | -- | Returns the list of outputs it redirected (as they were 39 | -- before the modification), in the order in which they occurred on the original 40 | -- transaction. 41 | m [TxSkelOut] 42 | redirectOutputTweakAll outputPred indexPred = do 43 | outputs <- viewTweak txSkelOutsL 44 | let (changed, newOutputs) = unzip $ go outputs 0 45 | setTweak txSkelOutsL newOutputs 46 | return $ catMaybes changed 47 | where 48 | go [] _ = [] 49 | go (out : l) n = 50 | case preview (txSkelOutTypedOwnerAT @owner) out >> outputPred out of 51 | Nothing -> (Nothing, out) : go l n 52 | Just newOwner | indexPred n -> (Just out, out {tsoOwner = newOwner}) : go l (n + 1) 53 | _ -> (Nothing, out) : go l (n + 1) 54 | 55 | -- | A version of 'redirectOutputTweakAll' where, instead of modifying all the 56 | -- outputs targeted by the input predicates in the same transaction, we modify 57 | -- one of them at a time, relying on the 'MonadPlus' instance of @m@. 58 | redirectOutputTweakAny :: 59 | forall owner owner' m. 60 | (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => 61 | (TxSkelOut -> Maybe owner') -> 62 | (Integer -> Bool) -> 63 | m TxSkelOut 64 | redirectOutputTweakAny outputPred indexPred = viewTweak txSkelOutsL >>= go [] 0 65 | where 66 | go _ _ [] = mzero 67 | go l' n (out : l) 68 | | indexPred n = 69 | fromMaybe 70 | (go (l' ++ [out]) (n + 1) l) 71 | ( do 72 | void $ preview (txSkelOutTypedOwnerAT @owner) out 73 | newOwner <- outputPred out 74 | return $ 75 | mplus 76 | (setTweak txSkelOutsL (l' ++ out {tsoOwner = newOwner} : l) >> return out) 77 | (go (l' ++ [out]) (n + 1) l) 78 | ) 79 | go l' n (out : l) = go (l' ++ [out]) n l 80 | 81 | -- | A datum hijacking attack, simplified: This attack tries to substitute a 82 | -- different recipient on outputs belonging to scripts, but leaves the datum as 83 | -- it is. That is, it tests for careless uses of something like 84 | -- 'Api.txInfoOutputs' in places where something like 'Api.getContinuingOutputs' 85 | -- should be used. If this attack goes through, however, a "proper" datum 86 | -- hijacking attack that modifies the datum in a way that (the relevant part of) 87 | -- the 'Api.toBuiltinData'-translation stays the same will also work. 88 | -- 89 | -- A 'DatumHijackingLbl' with the hash of the "thief" validator is added to the 90 | -- labels of the 'TxSkel' using 'addLabelTweak'. 91 | -- 92 | -- This attack returns the list of outputs it redirected, in the order in which 93 | -- they occurred on the original transaction. If no output is redirected, this 94 | -- attack fails. 95 | datumHijackingAttackAll :: 96 | forall owner owner' m. 97 | (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => 98 | -- | Predicate to select outputs to steal, depending on the intended 99 | -- recipient, the datum, and the value. 100 | (TxSkelOut -> Bool) -> 101 | -- | The selection predicate may match more than one output. Use this 102 | -- predicate to restrict to the i-th of the outputs (counting from the left, 103 | -- starting at zero) chosen by the selection predicate with this predicate. 104 | (Integer -> Bool) -> 105 | -- | The thief 106 | owner' -> 107 | m [TxSkelOut] 108 | datumHijackingAttackAll change select thief = do 109 | redirected <- redirectOutputTweakAll @owner (\output -> if change output then Just thief else Nothing) select 110 | guard . not $ null redirected 111 | addLabelTweak $ DatumHijackingLbl $ Script.toCredential thief 112 | return redirected 113 | 114 | -- | A version of datumHijackingAttackAll relying on the rules of 115 | -- 'redirectOutputTweakAny'. 116 | datumHijackingAttackAny :: 117 | forall owner owner' m. 118 | (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => 119 | -- | Predicate to select outputs to steal, depending on the intended 120 | -- recipient, the datum, and the value. 121 | (TxSkelOut -> Bool) -> 122 | -- | The selection predicate may match more than one output. Use this 123 | -- predicate to restrict to the i-th of the outputs (counting from the left, 124 | -- starting at zero) chosen by the selection predicate with this predicate. 125 | (Integer -> Bool) -> 126 | -- | The thief 127 | owner' -> 128 | m TxSkelOut 129 | datumHijackingAttackAny change select thief = do 130 | redirected <- redirectOutputTweakAny @owner (\output -> if change output then Just thief else Nothing) select 131 | addLabelTweak $ DatumHijackingLbl $ Script.toCredential thief 132 | return redirected 133 | 134 | -- | The default datum hijacking attack. It tries to redirect any output for 135 | -- which the owner is of type @owner@ and branches at each attempt. 136 | datumHijackingAttack :: 137 | forall owner owner' m. 138 | (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => 139 | owner' -> 140 | m TxSkelOut 141 | datumHijackingAttack = datumHijackingAttackAny @owner (const True) (const True) 142 | 143 | -- | A label that is added to a 'TxSkel' that has successfully been modified by 144 | -- any of the datum hijacking attacks 145 | newtype DatumHijackingLbl = DatumHijackingLbl Api.Credential 146 | deriving (Show, Eq, Ord) 147 | 148 | instance PrettyCooked DatumHijackingLbl where 149 | prettyCookedOpt opts (DatumHijackingLbl address) = "DatumHijacking" <+> prettyCookedOpt opts address 150 | -------------------------------------------------------------------------------- /src/Cooked/Attack/DoubleSat.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | This module provides an automated attack to try and perform double 4 | -- satisfaction on a contract. 5 | module Cooked.Attack.DoubleSat 6 | ( DoubleSatDelta, 7 | DoubleSatLbl (..), 8 | doubleSatAttack, 9 | ) 10 | where 11 | 12 | import Cooked.MockChain.BlockChain 13 | import Cooked.Pretty 14 | import Cooked.Skeleton 15 | import Cooked.Tweak 16 | import Cooked.Wallet 17 | import Data.Map (Map) 18 | import Data.Map qualified as Map 19 | import Optics.Core 20 | import PlutusLedgerApi.V1.Value qualified as Api 21 | import PlutusLedgerApi.V3 qualified as Api 22 | import PlutusTx.Numeric qualified as PlutusTx 23 | 24 | {- Note: What is a double satisfaction attack? 25 | 26 | A double satisfaction attack consists in trying to satisfy the requirements for 27 | what conceptually are two transactions in a single transaction, and doing so 28 | incompletely. It succeeds whenever the requirements of two validators ovelap, 29 | but the required outputs of the transaction are not sufficiently unique, so that 30 | both validators see them as satisfying "their" requirement. 31 | 32 | The mechanism is explained very well in the following analogy from the Plutus 33 | documentation: "Suppose that two tax auditors from two different departments 34 | come to visit you in turn to see if you’ve paid your taxes. You come up with a 35 | clever scheme to confuse them. Your tax liability to both departments is $10, so 36 | you make a single payment to the tax office’s bank account for $10. When the 37 | auditors arrive, you show them your books, containing the payment to the tax 38 | office. They both leave satisfied." 39 | 40 | The double satisfaction attack 'doubleSatAttack' provided by this module works 41 | by going through the foci of some optic on the 'TxSkel' representing the 42 | transaction from the left to the right, and adding some extra inputs, outputs, 43 | and mints depending on each focus and the current 'MockChainSt'ate. -} 44 | 45 | -- | A triplet of transaction inputs, transaction outputs, and minted 46 | -- value. This is what we can add to the transaction in order to try a double 47 | -- satisfaction attack. 48 | type DoubleSatDelta = (Map Api.TxOutRef TxSkelRedeemer, [TxSkelOut], TxSkelMints) 49 | 50 | instance {-# OVERLAPPING #-} Semigroup DoubleSatDelta where 51 | (i, o, m) <> (i', o', m') = 52 | ( i <> i', -- this is left-biased union 53 | o ++ o', 54 | m <> m' -- see the 'Semigroup' instance of 'TxSkelMints' 55 | ) 56 | 57 | instance {-# OVERLAPPING #-} Monoid DoubleSatDelta where 58 | mempty = (Map.empty, [], mempty) 59 | 60 | -- | Double satisfaction attack. See the comment above for what such an 61 | -- attack is about conceptually. 62 | -- 63 | -- This attack consists in adding some extra constraints to a transaction, and 64 | -- hoping that the additional minting policies or validator scripts thereby 65 | -- involved are fooled by what's already present on the transaction. Any extra 66 | -- value contained in new inputs to the transaction is then paid to the 67 | -- attacker. 68 | doubleSatAttack :: 69 | (MonadTweak m, Eq is, Is k A_Traversal) => 70 | -- | how to combine modifications from caused by different foci. See the 71 | -- comment at 'combineModsTweak', which uses the same logic. 72 | ([is] -> [[is]]) -> 73 | -- | Each focus of this optic is a potential reason to add some extra 74 | -- constraints. 75 | Optic' k (WithIx is) TxSkel a -> 76 | -- | How to change each focus, and which inputs, outputs, and mints to add, 77 | -- for each of the foci. There might be different options for each focus, 78 | -- that's why the return value is a list. 79 | -- 80 | -- Continuing the example, for each of the focused script outputs, you might 81 | -- want to try adding some script inputs to the transaction. Since it might be 82 | -- interesting to try different redeemers on these extra script inputs, you 83 | -- can just provide a list of all the options you want to try adding for a 84 | -- given script output that's already on the transaction. 85 | -- 86 | -- ################################### 87 | -- 88 | -- ATTENTION: If you modify the state while computing these lists, the 89 | -- behaviour of the 'doubleSatAttack' might be strange: Any modification of 90 | -- the state that happens on any call to this function will be applied to all 91 | -- returned transactions. For example, if you 92 | -- 'Cooked.MockChain.BlockChain.awaitSlot' in any of these computations, the 93 | -- 'doubleSatAttack' will wait for all returned transactions. 94 | -- 95 | -- TODO: Make this interface safer, for example by using (some kind of) an 96 | -- 'Cooked.MockChain.UtxoState.UtxoState' argument. 97 | -- 98 | -- ################################### 99 | (is -> a -> m [(a, DoubleSatDelta)]) -> 100 | -- | The wallet of the attacker, where any surplus is paid to. 101 | -- 102 | -- In the example, the extra value in the added input will be paid to the 103 | -- attacker. 104 | Wallet -> 105 | m () 106 | doubleSatAttack groupings optic change attacker = do 107 | deltas <- combineModsTweak groupings optic change 108 | let delta = joinDoubleSatDeltas deltas 109 | addDoubleSatDeltaTweak delta 110 | addedValue <- deltaBalance delta 111 | if addedValue `Api.gt` mempty 112 | then addOutputTweak $ attacker `receives` Value addedValue 113 | else failingTweak 114 | addLabelTweak DoubleSatLbl 115 | where 116 | -- for each triple of additional inputs, outputs, and mints, 117 | -- calculate its balance 118 | deltaBalance :: (MonadTweak m) => DoubleSatDelta -> m Api.Value 119 | deltaBalance (inputs, outputs, mints) = do 120 | inValue <- foldMap (txSkelOutValue . snd) . filter ((`elem` Map.keys inputs) . fst) <$> allUtxos 121 | return $ inValue <> PlutusTx.negate outValue <> mintValue 122 | where 123 | outValue = foldOf (traversed % txSkelOutValueL % txSkelOutValueContentL) outputs 124 | mintValue = txSkelMintsValue mints 125 | 126 | -- Helper tweak to add a 'DoubleSatDelta' to a transaction 127 | addDoubleSatDeltaTweak :: (MonadTweak m) => DoubleSatDelta -> m () 128 | addDoubleSatDeltaTweak (ins, outs, mints) = 129 | mapM_ (uncurry addInputTweak) (Map.toList ins) 130 | >> mapM_ addOutputTweak outs 131 | >> mapM_ addMintTweak (txSkelMintsToList mints) 132 | 133 | -- Join a list of 'DoubleSatDelta's into one 'DoubleSatDelta' that specifies 134 | -- eveything that is contained in the input. 135 | joinDoubleSatDeltas :: [DoubleSatDelta] -> DoubleSatDelta 136 | joinDoubleSatDeltas = mconcat 137 | 138 | -- | A label that is added to a 'TxSkel' that has successfully been modified by 139 | -- the 'doubleSatAttack' 140 | data DoubleSatLbl = DoubleSatLbl 141 | deriving (Eq, Show, Ord) 142 | 143 | instance PrettyCooked DoubleSatLbl where 144 | prettyCooked _ = "DoubleSat" 145 | -------------------------------------------------------------------------------- /src/Cooked/Attack/DupToken.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides an automated attack to duplicate tokens minted in a 2 | -- transaction. 3 | module Cooked.Attack.DupToken (dupTokenAttack, DupTokenLbl (..)) where 4 | 5 | import Control.Monad 6 | import Cooked.Pretty 7 | import Cooked.Skeleton 8 | import Cooked.Tweak 9 | import Optics.Core 10 | import Plutus.Script.Utils.Scripts qualified as Script 11 | import PlutusLedgerApi.V1.Value qualified as Api 12 | 13 | -- | A token duplication attack increases values in 'Mint' constraints of a 14 | -- 'TxSkel' according to some conditions, and pays the extra minted value to a 15 | -- given recipient wallet. This adds a 'DupTokenLbl' to the labels of the 16 | -- transaction using 'addLabelTweak'. Returns the 'Value' by which the minted 17 | -- value was increased. 18 | dupTokenAttack :: 19 | (MonadTweak m, OwnerConstrs o) => 20 | -- | A function describing how the amount of tokens specified by a 'Mint' 21 | -- constraint should be changed, depending on the asset class and the amount 22 | -- specified by the constraint. The given function @f@ should probably satisfy 23 | -- @f ac i > i@ for all @ac@ and @i@, i.e. it should increase the minted 24 | -- amount. If it does *not* increase the minted amount, the amount will be 25 | -- left unchanged. 26 | (Api.AssetClass -> Integer -> Integer) -> 27 | -- | The wallet of the attacker. Any additional tokens that are minted by the 28 | -- modified transaction but were not minted by the original transaction are 29 | -- paid to this wallet. 30 | o -> 31 | m Api.Value 32 | dupTokenAttack change attacker = do 33 | oldMintsList <- viewTweak $ txSkelMintsL % to txSkelMintsToList 34 | let (newMintsList, totalIncrement) = 35 | foldl 36 | ( \(newMs, addVal) (Mint mp@(Script.toCurrencySymbol . Script.toVersioned @Script.MintingPolicy -> cs) red tks) -> 37 | let (newTokensList, addValTokens) = 38 | foldl 39 | ( \(newTks, addVal') (tn, n) -> 40 | let newAmount = change (Api.assetClass cs tn) n 41 | in if newAmount > n 42 | then ((tn, newAmount) : newTks, addVal' <> Api.singleton cs tn (newAmount - n)) 43 | else ((tn, n) : newTks, addVal') 44 | ) 45 | ([], mempty) 46 | tks 47 | in (Mint mp red newTokensList : newMs, addValTokens <> addVal) 48 | ) 49 | ([], mempty) 50 | oldMintsList 51 | guard (totalIncrement /= mempty) 52 | setTweak txSkelMintsL $ txSkelMintsFromList newMintsList 53 | addOutputTweak $ attacker `receives` Value totalIncrement 54 | addLabelTweak DupTokenLbl 55 | return totalIncrement 56 | 57 | -- | A label that is added to a 'TxSkel' that has successfully been modified by 58 | -- the 'dupTokenAttack' 59 | data DupTokenLbl = DupTokenLbl 60 | deriving (Eq, Show, Ord) 61 | 62 | instance PrettyCooked DupTokenLbl where 63 | prettyCooked _ = "DupToken" 64 | -------------------------------------------------------------------------------- /src/Cooked/InitialDistribution.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a convenient way to spread assets between wallets and 2 | -- scripts at the initialization of the mock chain. These initial assets can be 3 | -- accompanied by datums, staking credentials and reference scripts. 4 | module Cooked.InitialDistribution 5 | ( InitialDistribution (..), 6 | distributionFromList, 7 | ) 8 | where 9 | 10 | import Cooked.Skeleton 11 | import Cooked.Wallet 12 | import Data.Default 13 | import Data.List (foldl') 14 | import Plutus.Script.Utils.Value qualified as Script 15 | import PlutusLedgerApi.V3 qualified as Api 16 | 17 | -- * Initial distribution of funds 18 | 19 | -- | Describes the initial distribution of UTxOs per wallet. This is important 20 | -- since transaction validation must specify a /collateral/. Hence, wallets must 21 | -- have more than one UTxO to begin with in order to execute a transaction and 22 | -- have some collateral option. The @txCollateral@ is transferred to the node 23 | -- operator in case the transaction fails to validate. 24 | -- 25 | -- The following specifies a starting state where @wallet 1@ owns two UTxOs, 26 | -- one with 42 Ada and one with 2 Ada and one "TOK" token; @wallet 2@ owns a 27 | -- single UTxO with 10 Ada and @wallet 3@ has 10 Ada and a permanent value. See 28 | -- "Cooked.Currencies" for more information on quick and permanent values. 29 | -- 30 | -- > i0 = distributionFromList $ 31 | -- > [ (wallet 1 , [ ada 42 , ada 2 <> quickValue "TOK" 1 ] 32 | -- > , (wallet 2 , [ ada 10 ]) 33 | -- > , (wallet 3 , [ ada 10 <> permanentValue "XYZ" 10]) 34 | -- > ] 35 | -- 36 | -- Note that initial distribution can lead to payments that would not be 37 | -- accepted if part of an actual transaction, such as payment without enough ada 38 | -- to sustain themselves. 39 | data InitialDistribution where 40 | InitialDistribution :: 41 | {unInitialDistribution :: [TxSkelOut]} -> 42 | InitialDistribution 43 | 44 | -- | 4 UTxOs with 100 Ada each, for each of the first 4 'knownWallets' 45 | instance Default InitialDistribution where 46 | def = distributionFromList . zip (take 4 knownWallets) . repeat . replicate 4 $ Script.ada 100 47 | 48 | instance Semigroup InitialDistribution where 49 | i <> j = InitialDistribution (unInitialDistribution i <> unInitialDistribution j) 50 | 51 | instance Monoid InitialDistribution where 52 | mempty = InitialDistribution mempty 53 | 54 | -- | Creating a initial distribution with simple values assigned to wallets 55 | distributionFromList :: [(Wallet, [Api.Value])] -> InitialDistribution 56 | distributionFromList = InitialDistribution . foldl' (\x (user, values) -> x <> map (receives user . Value) values) [] 57 | -------------------------------------------------------------------------------- /src/Cooked/MockChain.hs: -------------------------------------------------------------------------------- 1 | -- | This module centralizes everything related to our mockchain, while hiding 2 | -- elements related to logs and inner state. 3 | module Cooked.MockChain (module X) where 4 | 5 | import Cooked.MockChain.Balancing as X 6 | import Cooked.MockChain.BlockChain as X hiding 7 | ( MockChainLogEntry, 8 | logEvent, 9 | ) 10 | import Cooked.MockChain.Direct as X hiding 11 | ( MockChainReturn, 12 | ) 13 | import Cooked.MockChain.MinAda as X 14 | import Cooked.MockChain.MockChainState as X 15 | ( MockChainState (..), 16 | mockChainState0From, 17 | ) 18 | import Cooked.MockChain.Staged as X hiding 19 | ( InterpMockChain, 20 | MockChainBuiltin, 21 | StagedMockChain, 22 | ) 23 | import Cooked.MockChain.Testing as X 24 | import Cooked.MockChain.UtxoSearch as X 25 | import Cooked.MockChain.UtxoState as X hiding 26 | ( UtxoPayload, 27 | UtxoPayloadSet, 28 | UtxoState (UtxoState, availableUtxos, consumedUtxos), 29 | ) 30 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/AutoReferenceScripts.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a function to ensure that each redeemer used in a 2 | -- skeleton is attached a reference input with the right reference script when 3 | -- it exists in the index. 4 | module Cooked.MockChain.AutoReferenceScripts (toTxSkelWithReferenceScripts) where 5 | 6 | import Control.Monad 7 | import Cooked.MockChain.BlockChain 8 | import Cooked.MockChain.UtxoSearch 9 | import Cooked.Skeleton 10 | import Data.List (find) 11 | import Data.Map qualified as Map 12 | import Optics.Core 13 | import Plutus.Script.Utils.Scripts qualified as Script 14 | import PlutusLedgerApi.V3 qualified as Api 15 | 16 | -- | Attempts to find in the index a utxo containing a reference script with the 17 | -- given script hash, and attaches it to a redeemer when it does not yet have a 18 | -- reference input and when it is allowed, in which case an event is logged. 19 | updateRedeemer :: (MonadBlockChain m, Script.ToScriptHash s) => s -> [Api.TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer 20 | updateRedeemer script inputs txSkelRed@(TxSkelRedeemer _ Nothing True) = do 21 | oRefsInInputs <- runUtxoSearch (referenceScriptOutputsSearch script) 22 | maybe 23 | -- We leave the redeemer unchanged if no reference input was found 24 | (return txSkelRed) 25 | -- If a reference input is found, we assign it and log the event 26 | ( \oRef -> do 27 | logEvent $ MCLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash script) 28 | return $ txSkelRed `withReferenceInput` oRef 29 | ) 30 | $ case oRefsInInputs of 31 | [] -> Nothing 32 | -- If possible, we use a reference input appearing in regular inputs 33 | l | Just (oRefM', _) <- find (\(r, _) -> r `elem` inputs) l -> Just oRefM' 34 | -- If none exist, we use the first one we find elsewhere 35 | ((oRefM', _) : _) -> Just oRefM' 36 | updateRedeemer _ _ redeemer = return redeemer 37 | 38 | -- | Goes through the various parts of the skeleton where a redeemer can appear, 39 | -- and attempts to attach a reference input to each of them, whenever it is 40 | -- allowed and one has not already been set. 41 | toTxSkelWithReferenceScripts :: (MonadBlockChain m) => TxSkel -> m TxSkel 42 | toTxSkelWithReferenceScripts txSkel@TxSkel {..} = do 43 | let inputs = Map.keys txSkelIns 44 | newMints <- forM (txSkelMintsToList txSkelMints) $ \(Mint mPol red tks) -> 45 | (\x -> Mint mPol x tks) <$> updateRedeemer (Script.toVersioned @Script.MintingPolicy mPol) inputs red 46 | newInputs <- forM (Map.toList txSkelIns) $ \(oRef, red) -> do 47 | validatorM <- txSkelOutValidator <$> unsafeTxOutByRef oRef 48 | case validatorM of 49 | Nothing -> return (oRef, red) 50 | Just scriptHash -> (oRef,) <$> updateRedeemer scriptHash inputs red 51 | newProposals <- forM txSkelProposals $ \prop -> 52 | case prop ^. txSkelProposalWitnessL of 53 | Nothing -> return prop 54 | Just (script, red) -> flip (set txSkelProposalWitnessL) prop . Just . (script,) <$> updateRedeemer script inputs red 55 | newWithdrawals <- forM (Map.toList txSkelWithdrawals) $ \(wit, (red, quantity)) -> case wit of 56 | Right _ -> return (wit, (red, quantity)) 57 | Left script -> (Left script,) . (,quantity) <$> updateRedeemer script inputs red 58 | return $ 59 | txSkel 60 | & txSkelMintsL 61 | .~ txSkelMintsFromList newMints 62 | & txSkelInsL 63 | .~ Map.fromList newInputs 64 | & txSkelProposalsL 65 | .~ newProposals 66 | & txSkelWithdrawalsL 67 | .~ Map.fromList newWithdrawals 68 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes translation functions to transform a 'TxSkel' into a 2 | -- signed transaction 3 | module Cooked.MockChain.GenerateTx 4 | ( txSignersAndBodyToCardanoTx, 5 | txSkelToCardanoTx, 6 | ) 7 | where 8 | 9 | import Cardano.Api.Shelley qualified as Cardano 10 | import Cooked.MockChain.BlockChain 11 | import Cooked.MockChain.GenerateTx.Body 12 | import Cooked.MockChain.GenerateTx.Witness 13 | import Cooked.Skeleton 14 | import Cooked.Wallet 15 | import Data.Set (Set) 16 | import PlutusLedgerApi.V3 qualified as Api 17 | 18 | -- | Generates a Cardano transaction and signs it 19 | txSignersAndBodyToCardanoTx :: [Wallet] -> Cardano.TxBody Cardano.ConwayEra -> Cardano.Tx Cardano.ConwayEra 20 | txSignersAndBodyToCardanoTx signers txBody = Cardano.Tx txBody (toKeyWitness txBody <$> signers) 21 | 22 | -- | Generates a full Cardano transaction from a skeleton, fees and collaterals 23 | txSkelToCardanoTx :: (MonadBlockChainBalancing m) => TxSkel -> Integer -> Maybe (Set Api.TxOutRef, Wallet) -> m (Cardano.Tx Cardano.ConwayEra) 24 | txSkelToCardanoTx txSkel fee mCollaterals = 25 | txSignersAndBodyToCardanoTx (txSkelSigners txSkel) <$> txSkelToTxBody txSkel fee mCollaterals 26 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx/Collateral.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the generation of transaction collaterals, which 2 | -- consist of a collateral amount, collateral inputs and return collateral 3 | module Cooked.MockChain.GenerateTx.Collateral where 4 | 5 | import Cardano.Api qualified as Cardano 6 | import Cardano.Api.Ledger qualified as Cardano 7 | import Cardano.Api.Shelley qualified as Cardano hiding (Testnet) 8 | import Cardano.Ledger.Conway.Core qualified as Conway 9 | import Cardano.Node.Emulator.Internal.Node qualified as Emulator 10 | import Control.Monad 11 | import Cooked.MockChain.BlockChain 12 | import Cooked.MockChain.GenerateTx.Common 13 | import Cooked.Wallet 14 | import Data.Set (Set) 15 | import Data.Set qualified as Set 16 | import Ledger.Tx.CardanoAPI qualified as Ledger 17 | import Lens.Micro.Extras qualified as MicroLens 18 | import Plutus.Script.Utils.Address qualified as Script 19 | import Plutus.Script.Utils.Value qualified as Script 20 | import PlutusLedgerApi.V3 qualified as Api 21 | import PlutusTx.Numeric qualified as PlutusTx 22 | 23 | -- | Computes the collateral triplet from the fees and the collateral inputs in 24 | -- the context. What we call a collateral triplet is composed of: 25 | -- * The set of collateral inputs 26 | -- * The total collateral paid by the transaction in case of phase 2 failure 27 | -- * An output returning excess collateral value when collaterals are used 28 | -- These quantity should satisfy the equation (in terms of their values): 29 | -- collateral inputs = total collateral + return collateral 30 | toCollateralTriplet :: 31 | (MonadBlockChainBalancing m) => 32 | Integer -> 33 | Maybe (Set Api.TxOutRef, Wallet) -> 34 | m 35 | ( Cardano.TxInsCollateral Cardano.ConwayEra, 36 | Cardano.TxTotalCollateral Cardano.ConwayEra, 37 | Cardano.TxReturnCollateral Cardano.CtxTx Cardano.ConwayEra 38 | ) 39 | toCollateralTriplet _ Nothing = return (Cardano.TxInsCollateralNone, Cardano.TxTotalCollateralNone, Cardano.TxReturnCollateralNone) 40 | toCollateralTriplet fee (Just (Set.toList -> collateralInsList, returnCollateralWallet)) = do 41 | -- We build the collateral inputs from this list 42 | txInsCollateral <- 43 | case collateralInsList of 44 | [] -> return Cardano.TxInsCollateralNone 45 | l -> throwOnToCardanoError "toCollateralTriplet" $ Cardano.TxInsCollateral Cardano.AlonzoEraOnwardsConway <$> mapM Ledger.toCardanoTxIn l 46 | -- Retrieving the total value in collateral inputs. This fails if one of the 47 | -- collateral inputs has not been successfully resolved. 48 | collateralInsValue <- 49 | foldM (\val -> ((val <>) <$>) . unsafeValueFromTxOutRef) mempty collateralInsList 50 | -- We retrieve the collateral percentage compared to fees. By default, we use 51 | -- 150% which is the current value in the parameters, although the default 52 | -- value should never be used here, as the call is supposed to always succeed. 53 | collateralPercentage <- toInteger . MicroLens.view Conway.ppCollateralPercentageL . Emulator.pEmulatorPParams <$> getParams 54 | -- The total collateral corresponds to the fees multiplied by the collateral 55 | -- percentage. We add 1 because the ledger apparently rounds up this value. 56 | let coinTotalCollateral = 1 + (fee * collateralPercentage) `div` 100 57 | -- We create the total collateral based on the computed value 58 | let txTotalCollateral = Cardano.TxTotalCollateral Cardano.BabbageEraOnwardsConway $ Cardano.Coin coinTotalCollateral 59 | -- We compute a return collateral value by subtracting the total collateral to 60 | -- the value in collateral inputs 61 | let returnCollateralValue = collateralInsValue <> PlutusTx.negate (Script.lovelace coinTotalCollateral) 62 | -- The return collateral is then computed 63 | txReturnCollateral <- 64 | -- If the total collateral equal what the inputs provide, we return 65 | -- `TxReturnCollateralNone`, otherwise, we compute the new output 66 | if returnCollateralValue == mempty 67 | then return Cardano.TxReturnCollateralNone 68 | else do 69 | -- The value is a translation of the remaining value 70 | txReturnCollateralValue <- 71 | Ledger.toCardanoTxOutValue 72 | <$> throwOnToCardanoError 73 | "toCollateralTriplet: cannot build return collateral value" 74 | (Ledger.toCardanoValue returnCollateralValue) 75 | -- The address is the one from the return collateral wallet, which is 76 | -- required to exist here. 77 | networkId <- Emulator.pNetworkId <$> getParams 78 | address <- 79 | throwOnToCardanoError "toCollateralTriplet: cannot build return collateral address" $ 80 | Ledger.toCardanoAddressInEra networkId (Script.toAddress returnCollateralWallet) 81 | -- The return collateral is built up from those elements 82 | return $ 83 | Cardano.TxReturnCollateral Cardano.BabbageEraOnwardsConway $ 84 | Cardano.TxOut address txReturnCollateralValue Cardano.TxOutDatumNone Cardano.ReferenceScriptNone 85 | return (txInsCollateral, txTotalCollateral, txReturnCollateral) 86 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx/Common.hs: -------------------------------------------------------------------------------- 1 | -- | Common utilities used to transfer generation errors raised by plutus-ledger 2 | -- into instances of 'MockChainError' 3 | module Cooked.MockChain.GenerateTx.Common 4 | ( throwOnToCardanoErrorOrApply, 5 | throwOnToCardanoError, 6 | ) 7 | where 8 | 9 | import Control.Monad.Except 10 | import Cooked.MockChain.BlockChain 11 | import Ledger.Tx qualified as Ledger 12 | 13 | -- | Lifts a 'Ledger.ToCardanoError' with an associated error message, or apply a 14 | -- function if a value exists. 15 | throwOnToCardanoErrorOrApply :: (MonadError MockChainError m) => String -> (a -> b) -> Either Ledger.ToCardanoError a -> m b 16 | throwOnToCardanoErrorOrApply errorMsg f = either (throwError . MCEToCardanoError errorMsg) (return . f) 17 | 18 | -- | Lifts a 'Ledger.ToCardanoError' with an associated error message, or leaves 19 | -- the value unchanged if it exists. 20 | throwOnToCardanoError :: (MonadError MockChainError m) => String -> Either Ledger.ToCardanoError a -> m a 21 | throwOnToCardanoError = flip throwOnToCardanoErrorOrApply id 22 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx/Input.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the generation of transaction inputs 2 | module Cooked.MockChain.GenerateTx.Input (toTxInAndWitness) where 3 | 4 | import Cardano.Api qualified as Cardano 5 | import Cooked.MockChain.BlockChain 6 | import Cooked.MockChain.GenerateTx.Common 7 | import Cooked.MockChain.GenerateTx.Witness 8 | import Cooked.Skeleton 9 | import Ledger.Tx.CardanoAPI qualified as Ledger 10 | import PlutusLedgerApi.V3 qualified as Api 11 | 12 | -- | Converts a 'TxSkel' input, which consists of a 'Api.TxOutRef' and a 13 | -- 'TxSkelRedeemer', into a 'Cardano.TxIn', together with the appropriate witness. 14 | toTxInAndWitness :: 15 | (MonadBlockChainBalancing m) => 16 | (Api.TxOutRef, TxSkelRedeemer) -> 17 | m (Cardano.TxIn, Cardano.BuildTxWith Cardano.BuildTx (Cardano.Witness Cardano.WitCtxTxIn Cardano.ConwayEra)) 18 | toTxInAndWitness (txOutRef, txSkelRedeemer) = do 19 | TxSkelOut (toPKHOrValidator -> owner) _ datum _ _ <- unsafeTxOutByRef txOutRef 20 | witness <- case owner of 21 | Left _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending 22 | Right validator -> 23 | fmap (Cardano.ScriptWitness Cardano.ScriptWitnessForSpending) $ 24 | toScriptWitness validator txSkelRedeemer $ 25 | case datum of 26 | TxSkelOutNoDatum -> Cardano.ScriptDatumForTxIn Nothing 27 | TxSkelOutSomeDatum _ Inline -> Cardano.InlineScriptDatum 28 | TxSkelOutSomeDatum dat _ -> Cardano.ScriptDatumForTxIn $ Just $ Ledger.toCardanoScriptData $ Api.toBuiltinData dat 29 | throwOnToCardanoErrorOrApply 30 | "toTxInAndWitness: Unable to translate TxOutRef" 31 | (,Cardano.BuildTxWith witness) 32 | (Ledger.toCardanoTxIn txOutRef) 33 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx/Mint.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the generation of a transaction minted value 2 | module Cooked.MockChain.GenerateTx.Mint (toMintValue) where 3 | 4 | import Cardano.Api qualified as Cardano 5 | import Control.Monad 6 | import Cooked.MockChain.BlockChain 7 | import Cooked.MockChain.GenerateTx.Common 8 | import Cooked.MockChain.GenerateTx.Witness 9 | import Cooked.Skeleton 10 | import Data.Map qualified as Map 11 | import Data.Map.NonEmpty qualified as NEMap 12 | import Data.Map.Strict qualified as SMap 13 | import GHC.Exts (fromList) 14 | import Ledger.Tx.CardanoAPI qualified as Ledger 15 | import Plutus.Script.Utils.Scripts qualified as Script 16 | import PlutusLedgerApi.V3 qualified as Api 17 | import PlutusTx.Builtins.Internal qualified as PlutusTx 18 | import Test.QuickCheck.Modifiers (NonZero (NonZero)) 19 | 20 | -- | Converts a 'TxSkelMints' into a 'Cardano.TxMintValue' 21 | toMintValue :: (MonadBlockChainBalancing m) => TxSkelMints -> m (Cardano.TxMintValue Cardano.BuildTx Cardano.ConwayEra) 22 | toMintValue mints | null mints = return Cardano.TxMintNone 23 | toMintValue mints = fmap (Cardano.TxMintValue Cardano.MaryEraOnwardsConway . SMap.fromList) $ 24 | forM (Map.toList mints) $ \(policy, (red, Map.toList . NEMap.toMap -> assets)) -> do 25 | policyId <- 26 | throwOnToCardanoError 27 | "toMintValue: Unable to translate minting policy hash" 28 | (Ledger.toCardanoPolicyId $ Script.toMintingPolicyHash policy) 29 | mintWitness <- Cardano.BuildTxWith <$> toScriptWitness policy red Cardano.NoScriptDatumForMint 30 | return 31 | ( policyId, 32 | ( fromList 33 | [ (Cardano.AssetName name, Cardano.Quantity quantity) 34 | | (Api.TokenName (PlutusTx.BuiltinByteString name), NonZero quantity) <- assets 35 | ], 36 | mintWitness 37 | ) 38 | ) 39 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx/Output.hs: -------------------------------------------------------------------------------- 1 | -- | This modules exposes the generation of transaction outputs 2 | module Cooked.MockChain.GenerateTx.Output (toCardanoTxOut) where 3 | 4 | import Cardano.Api.Shelley qualified as Cardano 5 | import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator 6 | import Cooked.MockChain.BlockChain 7 | import Cooked.MockChain.GenerateTx.Common 8 | import Cooked.Skeleton 9 | import Ledger.Tx.CardanoAPI qualified as Ledger 10 | import Optics.Core 11 | import Plutus.Script.Utils.Data qualified as Script 12 | import Plutus.Script.Utils.Scripts qualified as Script 13 | import PlutusLedgerApi.V3 qualified as Api 14 | 15 | -- | Converts a 'TxSkelOut' to the corresponding 'Cardano.TxOut' 16 | toCardanoTxOut :: (MonadBlockChainBalancing m) => TxSkelOut -> m (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) 17 | toCardanoTxOut output = do 18 | let oAddress = txSkelOutAddress output 19 | oValue = txSkelOutValue output 20 | oDatum = output ^. txSkelOutDatumL 21 | oRefScript = txSkelOutReferenceScript output 22 | networkId <- Emulator.pNetworkId <$> getParams 23 | address <- 24 | throwOnToCardanoError 25 | ("toCardanoTxOut: Unable to translate the following address: " <> show oAddress) 26 | (Ledger.toCardanoAddressInEra networkId oAddress) 27 | (Ledger.toCardanoTxOutValue -> value) <- 28 | throwOnToCardanoError 29 | ("toCardanoTxOut: Unable to translate the following value:" <> show oValue) 30 | (Ledger.toCardanoValue oValue) 31 | datum <- case oDatum of 32 | TxSkelOutNoDatum -> return Cardano.TxOutDatumNone 33 | TxSkelOutSomeDatum datum (Hashed NotResolved) -> 34 | Cardano.TxOutDatumHash Cardano.AlonzoEraOnwardsConway 35 | <$> throwOnToCardanoError 36 | "toCardanoTxOut: Unable to resolve/transate a datum hash." 37 | (Ledger.toCardanoScriptDataHash $ Script.datumHash $ Api.Datum $ Api.toBuiltinData datum) 38 | TxSkelOutSomeDatum datum (Hashed Resolved) -> return $ Cardano.TxOutSupplementalDatum Cardano.AlonzoEraOnwardsConway $ Ledger.toCardanoScriptData $ Api.toBuiltinData datum 39 | TxSkelOutSomeDatum datum Inline -> return $ Cardano.TxOutDatumInline Cardano.BabbageEraOnwardsConway $ Ledger.toCardanoScriptData $ Api.toBuiltinData datum 40 | return $ Cardano.TxOut address value datum $ Ledger.toCardanoReferenceScript (Script.toVersioned <$> oRefScript) 41 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx/ReferenceInputs.hs: -------------------------------------------------------------------------------- 1 | -- | This module allows the generation of Cardano reference inputs 2 | module Cooked.MockChain.GenerateTx.ReferenceInputs (toInsReference) where 3 | 4 | import Cardano.Api qualified as Cardano 5 | import Cooked.MockChain.BlockChain 6 | import Cooked.MockChain.GenerateTx.Common 7 | import Cooked.Skeleton 8 | import Data.Map qualified as Map 9 | import Data.Set qualified as Set 10 | import Ledger.Tx.CardanoAPI qualified as Ledger 11 | import PlutusLedgerApi.V3 qualified as Api 12 | 13 | -- | Takes a 'TxSkel' and generates the associated 'Cardano.TxInsReference' from 14 | -- its content. These reference inputs can be found in two places, either in 15 | -- direct reference inputs 'txSkelInsReference' or scattered in the various 16 | -- redeemers of the transaction, which can be gathered with 17 | -- 'txSkelInsReferenceInRedeemers'. 18 | toInsReference :: (MonadBlockChainBalancing m) => TxSkel -> m (Cardano.TxInsReference Cardano.BuildTx Cardano.ConwayEra) 19 | toInsReference skel = do 20 | -- As regular inputs can be used to hold scripts as if in reference inputs, we 21 | -- need to remove from the reference inputs stored in redeemers the ones that 22 | -- already appear in the inputs to avoid validation errors. 23 | let indirectReferenceInputs = txSkelInsReferenceInRedeemers skel 24 | redundantReferenceInputs = indirectReferenceInputs `Set.intersection` Map.keysSet (txSkelIns skel) 25 | refInputs = Set.toList (txSkelInsReference skel <> indirectReferenceInputs `Set.difference` redundantReferenceInputs) 26 | if null refInputs 27 | then return Cardano.TxInsReferenceNone 28 | else do 29 | cardanoRefInputs <- 30 | throwOnToCardanoError 31 | "toInsReference: Unable to translate reference inputs." 32 | (mapM Ledger.toCardanoTxIn refInputs) 33 | resolvedOutputs <- mapM unsafeDatumFromTxOutRef refInputs 34 | return $ 35 | Cardano.TxInsReference Cardano.BabbageEraOnwardsConway cardanoRefInputs $ 36 | Cardano.BuildTxWith $ 37 | Set.fromList 38 | [Ledger.toCardanoScriptData $ Api.toBuiltinData dat | TxSkelOutSomeDatum dat (Hashed _) <- resolvedOutputs] 39 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx/Withdrawals.hs: -------------------------------------------------------------------------------- 1 | -- | This modules exposes the generation of withdrawals 2 | module Cooked.MockChain.GenerateTx.Withdrawals (toWithdrawals) where 3 | 4 | import Cardano.Api qualified as Cardano 5 | import Cardano.Api.Ledger qualified as Cardano 6 | import Cardano.Api.Shelley qualified as Cardano 7 | import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator 8 | import Control.Monad 9 | import Cooked.MockChain.BlockChain 10 | import Cooked.MockChain.GenerateTx.Common 11 | import Cooked.MockChain.GenerateTx.Witness 12 | import Cooked.Skeleton 13 | import Data.Map qualified as Map 14 | import Ledger.Tx.CardanoAPI qualified as Ledger 15 | import Plutus.Script.Utils.Scripts qualified as Script 16 | import PlutusLedgerApi.V1.Value qualified as Api 17 | 18 | -- | Takes a 'TxSkelWithdrawals' and transforms it into a 'Cardano.TxWithdrawals' 19 | toWithdrawals :: (MonadBlockChainBalancing m) => TxSkelWithdrawals -> m (Cardano.TxWithdrawals Cardano.BuildTx Cardano.ConwayEra) 20 | toWithdrawals (Map.toList -> []) = return Cardano.TxWithdrawalsNone 21 | toWithdrawals (Map.toList -> withdrawals) = 22 | fmap 23 | (Cardano.TxWithdrawals Cardano.ShelleyBasedEraConway) 24 | $ forM withdrawals 25 | $ \(staker, (red, Api.Lovelace n)) -> 26 | do 27 | (witness, sCred) <- 28 | case staker of 29 | Right pkh -> do 30 | sCred <- 31 | throwOnToCardanoError "toWithdrawals: unable to translate pkh stake credential" $ 32 | Cardano.StakeCredentialByKey <$> Ledger.toCardanoStakeKeyHash pkh 33 | return (Cardano.KeyWitness Cardano.KeyWitnessForStakeAddr, sCred) 34 | Left script -> do 35 | witness <- 36 | Cardano.ScriptWitness Cardano.ScriptWitnessForStakeAddr 37 | <$> toScriptWitness script red Cardano.NoScriptDatumForStake 38 | sCred <- 39 | throwOnToCardanoError "toWithdrawals: unable to translate script stake credential" $ 40 | Cardano.StakeCredentialByScript <$> Ledger.toCardanoScriptHash (Script.toScriptHash script) 41 | return (witness, sCred) 42 | networkId <- Emulator.pNetworkId <$> getParams 43 | return (Cardano.makeStakeAddress networkId sCred, Cardano.Coin n, Cardano.BuildTxWith witness) 44 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/GenerateTx/Witness.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the generation of witnesses and reward account 2 | module Cooked.MockChain.GenerateTx.Witness 3 | ( toRewardAccount, 4 | toScriptWitness, 5 | toKeyWitness, 6 | ) 7 | where 8 | 9 | import Cardano.Api.Ledger qualified as Cardano 10 | import Cardano.Api.Shelley qualified as Cardano hiding (Testnet) 11 | import Control.Monad.Except (throwError) 12 | import Cooked.MockChain.BlockChain 13 | import Cooked.MockChain.GenerateTx.Common 14 | import Cooked.Skeleton 15 | import Cooked.Wallet 16 | import Ledger.Address qualified as Ledger 17 | import Ledger.Tx.CardanoAPI qualified as Ledger 18 | import Plutus.Script.Utils.Scripts qualified as Script 19 | import PlutusLedgerApi.V3 qualified as Api 20 | 21 | -- | Translates a given credential to a reward account. 22 | toRewardAccount :: (MonadBlockChainBalancing m) => Api.Credential -> m Cardano.RewardAccount 23 | toRewardAccount cred = 24 | Cardano.RewardAccount Cardano.Testnet <$> case cred of 25 | Api.ScriptCredential scriptHash -> do 26 | Cardano.ScriptHash cHash <- 27 | throwOnToCardanoError 28 | "toRewardAccount: Unable to convert script hash." 29 | (Ledger.toCardanoScriptHash scriptHash) 30 | return $ Cardano.ScriptHashObj cHash 31 | Api.PubKeyCredential pubkeyHash -> do 32 | Cardano.StakeKeyHash pkHash <- 33 | throwOnToCardanoError 34 | "toRewardAccount: Unable to convert private key hash." 35 | (Ledger.toCardanoStakeKeyHash pubkeyHash) 36 | return $ Cardano.KeyHashObj pkHash 37 | 38 | -- | Translates a script and a reference script utxo into either a plutus script 39 | -- or a reference input containing the right script 40 | toPlutusScriptOrReferenceInput :: (MonadBlockChainBalancing m) => Script.Versioned Script.Script -> Maybe Api.TxOutRef -> m (Cardano.PlutusScriptOrReferenceInput lang) 41 | toPlutusScriptOrReferenceInput (Script.Versioned (Script.Script script) _) Nothing = return $ Cardano.PScript $ Cardano.PlutusScriptSerialised script 42 | toPlutusScriptOrReferenceInput (Script.toScriptHash -> scriptHash) (Just scriptOutRef) = do 43 | (fmap Script.toScriptHash . txSkelOutReferenceScript -> mScriptHash) <- unsafeTxOutByRef scriptOutRef 44 | case mScriptHash of 45 | Just scriptHash' 46 | | scriptHash == scriptHash' -> 47 | Cardano.PReferenceScript 48 | <$> throwOnToCardanoError 49 | "toPlutusScriptOrReferenceInput: Unable to translate reference script utxo." 50 | (Ledger.toCardanoTxIn scriptOutRef) 51 | _ -> throwError $ MCEWrongReferenceScriptError scriptOutRef scriptHash mScriptHash 52 | 53 | -- | Translates a script with its associated redeemer and datum to a script 54 | -- witness. Note on the usage of 'Ledger.zeroExecutionUnits': at this stage of 55 | -- the transaction create, we cannot know the execution units used by the 56 | -- script. They will be filled out later on once the full body has been 57 | -- generated. So, for now, we temporarily leave them to 0. 58 | toScriptWitness :: (MonadBlockChainBalancing m, Script.ToVersioned Script.Script a) => a -> TxSkelRedeemer -> Cardano.ScriptDatum b -> m (Cardano.ScriptWitness b Cardano.ConwayEra) 59 | toScriptWitness (Script.toVersioned -> script@(Script.Versioned _ version)) (TxSkelRedeemer {..}) datum = do 60 | let scriptData = Ledger.toCardanoScriptData $ Api.toBuiltinData txSkelRedeemerContent 61 | case version of 62 | Script.PlutusV1 -> 63 | (\x -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV1InConway Cardano.PlutusScriptV1 x datum scriptData Ledger.zeroExecutionUnits) 64 | <$> toPlutusScriptOrReferenceInput script txSkelRedeemerReferenceInput 65 | Script.PlutusV2 -> 66 | (\x -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV2InConway Cardano.PlutusScriptV2 x datum scriptData Ledger.zeroExecutionUnits) 67 | <$> toPlutusScriptOrReferenceInput script txSkelRedeemerReferenceInput 68 | Script.PlutusV3 -> 69 | (\x -> Cardano.PlutusScriptWitness Cardano.PlutusScriptV3InConway Cardano.PlutusScriptV3 x datum scriptData Ledger.zeroExecutionUnits) 70 | <$> toPlutusScriptOrReferenceInput script txSkelRedeemerReferenceInput 71 | 72 | -- | Generates a list of witnesses for a given wallet and body 73 | toKeyWitness :: Cardano.TxBody Cardano.ConwayEra -> Wallet -> Cardano.KeyWitness Cardano.ConwayEra 74 | toKeyWitness txBody = 75 | Cardano.makeShelleyKeyWitness Cardano.ShelleyBasedEraConway txBody 76 | . Ledger.toWitness 77 | . Ledger.PaymentPrivateKey 78 | . walletSK 79 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/MinAda.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides functions to ensure skeleton outputs contain enough 2 | -- ada to satisfy the minimum ada constraint. 3 | module Cooked.MockChain.MinAda 4 | ( toTxSkelOutWithMinAda, 5 | toTxSkelWithMinAda, 6 | getTxSkelOutMinAda, 7 | ) 8 | where 9 | 10 | import Cardano.Api qualified as Cardano 11 | import Cardano.Api.Ledger qualified as Cardano 12 | import Cardano.Api.Shelley qualified as Cardano 13 | import Cardano.Ledger.Shelley.Core qualified as Shelley 14 | import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator 15 | import Control.Monad 16 | import Cooked.MockChain.BlockChain 17 | import Cooked.MockChain.GenerateTx.Output 18 | import Cooked.Skeleton 19 | import Optics.Core 20 | import Plutus.Script.Utils.Value qualified as Script 21 | import PlutusLedgerApi.V1.Value qualified as Api 22 | 23 | -- | Compute the required minimal ADA for a given output 24 | getTxSkelOutMinAda :: (MonadBlockChainBalancing m) => TxSkelOut -> m Integer 25 | getTxSkelOutMinAda txSkelOut = do 26 | params <- Emulator.pEmulatorPParams <$> getParams 27 | Cardano.unCoin 28 | . Shelley.getMinCoinTxOut params 29 | . Cardano.toShelleyTxOut Cardano.ShelleyBasedEraConway 30 | . Cardano.toCtxUTxOTxOut 31 | <$> toCardanoTxOut txSkelOut 32 | 33 | -- | This transforms an output into another output which contains the minimal 34 | -- required ada. If the previous quantity of ADA was sufficient, it remains 35 | -- unchanged. This can require a few iterations to converge, as the added ADA 36 | -- will increase the size of the UTXO which in turn might need more ADA. 37 | toTxSkelOutWithMinAda :: (MonadBlockChainBalancing m) => TxSkelOut -> m TxSkelOut 38 | -- The auto adjustment is disabled so nothing is done here 39 | toTxSkelOutWithMinAda txSkelOut@((^. txSkelOutValueL % txSkelOutValueAutoAdjustL) -> False) = return txSkelOut 40 | -- The auto adjustment is enabled 41 | toTxSkelOutWithMinAda txSkelOut = do 42 | txSkelOut' <- go txSkelOut 43 | let originalAda = txSkelOutValue txSkelOut ^. Script.adaL 44 | updatedAda = txSkelOutValue txSkelOut' ^. Script.adaL 45 | when (originalAda /= updatedAda) $ logEvent $ MCLogAdjustedTxSkelOut txSkelOut updatedAda 46 | return txSkelOut' 47 | where 48 | go :: (MonadBlockChainBalancing m) => TxSkelOut -> m TxSkelOut 49 | go skelOut = do 50 | -- Computing the required minimal amount of ADA in this output 51 | requiredAda <- getTxSkelOutMinAda skelOut 52 | -- If this amount is sufficient, we return Nothing, otherwise, we adjust the 53 | -- output and possibly iterate 54 | if Api.getLovelace (skelOut ^. txSkelOutValueL % txSkelOutValueContentL % Script.adaL) >= requiredAda 55 | then return skelOut 56 | else go $ skelOut & txSkelOutValueL % txSkelOutValueContentL % Script.adaL .~ Api.Lovelace requiredAda 57 | 58 | -- | This goes through all the `TxSkelOut`s of the given skeleton and updates 59 | -- their ada value when requested by the user and required by the protocol 60 | -- parameters. 61 | toTxSkelWithMinAda :: (MonadBlockChainBalancing m) => TxSkel -> m TxSkel 62 | toTxSkelWithMinAda skel = (\x -> skel & txSkelOutsL .~ x) <$> forM (skel ^. txSkelOutsL) toTxSkelOutWithMinAda 63 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/MockChainState.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the internal state in which our direct simulation is 2 | -- run, and functions to update and query it. 3 | module Cooked.MockChain.MockChainState 4 | ( MockChainState (..), 5 | mcstParamsL, 6 | mcstLedgerStateL, 7 | mcstOutputsL, 8 | mcstConstitutionL, 9 | mcstToUtxoState, 10 | addOutput, 11 | removeOutput, 12 | mockChainState0From, 13 | mockChainState0, 14 | ) 15 | where 16 | 17 | import Cardano.Api qualified as Cardano 18 | import Cardano.Api.Shelley qualified as Cardano 19 | import Cardano.Ledger.Shelley.API qualified as Shelley 20 | import Cardano.Node.Emulator.Internal.Node qualified as Emulator 21 | import Control.Lens qualified as Lens 22 | import Control.Monad.Except 23 | import Cooked.InitialDistribution 24 | import Cooked.MockChain.BlockChain 25 | import Cooked.MockChain.GenerateTx 26 | import Cooked.MockChain.GenerateTx.Output 27 | import Cooked.MockChain.MinAda 28 | import Cooked.MockChain.UtxoState 29 | import Cooked.Skeleton 30 | import Data.Default 31 | import Data.Map.Strict (Map) 32 | import Data.Map.Strict qualified as Map 33 | import Ledger.Index qualified as Ledger 34 | import Ledger.Orphans () 35 | import Ledger.Tx qualified as Ledger 36 | import Ledger.Tx.CardanoAPI qualified as Ledger 37 | import Optics.Core 38 | import Optics.TH 39 | import Plutus.Script.Utils.Scripts qualified as Script 40 | import PlutusLedgerApi.V3 qualified as Api 41 | 42 | -- | The state used to run the simulation in 'Cooked.MockChain.Direct' 43 | data MockChainState = MockChainState 44 | { mcstParams :: Emulator.Params, 45 | mcstLedgerState :: Emulator.EmulatedLedgerState, 46 | -- | Associates to each 'Api.TxOutRef' the 'TxSkelOut' that produced it, 47 | -- alongside a boolean to state whether this UTxO is still present in the 48 | -- index ('True') or has already been consumed ('False'). 49 | mcstOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), 50 | -- | The constitution script to be used with proposals 51 | mcstConstitution :: Maybe (Script.Versioned Script.Script) 52 | } 53 | deriving (Show) 54 | 55 | -- | A lens to set or get the parameters of the 'MockChainState' 56 | makeLensesFor [("mcstParams", "mcstParamsL")] ''MockChainState 57 | 58 | -- | A lens to set or get the ledger state of the 'MockChainState' 59 | makeLensesFor [("mcstLedgerState", "mcstLedgerStateL")] ''MockChainState 60 | 61 | -- | A lens to set or get the outputs of the 'MockChainState' 62 | makeLensesFor [("mcstOutputs", "mcstOutputsL")] ''MockChainState 63 | 64 | -- | A lens to set or get the constitution script of the 'MockChainState' 65 | makeLensesFor [("mcstConstitution", "mcstConstitutionL")] ''MockChainState 66 | 67 | instance Default MockChainState where 68 | def = MockChainState def (Emulator.initialState def) Map.empty Nothing 69 | 70 | -- | Builds a 'UtxoState' from a 'MockChainState' 71 | mcstToUtxoState :: MockChainState -> UtxoState 72 | mcstToUtxoState = 73 | foldl extractPayload mempty . Map.toList . mcstOutputs 74 | where 75 | extractPayload :: UtxoState -> (Api.TxOutRef, (TxSkelOut, Bool)) -> UtxoState 76 | extractPayload utxoState (txOutRef, (txSkelOut, bool)) = 77 | let newAddress = txSkelOutAddress txSkelOut 78 | newPayloadSet = 79 | UtxoPayloadSet 80 | [ UtxoPayload 81 | txOutRef 82 | (txSkelOutValue txSkelOut) 83 | ( case txSkelOut ^. txSkelOutDatumL of 84 | TxSkelOutNoDatum -> Nothing 85 | TxSkelOutSomeDatum content Inline -> Just (content, False) 86 | TxSkelOutSomeDatum content _ -> Just (content, True) 87 | ) 88 | (txSkelOutReferenceScriptHash txSkelOut) 89 | ] 90 | in if bool 91 | then utxoState {availableUtxos = Map.insertWith (<>) newAddress newPayloadSet (availableUtxos utxoState)} 92 | else utxoState {consumedUtxos = Map.insertWith (<>) newAddress newPayloadSet (consumedUtxos utxoState)} 93 | 94 | -- | Stores an output in a 'MockChainState' 95 | addOutput :: Api.TxOutRef -> TxSkelOut -> MockChainState -> MockChainState 96 | addOutput oRef txSkelOut = over mcstOutputsL (Map.insert oRef (txSkelOut, True)) 97 | 98 | -- | Removes an output from the 'MockChainState' 99 | removeOutput :: Api.TxOutRef -> MockChainState -> MockChainState 100 | removeOutput oRef = over mcstOutputsL (Map.update (\(output, _) -> Just (output, False)) oRef) 101 | 102 | -- | This creates the initial 'MockChainState' from an initial distribution by 103 | -- submitting an initial transaction with the appropriate content. The genesis 104 | -- key hash has been taken from 105 | -- https://github.com/input-output-hk/cardano-node/blob/543b267d75d3d448e1940f9ec04b42bd01bbb16b/cardano-api/test/Test/Cardano/Api/Genesis.hs#L60 106 | mockChainState0From :: (MonadBlockChainBalancing m) => InitialDistribution -> m MockChainState 107 | mockChainState0From (InitialDistribution initDist) = do 108 | params <- getParams 109 | let genesisKeyHash = Cardano.GenesisUTxOKeyHash $ Shelley.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194" 110 | inputs = [(Cardano.genesisUTxOPseudoTxIn (Emulator.pNetworkId params) genesisKeyHash, Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending)] 111 | outputsMinAda <- mapM toTxSkelOutWithMinAda initDist 112 | outputs <- mapM toCardanoTxOut outputsMinAda 113 | cardanoTx <- 114 | Ledger.CardanoEmulatorEraTx . txSignersAndBodyToCardanoTx [] 115 | <$> either 116 | (throwError . MCEToCardanoError "generateTx :") 117 | return 118 | (Emulator.createTransactionBody params $ Ledger.CardanoBuildTx (Ledger.emptyTxBodyContent {Cardano.txOuts = outputs, Cardano.txIns = inputs})) 119 | let index = Ledger.fromPlutusIndex $ Ledger.initialise [[Emulator.unsafeMakeValid cardanoTx]] 120 | outputsMap = 121 | Map.fromList $ 122 | zipWith 123 | (\x y -> (x, (y, True))) 124 | (Ledger.fromCardanoTxIn . snd <$> Ledger.getCardanoTxOutRefs cardanoTx) 125 | outputsMinAda 126 | return $ MockChainState def (Lens.set Emulator.elsUtxoL index (Emulator.initialState def)) outputsMap Nothing 127 | 128 | -- | Same as 'mockChainState0From' with the default 'InitialDistribution' 129 | mockChainState0 :: (MonadBlockChainBalancing m) => m MockChainState 130 | mockChainState0 = mockChainState0From def 131 | -------------------------------------------------------------------------------- /src/Cooked/MockChain/UtxoState.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a depiction of the state we return when running a 2 | -- 'Cooked.BlockChain.Direct.MockChain'. 3 | module Cooked.MockChain.UtxoState 4 | ( UtxoState (..), 5 | UtxoPayloadSet (..), 6 | UtxoPayload (..), 7 | holdsInState, 8 | ) 9 | where 10 | 11 | import Cooked.Skeleton.Datum 12 | import Data.Function (on) 13 | import Data.List qualified as List 14 | import Data.Map.Strict (Map) 15 | import Data.Map.Strict qualified as Map 16 | import Plutus.Script.Utils.Address qualified as Script 17 | import PlutusLedgerApi.V1.Value qualified as Api 18 | import PlutusLedgerApi.V3 qualified as Api 19 | 20 | -- | A description of who owns what in a blockchain. Owners are addresses and 21 | -- they each own a 'UtxoPayloadSet'. 22 | data UtxoState = UtxoState 23 | { availableUtxos :: Map Api.Address UtxoPayloadSet, 24 | consumedUtxos :: Map Api.Address UtxoPayloadSet 25 | } 26 | deriving (Eq) 27 | 28 | -- | Total value accessible to what's pointed by the address. 29 | holdsInState :: (Script.ToAddress a) => a -> UtxoState -> Api.Value 30 | holdsInState (Script.toAddress -> address) = maybe mempty utxoPayloadSetTotal . Map.lookup address . availableUtxos 31 | 32 | instance Semigroup UtxoState where 33 | (UtxoState a c) <> (UtxoState a' c') = UtxoState (Map.unionWith (<>) a a') (Map.unionWith (<>) c c') 34 | 35 | instance Monoid UtxoState where 36 | mempty = UtxoState Map.empty Map.empty 37 | 38 | -- | Represents a /set/ of payloads. 39 | newtype UtxoPayloadSet = UtxoPayloadSet 40 | { -- | List of UTxOs contained in this 'UtxoPayloadSet' 41 | utxoPayloadSet :: [UtxoPayload] 42 | -- We use a list instead of a set because 'Api.Value' doesn't implement 'Ord' 43 | -- and because it is possible that we want to distinguish between utxo states 44 | -- that have additional utxos, even if these could have been merged together. 45 | } 46 | deriving (Show) 47 | 48 | -- | A convenient wrapping of the interesting information of a UTxO. 49 | data UtxoPayload = UtxoPayload 50 | { -- | The reference of this UTxO 51 | utxoPayloadTxOutRef :: Api.TxOutRef, 52 | -- | The value stored in this UTxO 53 | utxoPayloadValue :: Api.Value, 54 | -- | The optional datum stored in this UTxO and whether it is hashed 55 | -- ('True') or inline ('False') 56 | utxoPayloadDatum :: Maybe (DatumContent, Bool), 57 | -- | The optional reference script stored in this UTxO 58 | utxoPayloadReferenceScript :: Maybe Api.ScriptHash 59 | } 60 | deriving (Eq, Show) 61 | 62 | instance Eq UtxoPayloadSet where 63 | (UtxoPayloadSet xs) == (UtxoPayloadSet ys) = xs' == ys' 64 | where 65 | k (UtxoPayload ref val dat rs) = (ref, Api.flattenValue val, dat, rs) 66 | xs' = List.sortBy (compare `on` k) xs 67 | ys' = List.sortBy (compare `on` k) ys 68 | 69 | instance Semigroup UtxoPayloadSet where 70 | UtxoPayloadSet a <> UtxoPayloadSet b = UtxoPayloadSet $ a ++ b 71 | 72 | instance Monoid UtxoPayloadSet where 73 | mempty = UtxoPayloadSet [] 74 | 75 | -- | Computes the total value in a set 76 | utxoPayloadSetTotal :: UtxoPayloadSet -> Api.Value 77 | utxoPayloadSetTotal = mconcat . fmap utxoPayloadValue . utxoPayloadSet 78 | -------------------------------------------------------------------------------- /src/Cooked/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes off-chain pretty-printing functions for transaction 2 | -- skeletons, utxo states, addresses, pubkey hashes, values, etc. 3 | -- 4 | -- We provide the 'PrettyCooked' class and instances for common Plutus types. 5 | -- We don't rely on 'PP.Pretty' from "Prettyprinter" in order to define better 6 | -- printers for Plutus types which already have instances of 'PP.Pretty'. Also, 7 | -- 'PrettyCooked' makes it possible to optionally modify pretty printing 8 | -- settings 'PrettyCookedOpts' (e.g. length of printed hashes). 9 | -- 10 | -- == Requirements on datum and redeemers 11 | -- 12 | -- Datums and redeemers are required to have a 'PrettyCooked' instance. 13 | -- 14 | -- For trivial datatypes, you can rely on Show by using 'PrettyPrinter.viaShow' 15 | -- from "Prettyprinter": @prettyCooked = Prettyprinter.viaShow@. 16 | -- 17 | -- For more complex datatypes, you can rely on existing 'PrettyCooked' 18 | -- instances. Prefer implementing the 'prettyCookedOpt' function and relay the 19 | -- 'PrettyCookedOpts' settings to other printers. 20 | -- 21 | -- @ data Foo = Bar Api.Value | Baz Api.PubkeyHash Api.Value 22 | -- 23 | -- instance PrettyCooked Foo where 24 | -- prettyCookedOpt pcOpts (Bar value) = 25 | -- "Bar" <+> prettyCookedOpt pcOpts value 26 | -- prettyCookedOpt pcOpts (Baz pkh value) = 27 | -- prettyItemize 28 | -- "Baz" 29 | -- "-" 30 | -- [ "user:" <+> prettyCookedOpt pcOpts pkh, 31 | -- "deposit:" <+> prettyCookedOpt pcOpts value ] 32 | -- @ 33 | -- 34 | -- The 'prettyItemize' function is useful to nicely lay down nested lists of 35 | -- elements. Since we manipulate regular 'PrettyPrinter.Doc' values, any 36 | -- function from "Prettyprinter" can be used to implement your printers. 37 | -- 38 | -- == How to pretty print? 39 | -- 40 | -- Pretty printing of transaction skeletons and UTxO states is done 41 | -- automatically by the end-user functions provided in 42 | -- "Cooked.MockChain.Testing". 43 | -- 44 | -- To do it manually, use instances of 'PrettyCooked', 'PrettyCookedList' or 45 | -- 'PrettyCookedMaybe' defined in 'Cooked.Pretty.Skeleton' or 46 | -- 'Cooked.Pretty.MockChain' such as the one for @MockChainReturn a UtxoState@. 47 | module Cooked.Pretty (module X) where 48 | 49 | import Cooked.Pretty.Class as X 50 | import Cooked.Pretty.Hashable as X 51 | import Cooked.Pretty.MockChain as X () 52 | import Cooked.Pretty.Options as X 53 | import Cooked.Pretty.Plutus as X () 54 | import Cooked.Pretty.Skeleton as X () 55 | -------------------------------------------------------------------------------- /src/Cooked/Pretty/Hashable.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides an interface for plutus elements that can be 2 | -- hashed. This is used to provide aliases for hashes when pretty printing those 3 | -- elements. 4 | module Cooked.Pretty.Hashable where 5 | 6 | import Cooked.Wallet 7 | import Plutus.Script.Utils.Address qualified as Script 8 | import Plutus.Script.Utils.Data qualified as Script 9 | import Plutus.Script.Utils.Scripts qualified as Script 10 | import Plutus.Script.Utils.V1.Typed qualified as Script 11 | import Plutus.Script.Utils.V3.Typed qualified as Script 12 | import PlutusLedgerApi.V3 qualified as Api 13 | 14 | -- | Hashable elements can be transformed to 'Api.BuiltinByteString' 15 | class ToHash a where 16 | toHash :: a -> Api.BuiltinByteString 17 | 18 | instance ToHash Api.BuiltinByteString where 19 | toHash = id 20 | 21 | instance ToHash Api.CurrencySymbol where 22 | toHash = Api.unCurrencySymbol 23 | 24 | instance ToHash Api.TokenName where 25 | toHash = Api.unTokenName 26 | 27 | instance ToHash Api.PubKeyHash where 28 | toHash = Api.getPubKeyHash 29 | 30 | instance ToHash Wallet where 31 | toHash = toHash . Script.toPubKeyHash 32 | 33 | instance ToHash (Script.Versioned Script.MintingPolicy) where 34 | toHash = toHash . Script.toCurrencySymbol 35 | 36 | instance ToHash (Script.Versioned Script.Script) where 37 | toHash = toHash . Script.toScriptHash 38 | 39 | instance ToHash Script.ScriptHash where 40 | toHash = Script.getScriptHash 41 | 42 | instance ToHash Script.ValidatorHash where 43 | toHash = Script.getValidatorHash 44 | 45 | instance ToHash (Script.TypedValidator a) where 46 | toHash = toHash . Script.tvValidatorHash 47 | 48 | instance ToHash Api.DatumHash where 49 | toHash (Api.DatumHash hash) = hash 50 | 51 | instance ToHash Api.Datum where 52 | toHash = toHash . Script.datumHash 53 | 54 | instance ToHash Api.BuiltinData where 55 | toHash = toHash . Script.dataHash 56 | 57 | instance ToHash Api.TxId where 58 | toHash = Api.getTxId 59 | 60 | instance ToHash (Script.MultiPurposeScript a) where 61 | toHash = toHash . Script.toVersioned @Script.Script 62 | -------------------------------------------------------------------------------- /src/Cooked/Pretty/Options.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines pretty-printing options for 2 | -- 'Cooked.Pretty.Class.prettyCookedOpt' and their default values. 3 | module Cooked.Pretty.Options 4 | ( PrettyCookedOpts (..), 5 | PrettyCookedHashOpts (..), 6 | PCOptTxOutRefs (..), 7 | hashNamesFromList, 8 | defaultHashNames, 9 | addHashNames, 10 | ) 11 | where 12 | 13 | import Cooked.Pretty.Hashable 14 | import Cooked.Wallet 15 | import Data.Bifunctor (first) 16 | import Data.Default 17 | import Data.Map (Map) 18 | import Data.Map qualified as Map 19 | import Plutus.Script.Utils.Scripts qualified as Script 20 | import Plutus.Script.Utils.V1.Generators qualified as ScriptV1 21 | import Plutus.Script.Utils.V2.Generators qualified as ScriptV2 22 | import Plutus.Script.Utils.V3.Generators qualified as ScriptV3 23 | import PlutusLedgerApi.V3 qualified as Api 24 | 25 | -- | A set of option to pilot pretty printing in cooked-validators 26 | data PrettyCookedOpts = PrettyCookedOpts 27 | { -- | Whether to print transaction ids of validated transactions. By 28 | -- default: False 29 | pcOptPrintTxHashes :: Bool, 30 | -- | Whether to print transaction outputs references. By default: hidden 31 | pcOptPrintTxOutRefs :: PCOptTxOutRefs, 32 | -- | Whether to print tx options that have not been modified from their 33 | -- default. By default: False 34 | pcOptPrintDefaultTxOpts :: Bool, 35 | -- | Whether to print big integers with numeric underscores. For example 36 | -- @53_000_000@ instead of @53000000@. By default: True 37 | pcOptNumericUnderscores :: Bool, 38 | -- | Options related to printing hashes 39 | pcOptHashes :: PrettyCookedHashOpts, 40 | -- | Whether to display the log 41 | pcOptPrintLog :: Bool, 42 | -- | Whether to display consumed UTxOs in the end state. Default: False 43 | pcOptPrintConsumedUTxOs :: Bool 44 | } 45 | deriving (Eq, Show) 46 | 47 | instance Default PrettyCookedOpts where 48 | def = 49 | PrettyCookedOpts 50 | { pcOptPrintTxHashes = False, 51 | pcOptPrintTxOutRefs = PCOptTxOutRefsHidden, 52 | pcOptPrintDefaultTxOpts = False, 53 | pcOptNumericUnderscores = True, 54 | pcOptHashes = def, 55 | pcOptPrintLog = True, 56 | pcOptPrintConsumedUTxOs = False 57 | } 58 | 59 | -- | Whether to print transaction outputs references. 60 | data PCOptTxOutRefs 61 | = -- | Hide them 62 | PCOptTxOutRefsHidden 63 | | -- | Always show them. 64 | -- 65 | -- Warning: this will disable printing similar UTxOs as a group (for 66 | -- instance @(×10) Lovelace: 100_000_000@) 67 | PCOptTxOutRefsFull 68 | | -- | Show them for UTxOs which are not grouped with similar others. This 69 | -- avoids the downside of 'PCOptTxOutRefsFull' which disables printing UTxOs 70 | -- as a group. 71 | PCOptTxOutRefsPartial 72 | deriving (Eq, Show) 73 | 74 | -- | A set of options to pilot how hashes are pretty printed 75 | data PrettyCookedHashOpts = PrettyCookedHashOpts 76 | { -- | Length of printed hash prefix. By default: 7 77 | pcOptHashLength :: Int, 78 | -- | Association between hashes and given names to ease readability. For 79 | -- example @Map.singleton (walletPKHash (wallet 1)) "Alice"@ By default: 80 | -- "defaultHashNames" which assigns Lovelace, Quick, and Permanent as names 81 | -- for the associated currency symbols 82 | pcOptHashNames :: Map Api.BuiltinByteString String, 83 | -- | When a given name exists for a hash, this flag also prints the original 84 | -- hash after the name. By default: @False@ 85 | pcOptHashVerbose :: Bool 86 | } 87 | deriving (Eq, Show) 88 | 89 | instance Default PrettyCookedHashOpts where 90 | def = 91 | PrettyCookedHashOpts 92 | { pcOptHashLength = 7, 93 | pcOptHashNames = defaultHashNames, 94 | pcOptHashVerbose = False 95 | } 96 | 97 | -- | Default hash to names map that assigns Lovelace, Quick, and Permanent to 98 | -- the associated currency symbols. This is used as the default for the 99 | -- pretty-printing option and is recommended to use as a basis to extend with 100 | -- custom names. 101 | defaultHashNames :: Map Api.BuiltinByteString String 102 | defaultHashNames = 103 | hashNamesFromList 104 | [ (Api.CurrencySymbol "", "Lovelace"), 105 | (ScriptV1.alwaysSucceedCurrencySymbol, "QuickV1"), 106 | (ScriptV2.alwaysSucceedCurrencySymbol, "QuickV2"), 107 | (Script.toCurrencySymbol ScriptV3.trueMintingMPScript, "QuickV3"), 108 | (ScriptV1.alwaysFailCurrencySymbol, "PermanentV1"), 109 | (ScriptV2.alwaysFailCurrencySymbol, "PermanentV2"), 110 | (Script.toCurrencySymbol ScriptV3.falseMPScript, "PermanentV3") 111 | ] 112 | <> hashNamesFromList 113 | ((\i -> (wallet i, "wallet " <> show i)) <$> [1 .. 10]) 114 | 115 | -- | Smart constructor for maps to be used in the "pcOptHashNames" 116 | -- pretty-printing option. 117 | hashNamesFromList :: (ToHash a) => [(a, String)] -> Map Api.BuiltinByteString String 118 | hashNamesFromList = Map.fromList . map (first toHash) 119 | 120 | -- | Adds some additional names to these pretty cooked options. This has two 121 | -- practical use cases: 122 | -- 123 | -- * Users can use it in conjuction to 'hashNamesFromList' without having to 124 | -- remember to manually invoke 'defaultHashNames' 125 | -- 126 | -- * We use it internally to account for names that have been registered during 127 | -- mockchain runs, such as for names that depend on on-chain data, typically a 128 | -- 'Api.TxOutRef'. 129 | addHashNames :: Map Api.BuiltinByteString String -> PrettyCookedOpts -> PrettyCookedOpts 130 | addHashNames names opts'@(PrettyCookedOpts _ _ _ _ hashOpts _ _) = 131 | opts' {pcOptHashes = hashOpts {pcOptHashNames = Map.union names (pcOptHashNames hashOpts)}} 132 | -------------------------------------------------------------------------------- /src/Cooked/Pretty/Plutus.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | This module provides 'PrettyCooked' instances of plutus types 4 | module Cooked.Pretty.Plutus where 5 | 6 | import Cooked.Pretty.Class 7 | import Ledger.Index qualified as Ledger 8 | import Ledger.Scripts qualified as Ledger 9 | import Ledger.Tx.CardanoAPI qualified as Ledger 10 | import PlutusLedgerApi.V1.Value qualified as Api 11 | import PlutusLedgerApi.V3 qualified as Api 12 | import Prettyprinter ((<+>)) 13 | import Prettyprinter qualified as PP 14 | 15 | -- * Pretty instances for data types coming from plutus-ledger-api 16 | 17 | instance PrettyCooked Api.BuiltinData where 18 | prettyCookedOpt _ = PP.pretty 19 | 20 | instance PrettyCooked Api.TxOutRef where 21 | prettyCookedOpt opts (Api.TxOutRef txId index) = 22 | prettyHash opts txId <> "!" <> prettyCookedOpt opts index 23 | 24 | instance PrettyCooked Api.Address where 25 | prettyCookedOpt opts (Api.Address addrCr Nothing) = prettyCookedOpt opts addrCr 26 | prettyCookedOpt opts (Api.Address addrCr (Just (Api.StakingHash stakCr))) = 27 | prettyCookedOpt opts addrCr <+> PP.angles ("staking:" <+> prettyCookedOpt opts stakCr) 28 | prettyCookedOpt opts (Api.Address addrCr (Just (Api.StakingPtr p1 p2 p3))) = 29 | prettyCookedOpt opts addrCr <+> PP.angles ("staking:" <+> PP.pretty (p1, p2, p3)) 30 | 31 | instance PrettyCooked Api.Credential where 32 | prettyCookedOpt opts (Api.ScriptCredential vh) = "script" <+> prettyHash opts vh 33 | prettyCookedOpt opts (Api.PubKeyCredential pkh) = "pubkey" <+> prettyHash opts pkh 34 | 35 | instance PrettyCooked Api.Value where 36 | -- Example output: 37 | -- 38 | -- > Value: 39 | -- > - Lovelace: 45_000_000 40 | -- > - Quick "hello": 3 41 | -- > - #12bc3d "usertoken": 1 42 | -- 43 | -- In case of an empty value (even though not an empty map): 44 | -- > Empty value 45 | prettyCookedOpt opts = 46 | prettySingletons 47 | . map prettySingletonValue 48 | . filter (\(_, _, n) -> n /= 0) 49 | . Api.flattenValue 50 | where 51 | prettySingletons :: [DocCooked] -> DocCooked 52 | prettySingletons [] = "Empty value" 53 | prettySingletons [doc] = doc 54 | prettySingletons docs = prettyItemize opts "Value:" "-" docs 55 | prettySingletonValue :: (Api.CurrencySymbol, Api.TokenName, Integer) -> DocCooked 56 | prettySingletonValue (symbol, name, amount) = 57 | prettyCookedOpt opts (Api.AssetClass (symbol, name)) <> ":" <+> prettyCookedOpt opts amount 58 | 59 | instance PrettyCooked Api.AssetClass where 60 | prettyCookedOpt opts (Api.AssetClass (symbol, _)) | symbol == Api.adaSymbol = prettyHash opts symbol 61 | prettyCookedOpt opts (Api.AssetClass (symbol, name)) = prettyHash opts symbol <+> prettyHash opts name 62 | 63 | instance PrettyCooked Api.POSIXTime where 64 | prettyCookedOpt opts (Api.POSIXTime n) = "POSIXTime" <+> prettyCookedOpt opts n 65 | 66 | -- * Pretty instances for evalution error coming from plutus-ledger 67 | 68 | instance PrettyCooked Ledger.ValidationPhase where 69 | prettyCookedOpt _ Ledger.Phase1 = "Phase 1" 70 | prettyCookedOpt _ Ledger.Phase2 = "Phase 2" 71 | 72 | instance PrettyCooked Ledger.ValidationError where 73 | prettyCookedOpt opts (Ledger.TxOutRefNotFound txIn) = "TxOutRef not found" <+> prettyCookedOpt opts (Ledger.fromCardanoTxIn txIn) 74 | prettyCookedOpt opts (Ledger.ScriptFailure scriptError) = "Script failure" <+> prettyCookedOpt opts scriptError 75 | prettyCookedOpt _ (Ledger.CardanoLedgerValidationError text) = "Cardano ledger validation error " <+> PP.pretty text 76 | prettyCookedOpt _ Ledger.MaxCollateralInputsExceeded = "Max collateral inputs exceeded" 77 | 78 | instance PrettyCooked Ledger.ScriptError where 79 | prettyCookedOpt _ (Ledger.EvaluationError text string) = "Evaluation error" <+> PP.pretty text <+> PP.pretty string 80 | prettyCookedOpt _ (Ledger.EvaluationException string1 string2) = "Evaluation exception" <+> PP.pretty string1 <+> PP.pretty string2 81 | -------------------------------------------------------------------------------- /src/Cooked/Skeleton/Datum.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the notion of datums as they are handled within a 2 | -- 'Cooked.Skeleton.TxSkel' 3 | module Cooked.Skeleton.Datum 4 | ( DatumConstrs, 5 | DatumContent (..), 6 | datumContentToDatum, 7 | datumContentToDatumHash, 8 | DatumResolved (..), 9 | DatumKind (..), 10 | TxSkelOutDatum (..), 11 | txSkelOutDatumHash, 12 | txSkelOutUntypedDatum, 13 | datumContentTypedDatumAT, 14 | txSkelOutDatumContentAT, 15 | txSkelOutTypedDatumAT, 16 | ) 17 | where 18 | 19 | import Cooked.Pretty.Class 20 | import Data.Typeable (cast) 21 | import Optics.Core 22 | import Plutus.Script.Utils.Data qualified as Script 23 | import PlutusLedgerApi.V3 qualified as Api 24 | import PlutusTx.Prelude qualified as PlutusTx 25 | import Type.Reflection 26 | 27 | -- * Type constraints on datums used in cooked-validators 28 | 29 | -- | Type constraints that must be satisfied by the datum content 30 | type DatumConstrs a = 31 | ( Show a, 32 | PrettyCooked a, 33 | Api.ToData a, 34 | PlutusTx.Eq a, 35 | Typeable a 36 | ) 37 | 38 | -- * Wrapping datums of arbitrary types satisfying 'DatumConstrs' 39 | 40 | -- | Data type of wrapped datums satisfying 'DatumConstrs' 41 | data DatumContent where 42 | -- | Wraps an element satisfying 'DatumConstrs' 43 | DatumContent :: (DatumConstrs a) => a -> DatumContent 44 | 45 | deriving instance Show DatumContent 46 | 47 | instance Api.ToData DatumContent where 48 | toBuiltinData (DatumContent dat) = Api.toBuiltinData dat 49 | 50 | -- | Extracts the datum from a 'DatumContent' 51 | datumContentToDatum :: DatumContent -> Api.Datum 52 | datumContentToDatum = Api.Datum . Api.toBuiltinData 53 | 54 | -- | Extracts the datum hash from a 'DatumContent' 55 | datumContentToDatumHash :: DatumContent -> Api.DatumHash 56 | datumContentToDatumHash = Script.datumHash . datumContentToDatum 57 | 58 | -- | Extracts a typed datum for a 'DatumContent' when of the right type 59 | datumContentTypedDatumAT :: (DatumConstrs a) => AffineTraversal' DatumContent a 60 | datumContentTypedDatumAT = 61 | atraversal 62 | (\c@(DatumContent content) -> maybe (Left c) Right (cast content)) 63 | (const DatumContent) 64 | 65 | instance Ord DatumContent where 66 | compare (DatumContent d1) (DatumContent d2) = 67 | case compare (SomeTypeRep (typeOf d1)) (SomeTypeRep (typeOf d2)) of 68 | EQ -> compare (Api.toBuiltinData d1) (Api.toBuiltinData d2) 69 | a -> a 70 | 71 | instance Eq DatumContent where 72 | d1 == d2 = compare d1 d2 == EQ 73 | 74 | -- * Datum placement within a transaction 75 | 76 | -- | Whether the datum should be resolved in the transaction 77 | data DatumResolved 78 | = -- | Do not resolve the datum (absent from 'Api.txInfoData') 79 | NotResolved 80 | | -- | Resolve the datum (present from 'Api.txInfoData') 81 | Resolved 82 | deriving (Show, Eq, Ord) 83 | 84 | -- | Options on how to include the datum in the transaction 85 | data DatumKind 86 | = -- | Include the full datum in the UTxO 87 | Inline 88 | | -- | Only include the datum hash in the UTxO. Resolve, or do not resolve, 89 | -- the full datum in the transaction body. 90 | Hashed DatumResolved 91 | deriving (Show, Eq, Ord) 92 | 93 | -- * 'Cooked.Skeleton.TxSkel' datums 94 | 95 | -- | Datums to be placed in 'Cooked.Skeleton.TxSkel' outputs, which are either 96 | -- empty, or composed of a datum content and its placement 97 | data TxSkelOutDatum where 98 | -- | use no datum 99 | TxSkelOutNoDatum :: TxSkelOutDatum 100 | -- | use some datum content and associated placement 101 | TxSkelOutSomeDatum :: DatumContent -> DatumKind -> TxSkelOutDatum 102 | deriving (Eq, Show, Ord) 103 | 104 | instance Script.ToOutputDatum TxSkelOutDatum where 105 | toOutputDatum TxSkelOutNoDatum = Api.NoOutputDatum 106 | toOutputDatum (TxSkelOutSomeDatum datum Inline) = Api.OutputDatum $ Api.Datum $ Api.toBuiltinData datum 107 | toOutputDatum (TxSkelOutSomeDatum datum _) = Api.OutputDatumHash $ Script.datumHash $ Api.Datum $ Api.toBuiltinData datum 108 | 109 | -- | Extracts or changes the 'DatumContent' of a 'TxSkelOutDatum' 110 | txSkelOutDatumContentAT :: AffineTraversal' TxSkelOutDatum DatumContent 111 | txSkelOutDatumContentAT = 112 | atraversal 113 | ( \case 114 | TxSkelOutNoDatum -> Left TxSkelOutNoDatum 115 | TxSkelOutSomeDatum content _ -> Right content 116 | ) 117 | ( flip 118 | ( \content -> \case 119 | TxSkelOutNoDatum -> TxSkelOutNoDatum 120 | TxSkelOutSomeDatum _ kind -> TxSkelOutSomeDatum content kind 121 | ) 122 | ) 123 | 124 | -- | Converts a 'TxSkelOutDatum' into a possible Plutus datum 125 | txSkelOutUntypedDatum :: TxSkelOutDatum -> Maybe Api.Datum 126 | txSkelOutUntypedDatum = fmap datumContentToDatum . preview txSkelOutDatumContentAT 127 | 128 | -- | Converts a 'TxSkelOutDatum' into a possible Plutus datum hash 129 | txSkelOutDatumHash :: TxSkelOutDatum -> Maybe Api.DatumHash 130 | txSkelOutDatumHash = fmap datumContentToDatumHash . preview txSkelOutDatumContentAT 131 | 132 | -- | Extracts or changes the inner typed datum of a 'TxSkelOutDatum' 133 | txSkelOutTypedDatumAT :: (DatumConstrs a) => AffineTraversal' TxSkelOutDatum a 134 | txSkelOutTypedDatumAT = txSkelOutDatumContentAT % datumContentTypedDatumAT 135 | -------------------------------------------------------------------------------- /src/Cooked/Skeleton/Label.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the labels that can be used to stamp 2 | -- 'Cooked.Skeleton.TxSkel' with additional arbitrary pieces of information. 3 | module Cooked.Skeleton.Label 4 | ( LabelConstrs, 5 | TxLabel (..), 6 | ) 7 | where 8 | 9 | import Cooked.Pretty.Class 10 | import Type.Reflection 11 | 12 | -- | These are type constraints that must be satisfied by labels 13 | type LabelConstrs x = (PrettyCooked x, Show x, Typeable x, Eq x, Ord x) 14 | 15 | -- | Labels are arbitrary information that can be added to skeleton. They are 16 | -- meant to be pretty-printed. The common use case we currently have is to tag 17 | -- skeletons that have been modified by tweaks and automated attacks. 18 | data TxLabel where 19 | TxLabel :: (LabelConstrs x) => x -> TxLabel 20 | 21 | instance Eq TxLabel where 22 | a == x = compare a x == EQ 23 | 24 | instance Show TxLabel where 25 | show (TxLabel x) = show x 26 | 27 | instance PrettyCooked TxLabel where 28 | prettyCookedOpt opts (TxLabel x) = prettyCookedOpt opts x 29 | 30 | instance Ord TxLabel where 31 | compare (TxLabel a) (TxLabel x) = 32 | case compare (SomeTypeRep (typeOf a)) (SomeTypeRep (typeOf x)) of 33 | LT -> LT 34 | GT -> GT 35 | EQ -> case typeOf a `eqTypeRep` typeOf x of 36 | Just HRefl -> compare a x 37 | -- This can never happen, since 'eqTypeRep' is implemented in terms of 38 | -- '==' on the type representation: 39 | Nothing -> error "Type representations compare as EQ, but are not eqTypeRep" 40 | -------------------------------------------------------------------------------- /src/Cooked/Skeleton/Payable.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines the notion of 'Payable' elements with consist of the 2 | -- user API to build payments in a 'Cooked.Skeleton.TxSkel' 3 | module Cooked.Skeleton.Payable 4 | ( Payable (..), 5 | type (∉), 6 | type (⩀), 7 | type (∪), 8 | (<&&>), 9 | ) 10 | where 11 | 12 | import Cooked.Skeleton.Datum 13 | import Cooked.Skeleton.ReferenceScript 14 | import Data.Kind (Constraint, Type) 15 | import GHC.TypeLits 16 | import Plutus.Script.Utils.Address qualified as Script 17 | import Plutus.Script.Utils.Value qualified as Script 18 | 19 | -- | Constraint that a given type does not appear in a list of types 20 | type family (∉) (el :: a) (els :: [a]) :: Constraint where 21 | x ∉ '[] = () 22 | x ∉ (x ': xs) = TypeError ('Text "Cannot have two payable elements of type: " ':<>: 'ShowType x) 23 | x ∉ (_ ': xs) = x ∉ xs 24 | 25 | -- | Disjoint lists of types 26 | type family (⩀) (els :: [a]) (els' :: [a]) :: Constraint where 27 | '[] ⩀ _ = () 28 | (x ': xs) ⩀ ys = (x ∉ ys, xs ⩀ ys) 29 | 30 | -- | Union with duplicates, which will not occur by construction in the 31 | -- concrete implentation of 'Payable' due to the '⩀' constraint. 32 | type family (∪) (xs :: [a]) (ys :: [a]) :: [a] where 33 | '[] ∪ ys = ys 34 | (x ': xs) ∪ ys = x ': (xs ∪ ys) 35 | 36 | -- | Payable elements. Created from concrete elements or composed. Notice that 37 | -- there is no way of building an element of Type @Payable '[]@ so when using an 38 | -- element of Type @Payable els@ we are sure that something was in fact paid. 39 | data Payable :: [Symbol] -> Type where 40 | -- | Hashed datums visible in the transaction are payable 41 | VisibleHashedDatum :: (DatumConstrs a) => a -> Payable '["Datum"] 42 | -- | Inline datums are payable 43 | InlineDatum :: (DatumConstrs a) => a -> Payable '["Datum"] 44 | -- | Hashed datums hidden from the transaction are payable 45 | HiddenHashedDatum :: (DatumConstrs a) => a -> Payable '["Datum"] 46 | -- | Reference scripts are payable 47 | ReferenceScript :: (ReferenceScriptConstrs s) => s -> Payable '["Reference Script"] 48 | -- | Values are payable and are subject to min ada adjustment 49 | Value :: (Script.ToValue a) => a -> Payable '["Value"] 50 | -- | Fixed Values are payable but are NOT subject to min ada adjustment 51 | FixedValue :: (Script.ToValue a) => a -> Payable '["Value"] 52 | -- | Staking credentials are payable 53 | StakingCredential :: (Script.ToMaybeStakingCredential cred) => cred -> Payable '["Staking Credential"] 54 | -- | Payables can be combined as long as their list of tags are disjoint 55 | PayableAnd :: (els ⩀ els') => Payable els -> Payable els' -> Payable (els ∪ els') 56 | 57 | -- | An infix-usable alias for 'PayableAnd' 58 | (<&&>) :: (els ⩀ els') => Payable els -> Payable els' -> Payable (els ∪ els') 59 | (<&&>) = PayableAnd 60 | -------------------------------------------------------------------------------- /src/Cooked/Skeleton/Redeemer.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the notion of redeemers used whenever a script in 2 | -- invoked in a 'Cooked.Skeleton.TxSkel'. 3 | module Cooked.Skeleton.Redeemer 4 | ( TxSkelRedeemer (..), 5 | RedeemerConstrs, 6 | withReferenceInput, 7 | someTxSkelRedeemer, 8 | emptyTxSkelRedeemer, 9 | getTypedRedeemer, 10 | setTypedRedeemer, 11 | someTxSkelRedeemerNoAutoFill, 12 | emptyTxSkelRedeemerNoAutoFill, 13 | ) 14 | where 15 | 16 | import Cooked.Pretty.Class 17 | import Data.Typeable (Typeable, cast) 18 | import PlutusLedgerApi.V3 qualified as Api 19 | import PlutusTx.Prelude qualified as PlutusTx 20 | 21 | -- | These are the constraints that must be satisfied by the inner content of a 22 | -- redeemer, that is the actual data that will be passed to the script as its 23 | -- redeemer during during validation 24 | type RedeemerConstrs redeemer = 25 | ( Api.ToData redeemer, 26 | Show redeemer, 27 | PrettyCooked redeemer, 28 | PlutusTx.Eq redeemer, 29 | Typeable redeemer 30 | ) 31 | 32 | -- | A bundle around a redeemer which allows to provide a reference input in 33 | -- which the script associated with the redeemer can be found 34 | data TxSkelRedeemer where 35 | TxSkelRedeemer :: 36 | (RedeemerConstrs redeemer) => 37 | { -- | The redeemer data with which the script will be executed 38 | txSkelRedeemerContent :: redeemer, 39 | -- | An optional reference input containing the script to execute. During 40 | -- transaction generation, this reference input will only be translated 41 | -- into a Cardano reference input if it does not appear in regular inputs. 42 | txSkelRedeemerReferenceInput :: Maybe Api.TxOutRef, 43 | -- | Whether the reference input can be automatically assigned. This will 44 | -- only trigger if 'txSkelRedeemerReferenceInput' is 'Nothing' 45 | txSkelRedeemerAutoFill :: Bool 46 | } -> 47 | TxSkelRedeemer 48 | 49 | deriving instance (Show TxSkelRedeemer) 50 | 51 | instance Eq TxSkelRedeemer where 52 | (TxSkelRedeemer red mRefIn af) == TxSkelRedeemer red' mRefIn' af' = 53 | cast red PlutusTx.== Just red' PlutusTx.&& mRefIn PlutusTx.== mRefIn' PlutusTx.&& af PlutusTx.== af' 54 | 55 | -- | Attempts to retrieve the content of a 'TxSkelRedeemer' and cast it to a 56 | -- given type 57 | getTypedRedeemer :: (Typeable a) => TxSkelRedeemer -> Maybe a 58 | getTypedRedeemer (TxSkelRedeemer red _ _) = cast red 59 | 60 | -- | Changes the inner content of this 'TxSkelRedeemer', leaving the reference 61 | -- input unchanged. This operation is type-changing. 62 | setTypedRedeemer :: (RedeemerConstrs redeemer) => redeemer -> TxSkelRedeemer -> TxSkelRedeemer 63 | setTypedRedeemer red txSkelRed = txSkelRed {txSkelRedeemerContent = red} 64 | 65 | -- | Creates a 'TxSkelRedeemer' from an inner content with no reference input 66 | someTxSkelRedeemer :: (RedeemerConstrs redeemer) => redeemer -> TxSkelRedeemer 67 | someTxSkelRedeemer red = TxSkelRedeemer red Nothing True 68 | 69 | -- | Creates a 'TxSkelRedeemer' from an inner content with no reference input, 70 | -- while not allowing it to be automatically assigned 71 | someTxSkelRedeemerNoAutoFill :: (RedeemerConstrs redeemer) => redeemer -> TxSkelRedeemer 72 | someTxSkelRedeemerNoAutoFill red = TxSkelRedeemer red Nothing False 73 | 74 | -- | Creates a 'TxSkelRedeemer' without an inner content nor a reference input 75 | emptyTxSkelRedeemer :: TxSkelRedeemer 76 | emptyTxSkelRedeemer = someTxSkelRedeemer () 77 | 78 | -- | Creates a 'TxSkelRedeemer' with no inner content and no reference input, 79 | -- while dissallowing it to be automatically assinged 80 | emptyTxSkelRedeemerNoAutoFill :: TxSkelRedeemer 81 | emptyTxSkelRedeemerNoAutoFill = someTxSkelRedeemerNoAutoFill () 82 | 83 | -- | Attaches a reference input to a given 'TxSkelRedeemer'. This should usually 84 | -- be of no use if option 'Cooked.Skeleton.Option.txOptAutoReferenceScripts' is 85 | -- turned on, which is the case by default. 86 | withReferenceInput :: TxSkelRedeemer -> Api.TxOutRef -> TxSkelRedeemer 87 | withReferenceInput red ref = red {txSkelRedeemerReferenceInput = Just ref} 88 | -------------------------------------------------------------------------------- /src/Cooked/Skeleton/ReferenceScript.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the notion of reference scripts used in our 2 | -- 'Cooked.Skeleton.TxSkel' 3 | module Cooked.Skeleton.ReferenceScript 4 | ( ReferenceScriptConstrs, 5 | TxSkelOutReferenceScript (..), 6 | txSkelOutTypedRefScriptAT, 7 | txSkelOutRefScriptVersioned, 8 | txSkelOutRefScriptHash, 9 | ) 10 | where 11 | 12 | import Data.Typeable 13 | import Optics.Core 14 | import Plutus.Script.Utils.Scripts qualified as Script 15 | import PlutusLedgerApi.V3 qualified as Api 16 | 17 | -- | Type constraints over the reference script in a 18 | -- 'Cooked.Skeleton.Ouput.TxSkelOut' 19 | type ReferenceScriptConstrs refScript = 20 | ( Script.ToVersioned Script.Script refScript, 21 | Show refScript, 22 | Typeable refScript 23 | ) 24 | 25 | -- | Reference scripts in 'Cooked.Skeleton.Ouput.TxSkelOut' 26 | data TxSkelOutReferenceScript where 27 | TxSkelOutNoReferenceScript :: TxSkelOutReferenceScript 28 | TxSkelOutSomeReferenceScript :: (ReferenceScriptConstrs a) => a -> TxSkelOutReferenceScript 29 | 30 | deriving instance Show TxSkelOutReferenceScript 31 | 32 | -- | Retrieving, or setting, a typed reference script 33 | txSkelOutTypedRefScriptAT :: (ReferenceScriptConstrs a) => AffineTraversal' TxSkelOutReferenceScript a 34 | txSkelOutTypedRefScriptAT = 35 | atraversal 36 | ( \x -> case x of 37 | TxSkelOutNoReferenceScript -> Left x 38 | TxSkelOutSomeReferenceScript script -> maybe (Left x) Right (cast script) 39 | ) 40 | ( flip 41 | ( \refScript -> \case 42 | TxSkelOutNoReferenceScript -> TxSkelOutNoReferenceScript 43 | TxSkelOutSomeReferenceScript _ -> TxSkelOutSomeReferenceScript refScript 44 | ) 45 | ) 46 | 47 | -- | Retrieving the versioned reference script 48 | txSkelOutRefScriptVersioned :: TxSkelOutReferenceScript -> Maybe (Script.Versioned Script.Script) 49 | txSkelOutRefScriptVersioned TxSkelOutNoReferenceScript = Nothing 50 | txSkelOutRefScriptVersioned (TxSkelOutSomeReferenceScript content) = Just $ Script.toVersioned content 51 | 52 | -- | Retrieving the hash of the reference script 53 | txSkelOutRefScriptHash :: TxSkelOutReferenceScript -> Maybe Api.ScriptHash 54 | txSkelOutRefScriptHash = fmap Script.toScriptHash . txSkelOutRefScriptVersioned 55 | -------------------------------------------------------------------------------- /src/Cooked/Skeleton/Value.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes constructs around the value as it is stored in a 2 | -- 'Cooked.Skeleton.TxSkel'. 3 | module Cooked.Skeleton.Value 4 | ( TxSkelOutValue (..), 5 | txSkelOutValueContentL, 6 | txSkelOutValueAutoAdjustL, 7 | ) 8 | where 9 | 10 | import Optics.TH (makeLensesFor) 11 | import Plutus.Script.Utils.Value qualified as Script 12 | import PlutusLedgerApi.V3 qualified as Api 13 | 14 | -- | A bundle arond an 'Api.Value' to be stored in a 15 | -- 'Cooked.Skeleton.TxSkel'. This bundles offers the possibility to mark a value 16 | -- as adjustable, in case the ADA amount it contains is insufficient to sustain 17 | -- the storage cost of the UTxO containing it. 18 | data TxSkelOutValue where 19 | TxSkelOutValue :: 20 | { -- | Value to be paid 21 | txSkelOutValueContent :: Api.Value, 22 | -- | Whether this value can be subject to automated adjustment 23 | txSkelOutValueAutoAdjust :: Bool 24 | } -> 25 | TxSkelOutValue 26 | deriving (Show, Eq) 27 | 28 | instance Script.ToValue TxSkelOutValue where 29 | toValue = txSkelOutValueContent 30 | 31 | -- | A lens to get or set the inner value of a 'TxSkelOutValue' 32 | makeLensesFor [("txSkelOutValueContent", "txSkelOutValueContentL")] ''TxSkelOutValue 33 | 34 | -- | A lens to get or set if this value should be auto-adjusted if needed 35 | makeLensesFor [("txSkelOutValueAutoAdjust", "txSkelOutValueAutoAdjustL")] ''TxSkelOutValue 36 | -------------------------------------------------------------------------------- /src/Cooked/Skeleton/Withdrawal.hs: -------------------------------------------------------------------------------- 1 | -- | This module exposes the notion of Withdrawal within a 2 | -- 'Cooked.Skeleton.TxSkel' 3 | module Cooked.Skeleton.Withdrawal 4 | ( TxSkelWithdrawals, 5 | pkWithdrawal, 6 | scriptWithdrawal, 7 | ) 8 | where 9 | 10 | import Cooked.Skeleton.Redeemer 11 | import Data.Map (Map) 12 | import Data.Map qualified as Map 13 | import Plutus.Script.Utils.Address qualified as Script 14 | import Plutus.Script.Utils.Scripts qualified as Script 15 | import PlutusLedgerApi.V3 qualified as Api 16 | 17 | -- | Withdrawals associate either a script or a private key with a redeemer and 18 | -- a certain amount of ada. Note that the redeemer will be ignored in the case 19 | -- of a private key. 20 | type TxSkelWithdrawals = 21 | Map 22 | (Either (Script.Versioned Script.Script) Api.PubKeyHash) 23 | (TxSkelRedeemer, Api.Lovelace) 24 | 25 | -- | Creates a 'TxSkelWithdrawals' from a private key hash and amount 26 | pkWithdrawal :: (Script.ToPubKeyHash pkh) => pkh -> Integer -> TxSkelWithdrawals 27 | pkWithdrawal pkh amount = Map.singleton (Right $ Script.toPubKeyHash pkh) (emptyTxSkelRedeemer, Api.Lovelace amount) 28 | 29 | -- | Creates a 'TxSkelWithdrawals' from a script, redeemer and amount 30 | scriptWithdrawal :: (Script.ToVersioned Script.Script script) => script -> TxSkelRedeemer -> Integer -> TxSkelWithdrawals 31 | scriptWithdrawal script red amount = Map.singleton (Left $ Script.toVersioned script) (red, Api.Lovelace amount) 32 | -------------------------------------------------------------------------------- /src/Cooked/Tweak.hs: -------------------------------------------------------------------------------- 1 | -- | This module centralizes Tweaks, that is state-aware skeleton 2 | -- modifications. These tweaks can be used on specific skeletons, or deployed in 3 | -- time using `Cooked.Ltl` 4 | module Cooked.Tweak (module X) where 5 | 6 | import Cooked.Tweak.Common as X hiding 7 | ( Tweak, 8 | UntypedTweak, 9 | runTweakInChain, 10 | runTweakInChain', 11 | ) 12 | import Cooked.Tweak.Inputs as X 13 | import Cooked.Tweak.Labels as X 14 | import Cooked.Tweak.Mint as X 15 | import Cooked.Tweak.OutPermutations as X hiding (distinctPermutations) 16 | import Cooked.Tweak.Outputs as X 17 | import Cooked.Tweak.Signers as X 18 | import Cooked.Tweak.ValidityRange as X 19 | -------------------------------------------------------------------------------- /src/Cooked/Tweak/Inputs.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides some 'Tweak's that add or remove inputs and outputs 2 | -- from transactions. Some also operate on the minted value. 3 | module Cooked.Tweak.Inputs 4 | ( ensureInputTweak, 5 | addInputTweak, 6 | removeInputTweak, 7 | modifySpendRedeemersOfTypeTweak, 8 | ) 9 | where 10 | 11 | import Control.Monad 12 | import Cooked.Skeleton 13 | import Cooked.Tweak.Common 14 | import Data.Map qualified as Map 15 | import Data.Maybe (fromMaybe) 16 | import Optics.Core 17 | import PlutusLedgerApi.V3 qualified as Api 18 | import Type.Reflection (Typeable) 19 | 20 | -- | Ensure that a given 'Api.TxOutRef' is being spent with a given 21 | -- 'TxSkelRedeemer'. The return value will be @Just@ the added data, if anything 22 | -- changed. 23 | ensureInputTweak :: (MonadTweak m) => Api.TxOutRef -> TxSkelRedeemer -> m (Maybe (Api.TxOutRef, TxSkelRedeemer)) 24 | ensureInputTweak oref howConsumed = do 25 | presentInputs <- viewTweak txSkelInsL 26 | if presentInputs Map.!? oref == Just howConsumed 27 | then return Nothing 28 | else do 29 | overTweak txSkelInsL (Map.insert oref howConsumed) 30 | return $ Just (oref, howConsumed) 31 | 32 | -- | Add an input to a transaction. If the given 'Api.TxOutRef' is already being 33 | -- consumed by the transaction, fail. 34 | addInputTweak :: (MonadTweak m) => Api.TxOutRef -> TxSkelRedeemer -> m () 35 | addInputTweak oref howConsumed = do 36 | presentInputs <- viewTweak txSkelInsL 37 | guard (Map.notMember oref presentInputs) 38 | overTweak txSkelInsL (Map.insert oref howConsumed) 39 | 40 | -- | Remove transaction inputs according to a given predicate. The returned list 41 | -- contains all removed inputs. 42 | removeInputTweak :: (MonadTweak m) => (Api.TxOutRef -> TxSkelRedeemer -> Bool) -> m [(Api.TxOutRef, TxSkelRedeemer)] 43 | removeInputTweak removePred = do 44 | presentInputs <- viewTweak txSkelInsL 45 | let (removed, kept) = Map.partitionWithKey removePred presentInputs 46 | setTweak txSkelInsL kept 47 | return $ Map.toList removed 48 | 49 | -- | Applies an optional modification to all spend redeemers of type a 50 | modifySpendRedeemersOfTypeTweak :: forall a b m. (Typeable a, RedeemerConstrs b, MonadTweak m) => (a -> Maybe b) -> m () 51 | modifySpendRedeemersOfTypeTweak f = do 52 | presentInputs <- Map.toList <$> viewTweak txSkelInsL 53 | setTweak txSkelInsL $ 54 | Map.fromList $ 55 | presentInputs <&> \(oRef, red) -> (oRef,) . fromMaybe red $ do 56 | typedRedeemer <- getTypedRedeemer red 57 | (`setTypedRedeemer` red) <$> f typedRedeemer 58 | -------------------------------------------------------------------------------- /src/Cooked/Tweak/Labels.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides tweaks operating on transaction labels 2 | module Cooked.Tweak.Labels 3 | ( addLabelTweak, 4 | removeLabelTweak, 5 | hasLabelTweak, 6 | ) 7 | where 8 | 9 | import Control.Monad 10 | import Cooked.Skeleton 11 | import Cooked.Tweak.Common 12 | import Data.Functor 13 | import Data.Set qualified as Set 14 | 15 | -- | Adds a label to a 'TxSkel'. 16 | addLabelTweak :: (MonadTweak m, LabelConstrs x) => x -> m () 17 | addLabelTweak = overTweak txSkelLabelL . Set.insert . TxLabel 18 | 19 | -- | Checks if a given label is present in the 'TxSkel' 20 | hasLabelTweak :: (MonadTweak m, LabelConstrs x) => x -> m Bool 21 | hasLabelTweak = (viewTweak txSkelLabelL <&>) . Set.member . TxLabel 22 | 23 | -- | Removes a label from a 'TxSkel' when possible, fails otherwise 24 | removeLabelTweak :: (MonadTweak m, LabelConstrs x) => x -> m () 25 | removeLabelTweak label = do 26 | hasLabelTweak label >>= guard 27 | overTweak txSkelLabelL . Set.delete $ TxLabel label 28 | -------------------------------------------------------------------------------- /src/Cooked/Tweak/Mint.hs: -------------------------------------------------------------------------------- 1 | -- | 'Tweak's working on the minting part of a 'TxSkel' 2 | module Cooked.Tweak.Mint 3 | ( addMintTweak, 4 | removeMintTweak, 5 | ) 6 | where 7 | 8 | import Cooked.Skeleton 9 | import Cooked.Tweak.Common 10 | import Data.List (partition) 11 | import Optics.Core 12 | 13 | -- | Adds a new entry to the 'TxSkelMints' of the transaction skeleton under 14 | -- modification. As this is implemented in terms of 'addMint', the same caveats 15 | -- apply as do to that function! 16 | addMintTweak :: (MonadTweak m) => Mint -> m () 17 | addMintTweak = overTweak txSkelMintsL . flip addMint 18 | 19 | -- | Remove some entries from the 'TxSkelMints' of a transaction, according to 20 | -- some predicate. The returned list holds the removed entries. 21 | removeMintTweak :: (MonadTweak m) => (Mint -> Bool) -> m [Mint] 22 | removeMintTweak removePred = do 23 | presentMints <- viewTweak $ txSkelMintsL % to txSkelMintsToList 24 | let (removed, kept) = partition removePred presentMints 25 | setTweak txSkelMintsL $ txSkelMintsFromList kept 26 | return removed 27 | -------------------------------------------------------------------------------- /src/Cooked/Tweak/OutPermutations.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides 'Cooked.Tweak.Common.Tweak's to modify the order of 2 | -- outputs in a transaction skeleton. This can be useful since some validators 3 | -- expect a certain rigid output order to make sense of them. 4 | module Cooked.Tweak.OutPermutations 5 | ( PermutOutTweakMode (..), 6 | allOutPermutsTweak, 7 | singleOutPermutTweak, 8 | 9 | -- * For testing purposes 10 | distinctPermutations, 11 | ) 12 | where 13 | 14 | import Control.Monad 15 | import Cooked.Skeleton 16 | import Cooked.Tweak.Common 17 | import System.Random 18 | import System.Random.Shuffle 19 | 20 | -- | Output permutation policy 21 | data PermutOutTweakMode = KeepIdentity (Maybe Int) | OmitIdentity (Maybe Int) 22 | 23 | -- | Modify transactions by changing the ordering of output constraints. If the 24 | -- 'PermutOutTweakMode' is 25 | -- 26 | -- - @KeepIdentity (Just n)@, the unmodified transaction is included in the list 27 | -- of modified transactions and only the first n outputs are permuted, 28 | -- 29 | -- - @KeepIdentity Nothing@, the unmodified transaction is included and all 30 | -- outputs are permuted. Use this with care; there might be a lot of 31 | -- permutations! 32 | -- 33 | -- - @OmitIdentity (Just n)@, the unmodified transaction is not included in the 34 | -- list of modified transactions and only the first n outputs are permuted, 35 | -- 36 | -- - @OmitIdentity Nothing@, the unmodified transaction is not included and all 37 | -- outputs are permuted. Use this with care; there might be a lot of 38 | -- permutations! 39 | -- 40 | -- (In particular, this is clever enough to generate only the distinct 41 | -- permutations, even if some outputs are identical.) 42 | allOutPermutsTweak :: (MonadTweak m) => PermutOutTweakMode -> m () 43 | allOutPermutsTweak mode = do 44 | oldOut <- viewTweak txSkelOutsL 45 | msum $ 46 | map 47 | (setTweak txSkelOutsL) 48 | (perms oldOut) 49 | where 50 | perms = case mode of 51 | KeepIdentity (Just n) -> \l -> map (++ drop n l) $ distinctPermutations (take n l) 52 | KeepIdentity Nothing -> distinctPermutations 53 | OmitIdentity (Just n) -> \l -> map (++ drop n l) $ nonIdentityPermutations (take n l) 54 | OmitIdentity Nothing -> nonIdentityPermutations 55 | 56 | -- | This ensures duplicate entries in the input list don't give rise to 57 | -- duplicate permutations. 58 | distinctPermutations :: (Eq a) => [a] -> [[a]] 59 | distinctPermutations = foldr (concatMap . insertSomewhere) [[]] . groupEq 60 | where 61 | -- group all equal elements. If we had @Ord a@, we could implement this more 62 | -- effifiently as @group . sort@. 63 | groupEq :: (Eq a) => [a] -> [[a]] 64 | groupEq l = map (\x -> replicate (count x l) x) $ makeUnique l 65 | where 66 | count :: (Eq a) => a -> [a] -> Int 67 | count _ [] = 0 68 | count a (b : bs) = if a /= b then count a bs else 1 + count a bs 69 | 70 | makeUnique :: (Eq a) => [a] -> [a] 71 | makeUnique [] = [] 72 | makeUnique (x : xs) = 73 | let xs' = makeUnique xs 74 | in if x `elem` xs' then xs' else x : xs' 75 | 76 | -- all possibilities to insert elements from the left list into the right 77 | -- list 78 | insertSomewhere :: [a] -> [a] -> [[a]] 79 | insertSomewhere [] ys = [ys] 80 | insertSomewhere xs [] = [xs] 81 | insertSomewhere l@(x : xs) r@(y : ys) = 82 | map (x :) (insertSomewhere xs r) ++ map (y :) (insertSomewhere l ys) 83 | 84 | nonIdentityPermutations :: (Eq a) => [a] -> [[a]] 85 | nonIdentityPermutations l = removeFirst l $ distinctPermutations l 86 | where 87 | removeFirst :: (Eq a) => a -> [a] -> [a] 88 | removeFirst _ [] = [] 89 | removeFirst x (y : ys) = if x == y then ys else y : removeFirst x ys 90 | 91 | -- | This randomly permutes the outputs of a transaction with a given seed. Can 92 | -- be used to assess if a certain validator is order-dependant 93 | singleOutPermutTweak :: (MonadTweak m) => Int -> m () 94 | singleOutPermutTweak seed = do 95 | outputs <- viewTweak txSkelOutsL 96 | let outputs' = shuffle' outputs (length outputs) (mkStdGen seed) 97 | guard $ outputs' /= outputs 98 | setTweak txSkelOutsL outputs' 99 | -------------------------------------------------------------------------------- /src/Cooked/Tweak/Outputs.hs: -------------------------------------------------------------------------------- 1 | -- | 'Tweak's working on the outputs of a 'TxSkel' 2 | module Cooked.Tweak.Outputs 3 | ( ensureOutputTweak, 4 | addOutputTweak, 5 | removeOutputTweak, 6 | tamperDatumTweak, 7 | TamperDatumLbl (..), 8 | malformDatumTweak, 9 | MalformDatumLbl (..), 10 | ) 11 | where 12 | 13 | import Control.Monad 14 | import Cooked.Pretty.Class 15 | import Cooked.Skeleton 16 | import Cooked.Tweak.Common 17 | import Cooked.Tweak.Labels 18 | import Data.List (partition) 19 | import Data.Maybe 20 | import Optics.Core 21 | import PlutusLedgerApi.V3 qualified as Api 22 | 23 | -- | Ensures that a certain output is produced by a transaction. The return 24 | -- value will be @Just@ the added output, when applicable. 25 | ensureOutputTweak :: (MonadTweak m) => TxSkelOut -> m (Maybe TxSkelOut) 26 | ensureOutputTweak txSkelOut = do 27 | presentOutputs <- viewTweak txSkelOutsL 28 | if txSkelOut `elem` presentOutputs 29 | then return Nothing 30 | else do 31 | addOutputTweak txSkelOut 32 | return $ Just txSkelOut 33 | 34 | -- | Adds a transaction output, at the end of the current list of outputs, thus 35 | -- retaining the initial outputs order. 36 | addOutputTweak :: (MonadTweak m) => TxSkelOut -> m () 37 | addOutputTweak txSkelOut = overTweak txSkelOutsL (++ [txSkelOut]) 38 | 39 | -- | Removes transaction outputs according to some predicate. The returned list 40 | -- contains all the removed outputs. 41 | removeOutputTweak :: (MonadTweak m) => (TxSkelOut -> Bool) -> m [TxSkelOut] 42 | removeOutputTweak removePred = do 43 | presentOutputs <- viewTweak txSkelOutsL 44 | let (removed, kept) = partition removePred presentOutputs 45 | setTweak txSkelOutsL kept 46 | return removed 47 | 48 | -- | A label added to a 'TxSkel' on which the 'tamperDatumTweak' has been 49 | -- successfully applied 50 | data TamperDatumLbl = TamperDatumLbl deriving (Show, Eq, Ord) 51 | 52 | instance PrettyCooked TamperDatumLbl where 53 | prettyCooked _ = "TamperDatum" 54 | 55 | -- | A tweak that tries to change the datum on outputs carrying datums of a 56 | -- certain type with a prescribed tampering function. The tampering function 57 | -- ignores datums of other types and those for which it returns @Nothing@. 58 | -- 59 | -- The tweak returns a list of the modified datums, as they were *before* the 60 | -- modification was applied to them. 61 | tamperDatumTweak :: forall a m. (MonadTweak m, DatumConstrs a) => (a -> Maybe a) -> m [a] 62 | tamperDatumTweak change = do 63 | beforeModification <- overMaybeTweak (txSkelOutsL % traversed % txSkelOutDatumL % txSkelOutTypedDatumAT) change 64 | guard . not . null $ beforeModification 65 | addLabelTweak TamperDatumLbl 66 | return beforeModification 67 | 68 | -- | A tweak that tries to change the datum on outputs carrying datums of a 69 | -- certain type with a prescribed tampering function. There are two main 70 | -- differences with 'tamperDatumTweak'. First, the tampering function returns 71 | -- 'Api.BuiltinData', allowing it to do pretty much anything with the 72 | -- datums. Second, for every output datum there are zero or more options for how 73 | -- to modify it, and all combinations of these modifications are tried. 74 | -- 75 | -- That is, if there are @n@ output datums, for which there are @k_1,...,k_n@ 76 | -- possible modifications, this tweak will try 77 | -- 78 | -- > k_1 + ... + k_n 79 | -- > + k_1 * k_2 + ... + k_{n-1} * k_n 80 | -- > + k_1 * k_2 * k_3 + ... + k_{n-2} * k_{n-1} * k_n 81 | -- > + ... 82 | -- > + k_1 * k_2 * ... * k_{n-1} * k_n 83 | -- > == (k_1 + 1) * ... * (k_n + 1) - 1 84 | -- 85 | -- modified transactions. 86 | malformDatumTweak :: forall a m. (MonadTweak m, DatumConstrs a) => (a -> [Api.BuiltinData]) -> m () 87 | malformDatumTweak change = do 88 | outputs <- viewAllTweak (txSkelOutsL % traversed) 89 | let modifiedOutputs = map (\output -> output : changeOutput output) outputs 90 | -- We remove the first combination because it consists of all the heads 91 | -- and therefore it is the combination consisting of no changes at all. 92 | modifiedOutputGroups = tail $ allCombinations modifiedOutputs 93 | msum $ map (setTweak txSkelOutsL) modifiedOutputGroups 94 | addLabelTweak MalformDatumLbl 95 | where 96 | changeOutput :: TxSkelOut -> [TxSkelOut] 97 | changeOutput txSkelOut = 98 | do 99 | typedDat <- maybeToList $ txSkelOut ^? txSkelOutDatumL % txSkelOutTypedDatumAT 100 | modifiedDat <- change typedDat 101 | return $ txSkelOut & txSkelOutDatumL % txSkelOutDatumContentAT .~ DatumContent modifiedDat 102 | 103 | -- | A label added to a 'TxSkel' on which the 'malformDatumTweak' has been 104 | -- successfully applied 105 | data MalformDatumLbl = MalformDatumLbl deriving (Show, Eq, Ord) 106 | 107 | instance PrettyCooked MalformDatumLbl where 108 | prettyCooked _ = "MalformDatum" 109 | 110 | -- | Given a list of lists @l@, we call “combination” of @l@ a list @c@ such 111 | -- that - @length c == length l@, and - for all @0 <= i < length c@, @elem (c !! 112 | -- i) (l !! i)@. 113 | -- 114 | -- 'allCombinations', as the name suggests, returns all the possible 115 | -- combinations of a given list of lists. For instance: 116 | -- 117 | -- @allCombinations [[1,2,3], [4,5], [6]] == [[1,4,6], [1,5,6], [2,4,6], [2,5,6], [3,4,6], [3,5,6]]@ 118 | -- 119 | -- It is guaranteed that combinations are returned in such an order that a 120 | -- combination @c1@ comes before a combination @c2@ in the result list if and 121 | -- only if for some prefix list @p@, some elements @a1@ and @a2@ and for some 122 | -- rest lists @r1@ and @r2@: 123 | -- > c1 == p ++ (a1 : r1) 124 | -- > c2 == p ++ (a2 : r2) 125 | -- and @a1@ comes before @a2@ in the list @l !! length p@. In particular, the 126 | -- first element of the result list is the combination consisting of all the 127 | -- first elements of the input lists. 128 | allCombinations :: [[a]] -> [[a]] 129 | allCombinations [] = [[]] 130 | allCombinations [[]] = [] -- included in the next one 131 | allCombinations (first : rest) = [x : xs | x <- first, xs <- allCombinations rest] 132 | -------------------------------------------------------------------------------- /src/Cooked/Tweak/Signers.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines 'Cooked.Tweak.Common.Tweak's revolving around the 2 | -- signers of a transaction. They assume but do not ensure that the list of 3 | -- signers is free of duplicates. 4 | module Cooked.Tweak.Signers 5 | ( getSignersTweak, 6 | modifySignersTweak, 7 | setSignersTweak, 8 | signersSatisfyTweak, 9 | isSignerTweak, 10 | hasSignersTweak, 11 | addFirstSignerTweak, 12 | addSignersTweak, 13 | addLastSignerTweak, 14 | removeSignersTweak, 15 | removeSignerTweak, 16 | replaceFirstSignerTweak, 17 | ) 18 | where 19 | 20 | import Cooked.Skeleton (txSkelSignersL) 21 | import Cooked.Tweak.Common (MonadTweak, setTweak, viewTweak) 22 | import Cooked.Wallet (Wallet) 23 | import Data.List (delete, (\\)) 24 | 25 | -- | Returns the current list of signers 26 | getSignersTweak :: (MonadTweak m) => m [Wallet] 27 | getSignersTweak = viewTweak txSkelSignersL 28 | 29 | -- | Apply a function to the list of signers and return the old ones 30 | modifySignersTweak :: (MonadTweak m) => ([Wallet] -> [Wallet]) -> m [Wallet] 31 | modifySignersTweak f = do 32 | oldSigners <- getSignersTweak 33 | setTweak txSkelSignersL (f oldSigners) 34 | return oldSigners 35 | 36 | -- | Change the current signers and return the old ones 37 | setSignersTweak :: (MonadTweak m) => [Wallet] -> m [Wallet] 38 | setSignersTweak = modifySignersTweak . const 39 | 40 | -- | Check if the signers satisfy a certain predicate 41 | signersSatisfyTweak :: (MonadTweak m) => ([Wallet] -> Bool) -> m Bool 42 | signersSatisfyTweak = (<$> getSignersTweak) 43 | 44 | -- | Check if a wallet signs a transaction 45 | isSignerTweak :: (MonadTweak m) => Wallet -> m Bool 46 | isSignerTweak = signersSatisfyTweak . elem 47 | 48 | -- | Check if the transaction has at least a signer 49 | hasSignersTweak :: (MonadTweak m) => m Bool 50 | hasSignersTweak = signersSatisfyTweak (not . null) 51 | 52 | -- | Add a signer to the transaction, at the head of the list of signers, and 53 | -- return the old list of signers 54 | addFirstSignerTweak :: (MonadTweak m) => Wallet -> m [Wallet] 55 | addFirstSignerTweak = modifySignersTweak . (:) 56 | 57 | -- | Add signers at the end of the list of signers, and return the old list of 58 | -- signers 59 | addSignersTweak :: (MonadTweak m) => [Wallet] -> m [Wallet] 60 | addSignersTweak = modifySignersTweak . (<>) 61 | 62 | -- | Add a signer to the transaction, at the end of the list of signers, and 63 | -- return the old list of signers 64 | addLastSignerTweak :: (MonadTweak m) => Wallet -> m [Wallet] 65 | addLastSignerTweak = addSignersTweak . (: []) 66 | 67 | -- | Remove signers from the transaction and return the old list of signers 68 | removeSignersTweak :: (MonadTweak m) => [Wallet] -> m [Wallet] 69 | removeSignersTweak = modifySignersTweak . (\\) 70 | 71 | -- | Remove a signer from the transaction and return the old list of signers 72 | removeSignerTweak :: (MonadTweak m) => Wallet -> m [Wallet] 73 | removeSignerTweak = modifySignersTweak . delete 74 | 75 | -- | Changes the first signer (adds it if there are no signers) and return the 76 | -- old list of signers. 77 | replaceFirstSignerTweak :: (MonadTweak m) => Wallet -> m [Wallet] 78 | replaceFirstSignerTweak = 79 | modifySignersTweak 80 | . ( \newSigner -> \case 81 | [] -> [newSigner] 82 | (_ : ss) -> newSigner : ss 83 | ) 84 | -------------------------------------------------------------------------------- /src/Cooked/Tweak/ValidityRange.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines 'Tweak's revolving around the validity range of a 2 | -- transaction 3 | module Cooked.Tweak.ValidityRange where 4 | 5 | import Control.Monad 6 | import Cooked.MockChain 7 | import Cooked.Skeleton 8 | import Cooked.Tweak.Common 9 | import Ledger.Slot qualified as Ledger 10 | import PlutusLedgerApi.V1.Interval qualified as Api 11 | 12 | -- | Looks up the current validity range of the transaction 13 | getValidityRangeTweak :: (MonadTweak m) => m Ledger.SlotRange 14 | getValidityRangeTweak = viewTweak txSkelValidityRangeL 15 | 16 | -- | Changes the current validity range, returning the old one 17 | setValidityRangeTweak :: (MonadTweak m) => Ledger.SlotRange -> m Ledger.SlotRange 18 | setValidityRangeTweak newRange = do 19 | oldRange <- getValidityRangeTweak 20 | setTweak txSkelValidityRangeL newRange 21 | return oldRange 22 | 23 | -- | Ensures the skeleton makes for an unconstrained validity range 24 | setAlwaysValidRangeTweak :: (MonadTweak m) => m Ledger.SlotRange 25 | setAlwaysValidRangeTweak = setValidityRangeTweak Api.always 26 | 27 | -- | Sets the left bound of the validity range. Leaves the right bound unchanged 28 | setValidityStartTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange 29 | setValidityStartTweak left = getValidityRangeTweak >>= setValidityRangeTweak . Api.Interval (Api.LowerBound (Api.Finite left) True) . Api.ivTo 30 | 31 | -- | Sets the right bound of the validity range. Leaves the left bound unchanged 32 | setValidityEndTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange 33 | setValidityEndTweak right = getValidityRangeTweak >>= setValidityRangeTweak . flip Api.Interval (Api.UpperBound (Api.Finite right) True) . Api.ivFrom 34 | 35 | -- | Checks if the validity range satisfies a certain predicate 36 | validityRangeSatisfiesTweak :: (MonadTweak m) => (Ledger.SlotRange -> Bool) -> m Bool 37 | validityRangeSatisfiesTweak = (<$> getValidityRangeTweak) 38 | 39 | -- | Checks if a given time belongs to the validity range of a transaction 40 | isValidAtTweak :: (MonadTweak m) => Ledger.Slot -> m Bool 41 | isValidAtTweak = validityRangeSatisfiesTweak . Api.member 42 | 43 | -- | Checks if the current validity range includes the current time 44 | isValidNowTweak :: (MonadTweak m) => m Bool 45 | isValidNowTweak = currentSlot >>= isValidAtTweak 46 | 47 | -- | Checks if a given range is included in the validity range of a transaction 48 | isValidDuringTweak :: (MonadTweak m) => Ledger.SlotRange -> m Bool 49 | isValidDuringTweak = validityRangeSatisfiesTweak . flip Api.contains 50 | 51 | -- | Checks if the validity range is empty 52 | hasEmptyTimeRangeTweak :: (MonadTweak m) => m Bool 53 | hasEmptyTimeRangeTweak = validityRangeSatisfiesTweak Api.isEmpty 54 | 55 | -- | Checks if the validity range is unconstrained 56 | hasFullTimeRangeTweak :: (MonadTweak m) => m Bool 57 | hasFullTimeRangeTweak = validityRangeSatisfiesTweak (Api.always ==) 58 | 59 | -- | Adds a constraint to the current validity range. Returns the old range, and 60 | -- fails is the resulting interval is empty 61 | intersectValidityRangeTweak :: (MonadTweak m) => Ledger.SlotRange -> m Ledger.SlotRange 62 | intersectValidityRangeTweak newRange = do 63 | oldRange <- viewTweak txSkelValidityRangeL 64 | let combinedRange = Api.intersection newRange oldRange 65 | guard (combinedRange /= Api.never) 66 | setTweak txSkelValidityRangeL combinedRange 67 | return oldRange 68 | 69 | -- | Centers the validity range around a value with a certain radius 70 | centerAroundValidityRangeTweak :: (MonadTweak m) => Ledger.Slot -> Integer -> m Ledger.SlotRange 71 | centerAroundValidityRangeTweak t r = do 72 | let radius = Ledger.Slot r 73 | left = t - radius 74 | right = t + radius 75 | newRange = Api.interval left right 76 | setValidityRangeTweak newRange 77 | 78 | -- | Makes a transaction range equal to a singleton 79 | makeValidityRangeSingletonTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange 80 | makeValidityRangeSingletonTweak = setValidityRangeTweak . Api.singleton 81 | 82 | -- | Makes the transaction validity range comply with the current time 83 | makeValidityRangeNowTweak :: (MonadTweak m) => m Ledger.SlotRange 84 | makeValidityRangeNowTweak = currentSlot >>= makeValidityRangeSingletonTweak 85 | 86 | -- | Makes current time comply with the validity range of the transaction under 87 | -- modification. Returns the new current time after the modification; fails if 88 | -- current time is already after the validity range. 89 | waitUntilValidTweak :: (MonadTweak m) => m Ledger.Slot 90 | waitUntilValidTweak = do 91 | now <- currentSlot 92 | vRange <- getValidityRangeTweak 93 | if Api.member now vRange 94 | then return now 95 | else do 96 | guard $ Api.before now vRange 97 | guard $ not $ Api.isEmpty vRange 98 | later <- case Api.ivFrom vRange of 99 | Api.LowerBound (Api.Finite left) isClosed -> 100 | return $ left + fromIntegral (fromEnum $ not isClosed) 101 | _ -> fail "Unexpected left-finite interval without left border: please report a bug at https://github.com/tweag/cooked-validators/issues" 102 | void $ awaitSlot later 103 | return later 104 | -------------------------------------------------------------------------------- /src/Cooked/Wallet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | This module defines convenient wrappers for mock chain wallets (around 4 | -- Plutus mock wallets) with an associate API to construct them, manipulate 5 | -- them, and fetch information (such as public/private and staking keys). 6 | module Cooked.Wallet 7 | ( knownWallets, 8 | wallet, 9 | walletPKHashToId, 10 | walletPKHashToWallet, 11 | walletPK, 12 | walletStakingPK, 13 | walletStakingPKHash, 14 | walletSK, 15 | walletStakingSK, 16 | Wallet, 17 | ) 18 | where 19 | 20 | import Cardano.Crypto.Wallet qualified as Crypto 21 | import Data.Function (on) 22 | import Data.List (elemIndex) 23 | import Ledger.Address qualified as Ledger 24 | import Ledger.CardanoWallet qualified as Ledger 25 | import Ledger.Crypto qualified as Ledger 26 | import Plutus.Script.Utils.Address qualified as Script 27 | import PlutusLedgerApi.V3 qualified as Api 28 | 29 | -- * MockChain Wallets 30 | 31 | -- $mockchainwallets 32 | -- 33 | -- Because mock wallets from plutus-ledger change often, we provide our own 34 | -- wrapper on top of them to ensure that we can easily deal changes from Plutus. 35 | 36 | -- | A 'Wallet' is a 'Ledger.MockWallet' from plutus-ledger 37 | type Wallet = Ledger.MockWallet 38 | 39 | instance Eq Wallet where 40 | (==) = (==) `on` Ledger.mwWalletId 41 | 42 | instance Ord Wallet where 43 | compare = compare `on` Ledger.mwWalletId 44 | 45 | -- | All the wallets corresponding to known Plutus mock wallets. This is a list 46 | -- of 10 wallets which will 47 | -- 48 | -- - receive funds in the standard initial distribution of cooked-validators, 49 | -- 50 | -- - be pretty-printed as part the final state after running a few transactions. 51 | knownWallets :: [Wallet] 52 | knownWallets = Ledger.knownMockWallets 53 | 54 | -- | Wallet corresponding to a given wallet number (or wallet ID) with an offset 55 | -- of 1 to start at 1 instead of 0 56 | wallet :: Integer -> Wallet 57 | wallet j 58 | | j > 0 && j <= 10 = Ledger.knownMockWallet j 59 | | otherwise = Ledger.fromWalletNumber $ Ledger.WalletNumber j 60 | 61 | -- | Retrieves the id of the known wallet that corresponds to a public key hash 62 | -- 63 | -- @walletPKHashToId (walletPKHash (wallet 3)) == Just 3@ 64 | walletPKHashToId :: Api.PubKeyHash -> Maybe Int 65 | walletPKHashToId = (succ <$>) . flip elemIndex (Script.toPubKeyHash <$> knownWallets) 66 | 67 | -- | Retrieves the known wallet that corresponds to a public key hash 68 | walletPKHashToWallet :: Api.PubKeyHash -> Maybe Wallet 69 | walletPKHashToWallet pkh = wallet . fromIntegral <$> walletPKHashToId pkh 70 | 71 | -- | Retrieves a wallet public key (PK) 72 | walletPK :: Wallet -> Ledger.PubKey 73 | walletPK = Ledger.unPaymentPubKey . Ledger.paymentPubKey 74 | 75 | -- | Retrieves a wallet's public staking key (PK), if any 76 | walletStakingPK :: Wallet -> Maybe Ledger.PubKey 77 | walletStakingPK = fmap Ledger.toPublicKey . walletStakingSK 78 | 79 | -- | Retrieves a wallet's public key hash 80 | instance Script.ToPubKeyHash Wallet where 81 | toPubKeyHash = Ledger.pubKeyHash . walletPK 82 | 83 | -- | Retrieves a wallet's public staking key hash, if any 84 | walletStakingPKHash :: Wallet -> Maybe Api.PubKeyHash 85 | walletStakingPKHash = fmap Ledger.pubKeyHash . walletStakingPK 86 | 87 | instance Script.ToCredential Wallet where 88 | toCredential = Api.PubKeyCredential . Script.toPubKeyHash 89 | 90 | -- | Retrieves a wallet's staking credential 91 | instance Script.ToMaybeStakingCredential Wallet where 92 | toMaybeStakingCredential = (Api.StakingHash . Api.PubKeyCredential <$>) . walletStakingPKHash 93 | 94 | instance Script.ToAddress Wallet where 95 | toAddress w = 96 | Api.Address 97 | (Script.toCredential w) 98 | (Script.toMaybeStakingCredential w) 99 | 100 | -- | Retrieves a wallet private key (secret key SK) 101 | walletSK :: Wallet -> Crypto.XPrv 102 | walletSK = Ledger.unPaymentPrivateKey . Ledger.paymentPrivateKey 103 | 104 | -- | Retrieves a wallet's private staking key (secret key SK), if any 105 | walletStakingSK :: Wallet -> Maybe Crypto.XPrv 106 | walletStakingSK = fmap Ledger.unStakePrivateKey . Ledger.stakePrivateKey 107 | -------------------------------------------------------------------------------- /tests/Plutus/Attack/DatumHijacking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Plutus.Attack.DatumHijacking where 4 | 5 | import Plutus.Script.Utils.V3 qualified as Script 6 | import PlutusLedgerApi.V3 qualified as Api 7 | import PlutusLedgerApi.V3.Contexts qualified as Api 8 | import PlutusTx 9 | import PlutusTx.Prelude 10 | import Prelude qualified as HS 11 | 12 | -- * Mock contract for the datum hijacking attack 13 | 14 | -- This is a very simple contract: The first transaction locks some 15 | -- Ada to the validator, using the datum 'FirstLock', the second 16 | -- transaction then re-locks the same amount to the same validator, 17 | -- using the datum 'SecondLock'. The datum hijacking attack should 18 | -- target the second transaction, and substitute a different 19 | -- recipient. 20 | 21 | data LockDatum = FirstLock | SecondLock deriving (HS.Show, HS.Eq) 22 | 23 | instance Eq LockDatum where 24 | {-# INLINEABLE (==) #-} 25 | FirstLock == FirstLock = True 26 | SecondLock == SecondLock = True 27 | _ == _ = False 28 | 29 | makeLift ''LockDatum 30 | unstableMakeIsData ''LockDatum 31 | 32 | data DHContract 33 | 34 | instance Script.MultiPurposeScriptTypes DHContract where 35 | type SpendingDatumType DHContract = LockDatum 36 | 37 | lockValue :: Api.Value 38 | lockValue = Script.lovelace 12345678 39 | 40 | -- | Try to extract a datum from an output. 41 | {-# INLINEABLE outputDatum #-} 42 | outputDatum :: Api.TxInfo -> Api.TxOut -> Maybe LockDatum 43 | outputDatum txi o = case Api.txOutDatum o of 44 | Api.NoOutputDatum -> Nothing 45 | Api.OutputDatumHash h -> do 46 | Api.Datum d <- Api.findDatum h txi 47 | Api.fromBuiltinData d 48 | Api.OutputDatum (Api.Datum d) -> Api.fromBuiltinData d 49 | 50 | {-# INLINEABLE mockValidatorSpendingPurpose #-} 51 | mockValidatorSpendingPurpose :: (Api.TxInfo -> [Api.TxOut]) -> Script.SpendingPurposeType DHContract 52 | mockValidatorSpendingPurpose getOutputs _ (Just FirstLock) _ txi = 53 | case getOutputs txi of 54 | o : _ -> 55 | traceIfFalse "not in 'SecondLock'-state after re-locking" (outputDatum txi o == Just SecondLock) 56 | && traceIfFalse "not re-locking the right amout" (Api.txOutValue o == lockValue) 57 | _ -> trace "there must be a output re-locked" False 58 | mockValidatorSpendingPurpose _ _ _ _ _ = False 59 | 60 | carefulValidator :: Script.MultiPurposeScript DHContract 61 | carefulValidator = 62 | Script.MultiPurposeScript 63 | $ Script.toScript $$(compile [||script||]) 64 | where 65 | script = 66 | Script.mkMultiPurposeScript 67 | $ Script.falseTypedMultiPurposeScript 68 | `Script.withSpendingPurpose` mockValidatorSpendingPurpose (\txi -> Api.getContinuingOutputs $ Api.ScriptContext txi (error ()) (error ())) 69 | 70 | carelessValidator :: Script.MultiPurposeScript DHContract 71 | carelessValidator = 72 | Script.MultiPurposeScript 73 | $ Script.toScript $$(compile [||script||]) 74 | where 75 | script = 76 | Script.mkMultiPurposeScript 77 | $ Script.falseTypedMultiPurposeScript 78 | `Script.withSpendingPurpose` mockValidatorSpendingPurpose Api.txInfoOutputs 79 | -------------------------------------------------------------------------------- /tests/Plutus/Attack/DoubleSat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} 3 | 4 | module Plutus.Attack.DoubleSat where 5 | 6 | import Plutus.Script.Utils.V2 qualified as Script 7 | import PlutusLedgerApi.V2 qualified as Api 8 | import PlutusTx 9 | import PlutusTx.Prelude 10 | import Prelude qualified as HS 11 | 12 | -- * Mock contracts for the double satisfaction attack 13 | 14 | -- Scenario: There are two validators, one of type A, one of type B. We want to 15 | -- add an input belonging to the B validator to a transaction that spends from 16 | -- the A validator. 17 | 18 | data ADatum = ADatum deriving (HS.Show) 19 | 20 | instance Eq ADatum where 21 | ADatum == ADatum = True 22 | 23 | makeLift ''ADatum 24 | unstableMakeIsData ''ADatum 25 | 26 | data ARedeemer = ARedeemer1 | ARedeemer2 | ARedeemer3 deriving (HS.Show) 27 | 28 | instance Eq ARedeemer where 29 | ARedeemer1 == ARedeemer1 = True 30 | ARedeemer2 == ARedeemer2 = True 31 | ARedeemer3 == ARedeemer3 = True 32 | _ == _ = False 33 | 34 | makeLift ''ARedeemer 35 | unstableMakeIsData ''ARedeemer 36 | 37 | data AContract 38 | 39 | instance Script.ValidatorTypes AContract where 40 | type DatumType AContract = ADatum 41 | type RedeemerType AContract = ARedeemer 42 | 43 | {-# INLINEABLE mkAValidator #-} 44 | mkAValidator :: ADatum -> ARedeemer -> Api.ScriptContext -> Bool 45 | mkAValidator _ _ _ = True 46 | 47 | aValidator :: Script.TypedValidator AContract 48 | aValidator = 49 | Script.mkTypedValidator @AContract 50 | $$(compile [||mkAValidator||]) 51 | $$(compile [||wrap||]) 52 | where 53 | wrap = Script.mkUntypedValidator 54 | 55 | data BDatum = BDatum deriving (HS.Show) 56 | 57 | instance Eq BDatum where 58 | BDatum == BDatum = True 59 | 60 | makeLift ''BDatum 61 | unstableMakeIsData ''BDatum 62 | 63 | data BRedeemer = BRedeemer1 | BRedeemer2 deriving (HS.Show) 64 | 65 | instance Eq BRedeemer where 66 | BRedeemer1 == BRedeemer1 = True 67 | BRedeemer2 == BRedeemer2 = True 68 | _ == _ = False 69 | 70 | makeLift ''BRedeemer 71 | unstableMakeIsData ''BRedeemer 72 | 73 | data BContract 74 | 75 | instance Script.ValidatorTypes BContract where 76 | type DatumType BContract = BDatum 77 | type RedeemerType BContract = BRedeemer 78 | 79 | {-# INLINEABLE mkBValidator #-} 80 | mkBValidator :: BDatum -> BRedeemer -> Api.ScriptContext -> Bool 81 | mkBValidator _ _ _ = True 82 | 83 | bValidator :: Script.TypedValidator BContract 84 | bValidator = 85 | Script.mkTypedValidator @BContract 86 | $$(compile [||mkBValidator||]) 87 | $$(compile [||wrap||]) 88 | where 89 | wrap = Script.mkUntypedValidator 90 | -------------------------------------------------------------------------------- /tests/Plutus/Attack/DupToken.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Plutus.Attack.DupToken where 4 | 5 | import Plutus.Script.Utils.V3 qualified as Script 6 | import PlutusCore.Version 7 | import PlutusLedgerApi.V1.Value qualified as Api 8 | import PlutusLedgerApi.V3 qualified as Api 9 | import PlutusTx 10 | import PlutusTx.Prelude 11 | 12 | {-# INLINEABLE carefulPolicyMintingPurpose #-} 13 | carefulPolicyMintingPurpose :: Api.TokenName -> Integer -> Script.MintingPurposeType () 14 | carefulPolicyMintingPurpose tn n cs _ (Api.TxInfo {txInfoMint}) = 15 | case Api.flattenValue (Script.toValue txInfoMint) of 16 | [(cs', tn', n')] -> cs' == cs && tn' == tn && n' == n 17 | _ -> trace "tried to mint wrong amount" False 18 | 19 | carefulPolicyCompiled :: CompiledCode (Api.TokenName -> Integer -> BuiltinData -> BuiltinUnit) 20 | carefulPolicyCompiled = $$(compile [||script||]) 21 | where 22 | script tn n = 23 | Script.mkMultiPurposeScript 24 | $ Script.falseTypedMultiPurposeScript 25 | `Script.withMintingPurpose` carefulPolicyMintingPurpose tn n 26 | 27 | carefulPolicy :: Api.TokenName -> Integer -> Script.Versioned Script.MintingPolicy 28 | carefulPolicy tName allowedAmount = 29 | Script.toVersioned 30 | $ Script.MultiPurposeScript @() 31 | $ Script.toScript 32 | $ carefulPolicyCompiled 33 | `unsafeApplyCode` liftCode plcVersion110 tName 34 | `unsafeApplyCode` liftCode plcVersion110 allowedAmount 35 | 36 | carelessPolicy :: Script.Versioned Script.MintingPolicy 37 | carelessPolicy = Script.toVersioned Script.trueMintingMPScript 38 | -------------------------------------------------------------------------------- /tests/Plutus/InlineDatums.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Plutus.InlineDatums where 4 | 5 | import Plutus.Script.Utils.V3 qualified as Script 6 | import PlutusCore.Version 7 | import PlutusLedgerApi.V3 qualified as Api 8 | import PlutusTx 9 | import PlutusTx.AssocMap qualified as Map 10 | import PlutusTx.List 11 | import PlutusTx.Prelude 12 | import Prelude qualified as HS 13 | 14 | data SimpleContractDatum = FirstPaymentDatum | SecondPaymentDatum deriving (HS.Show) 15 | 16 | instance Eq SimpleContractDatum where 17 | FirstPaymentDatum == FirstPaymentDatum = True 18 | SecondPaymentDatum == SecondPaymentDatum = True 19 | _ == _ = False 20 | 21 | unstableMakeIsData ''SimpleContractDatum 22 | 23 | data SimpleContract 24 | 25 | instance Script.MultiPurposeScriptTypes SimpleContract where 26 | type SpendingDatumType SimpleContract = SimpleContractDatum 27 | 28 | {-# INLINEABLE inputDatumSpendingPurpose #-} 29 | inputDatumSpendingPurpose :: Bool -> Script.SpendingPurposeType SimpleContract 30 | inputDatumSpendingPurpose requireInlineDatum oRef _ _ Api.TxInfo {txInfoInputs} = 31 | case find ((oRef ==) . Api.txInInfoOutRef) txInfoInputs of 32 | Just (Api.TxInInfo _ Api.TxOut {Api.txOutDatum = inDatum}) | requireInlineDatum -> case inDatum of 33 | Api.OutputDatum _ -> True 34 | Api.OutputDatumHash _ -> trace "I want an inline datum, but I got a hash" False 35 | Api.NoOutputDatum -> trace "I want an inline datum, but I got neither a datum nor a hash" False 36 | Just (Api.TxInInfo _ Api.TxOut {Api.txOutDatum = inDatum}) -> case inDatum of 37 | Api.OutputDatumHash _ -> True 38 | Api.OutputDatum _ -> trace "I want a datum hash, but I got an inline datum" False 39 | Api.NoOutputDatum -> trace "I want a datum hash, but I got neither a datum nor a hash" False 40 | _ -> False 41 | 42 | compiledInputDatumSpendingPurpose :: CompiledCode (Bool -> BuiltinData -> BuiltinUnit) 43 | compiledInputDatumSpendingPurpose = $$(compile [||script||]) 44 | where 45 | script b = Script.mkMultiPurposeScript $ Script.falseTypedMultiPurposeScript `Script.withSpendingPurpose` inputDatumSpendingPurpose b 46 | 47 | requireInlineDatumInInputValidator :: Script.Versioned Script.Validator 48 | requireInlineDatumInInputValidator = 49 | Script.toVersioned 50 | $ Script.MultiPurposeScript @SimpleContract 51 | $ Script.toScript 52 | $ compiledInputDatumSpendingPurpose 53 | `unsafeApplyCode` liftCode plcVersion110 True 54 | 55 | requireHashedDatumInInputValidator :: Script.Versioned Script.Validator 56 | requireHashedDatumInInputValidator = 57 | Script.toVersioned 58 | $ Script.MultiPurposeScript @SimpleContract 59 | $ Script.toScript 60 | $ compiledInputDatumSpendingPurpose 61 | `unsafeApplyCode` liftCode plcVersion110 False 62 | 63 | data OutputDatumKind = OnlyHash | Datum | Inline 64 | 65 | makeLift ''OutputDatumKind 66 | 67 | -- | This defines three validators: @outputDatumValidator OnlyHash@ is a 68 | -- validator that only returns true if there's a continuing transaction output 69 | -- that has a datum hash that's not included in the 'txInfoData', inline datum, 70 | -- @outputDatumSpendingPurpose Datum@ requires an output datum with a hash that's in 71 | -- the 'txInfoData', and @outputDatumSpendingPurpose Inline@ only returns true if the 72 | -- output has an inline datum. 73 | {-# INLINEABLE outputDatumSpendingPurpose #-} 74 | outputDatumSpendingPurpose :: OutputDatumKind -> Script.SpendingPurposeType SimpleContract 75 | outputDatumSpendingPurpose datumKind oRef _ _ Api.TxInfo {txInfoInputs, txInfoOutputs, txInfoData} = 76 | case find ((oRef ==) . Api.txInInfoOutRef) txInfoInputs of 77 | Just (Api.TxInInfo _ Api.TxOut {txOutAddress}) 78 | | [Api.TxOut {txOutDatum}] <- filter ((txOutAddress ==) . Api.txOutAddress) txInfoOutputs -> 79 | case (datumKind, txOutDatum) of 80 | (OnlyHash, Api.OutputDatumHash h) -> not $ Map.member h txInfoData 81 | (Datum, Api.OutputDatumHash h) -> Map.member h txInfoData 82 | (Inline, Api.OutputDatum _) -> True 83 | _ -> False 84 | _ -> False 85 | 86 | compiledOutputDatumSpendingPurpose :: CompiledCode (OutputDatumKind -> BuiltinData -> BuiltinUnit) 87 | compiledOutputDatumSpendingPurpose = $$(compile [||script||]) 88 | where 89 | script b = Script.mkMultiPurposeScript $ Script.falseTypedMultiPurposeScript `Script.withSpendingPurpose` outputDatumSpendingPurpose b 90 | 91 | requireInlineDatumInOutputValidator :: Script.Versioned Script.Validator 92 | requireInlineDatumInOutputValidator = 93 | Script.toVersioned 94 | $ Script.MultiPurposeScript @() 95 | $ Script.toScript 96 | $ compiledOutputDatumSpendingPurpose 97 | `unsafeApplyCode` liftCode plcVersion110 Inline 98 | 99 | requireHashedDatumInOutputValidator :: Script.Versioned Script.Validator 100 | requireHashedDatumInOutputValidator = 101 | Script.toVersioned 102 | $ Script.MultiPurposeScript @() 103 | $ Script.toScript 104 | $ compiledOutputDatumSpendingPurpose 105 | `unsafeApplyCode` liftCode plcVersion110 Datum 106 | 107 | requireOnlyHashedDatumInOutputValidator :: Script.Versioned Script.Validator 108 | requireOnlyHashedDatumInOutputValidator = 109 | Script.toVersioned 110 | $ Script.MultiPurposeScript @() 111 | $ Script.toScript 112 | $ compiledOutputDatumSpendingPurpose 113 | `unsafeApplyCode` liftCode plcVersion110 OnlyHash 114 | -------------------------------------------------------------------------------- /tests/Plutus/MultiPurpose.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | -- | This modules defines a small dummy smart contract which can both be used as 5 | -- a spending or minting script. The smart contract is parameterized with a 6 | -- transaction id. It allows the minting of as many NFTs as there are outputs to 7 | -- this transactions. Each NFT has to be minted alone, in a transaction that 8 | -- consumes exactly one of these outputs. They must be put at the script address 9 | -- to allow for the spending purpose to be used, with a datum containing an 10 | -- integer. This integer must be equal to the index at which the TxOutRef was 11 | -- produced in the parameter transaction. Then, if the datum is 0, the token can 12 | -- be burned while consuming its UTXO. If is it greater than 0, 1 by 1 steps can 13 | -- decrease the counter until it reaches 0, at which point it can be burned.o 14 | module Plutus.MultiPurpose where 15 | 16 | import Plutus.Script.Utils.V3 qualified as Script 17 | import PlutusLedgerApi.V1.Value qualified as Api 18 | import PlutusLedgerApi.V3 qualified as Api 19 | import PlutusTx 20 | import PlutusTx.AssocMap qualified as Map 21 | import PlutusTx.List 22 | import PlutusTx.Prelude 23 | import Prelude qualified as HS 24 | 25 | instance Eq Api.ScriptPurpose where 26 | Api.Spending r1 == Api.Spending r2 = r1 == r2 27 | Api.Minting r1 == Api.Minting r2 = r1 == r2 28 | _ == _ = False 29 | 30 | data MintingRed = MintToken Api.TxOutRef | BurnToken 31 | deriving (HS.Show, HS.Eq) 32 | 33 | instance Eq MintingRed where 34 | (==) = (HS.==) 35 | 36 | PlutusTx.unstableMakeIsData ''MintingRed 37 | PlutusTx.makeLift ''MintingRed 38 | 39 | data SpendingRed = Step | Close 40 | deriving (HS.Show, HS.Eq) 41 | 42 | instance Eq SpendingRed where 43 | (==) = (HS.==) 44 | 45 | PlutusTx.unstableMakeIsData ''SpendingRed 46 | PlutusTx.makeLift ''SpendingRed 47 | 48 | {-# INLINEABLE txOutRefToToken #-} 49 | txOutRefToToken :: Api.TxOutRef -> Api.TokenName 50 | txOutRefToToken (Api.TxOutRef (Api.TxId txId) n) = Api.TokenName $ sha2_256 (txId <> encodeInteger n) 51 | 52 | {-# INLINEABLE encodeInteger #-} 53 | encodeInteger :: Integer -> Api.BuiltinByteString 54 | encodeInteger x 55 | | x < 256 = consByteString x "" 56 | | otherwise = consByteString (x `modulo` 256) $ encodeInteger (x `quotient` 256) 57 | 58 | data MPTag 59 | 60 | instance Script.MultiPurposeScriptTypes MPTag where 61 | type SpendingRedeemerType MPTag = SpendingRed 62 | type SpendingDatumType MPTag = Integer 63 | type MintingRedeemerType MPTag = MintingRed 64 | 65 | {-# INLINEABLE mpMintingPurpose #-} 66 | mpMintingPurpose :: Api.TxId -> Script.MintingPurposeType MPTag 67 | mpMintingPurpose txId cs@(Api.CurrencySymbol hash) (MintToken oRef@(Api.TxOutRef txId' ix)) (Api.TxInfo {..}) = 68 | let requiredMintedValue = Api.assetClassValue (Api.assetClass cs (txOutRefToToken oRef)) 1 69 | in Script.toValue txInfoMint 70 | == requiredMintedValue 71 | && length 72 | [ val 73 | | Api.TxOut (Api.Address (Api.ScriptCredential (Api.ScriptHash hash')) _) val (Api.OutputDatum (Api.Datum dat)) _ <- txInfoOutputs, 74 | hash == hash', 75 | Script.currencyValueOf val cs == requiredMintedValue, 76 | Api.fromBuiltinData dat == Just ix 77 | ] 78 | == 1 79 | && oRef 80 | `elem` (Api.txInInfoOutRef <$> txInfoInputs) 81 | && txId 82 | == txId' 83 | mpMintingPurpose _ cs@(Api.CurrencySymbol hash) BurnToken (Api.TxInfo {..}) = 84 | Api.Value 85 | ( Map.singleton cs 86 | $ Map.safeFromList 87 | [ (tn, n) 88 | | Api.TxInInfo scriptRef (Api.TxOut (Api.Address (Api.ScriptCredential (Api.ScriptHash hash')) _) val (Api.OutputDatum (Api.Datum dat)) _) <- txInfoInputs, 89 | hash' == hash, 90 | Api.fromBuiltinData @Integer dat == Just 0, 91 | (cs', tn, n) <- Api.flattenValue val, 92 | cs == cs', 93 | Map.lookup (Api.Spending scriptRef) txInfoRedeemers == Just (Api.Redeemer (Api.toBuiltinData Close)) 94 | ] 95 | ) 96 | == negate (Script.toValue txInfoMint) 97 | 98 | {-# INLINEABLE mpSpendingPurpose #-} 99 | mpSpendingPurpose :: Script.SpendingPurposeType MPTag 100 | mpSpendingPurpose oRef (Just x) Close Api.TxInfo {..} 101 | | x == 0 = 102 | length 103 | [ h 104 | | Api.TxInInfo oRef' (Api.TxOut (Api.Address (Api.ScriptCredential (Api.ScriptHash h)) _) _ _ _) <- txInfoInputs, 105 | oRef == oRef', 106 | Map.lookup (Api.Minting (Api.CurrencySymbol h)) txInfoRedeemers == Just (Api.Redeemer (Api.toBuiltinData BurnToken)) 107 | ] 108 | == 1 109 | mpSpendingPurpose oRef (Just x) Step Api.TxInfo {..} = 110 | length 111 | [ h 112 | | Api.TxInInfo oRef' (Api.TxOut (Api.Address (Api.ScriptCredential (Api.ScriptHash h)) _) val _ _) <- txInfoInputs, 113 | oRef == oRef', 114 | Api.TxOut (Api.Address (Api.ScriptCredential (Api.ScriptHash h')) _) val' (Api.OutputDatum (Api.Datum dat')) _ <- txInfoOutputs, 115 | h' == h, 116 | Script.noAdaValue val == Script.noAdaValue val', 117 | Api.fromBuiltinData dat' == Just (x - 1) 118 | ] 119 | == 1 120 | mpSpendingPurpose _ _ _ _ = False 121 | 122 | mpScript :: Api.TxId -> Script.MultiPurposeScript MPTag 123 | mpScript txId = Script.MultiPurposeScript $ Script.toScript $ $$(PlutusTx.compile [||script||]) `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef txId 124 | where 125 | script txId' = 126 | Script.mkMultiPurposeScript 127 | $ Script.falseTypedMultiPurposeScript 128 | `Script.withSpendingPurpose` mpSpendingPurpose 129 | `Script.withMintingPurpose` mpMintingPurpose txId' 130 | -------------------------------------------------------------------------------- /tests/Plutus/ProposingScript.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Plutus.ProposingScript where 4 | 5 | import Plutus.Script.Utils.V3 qualified as Script 6 | import PlutusLedgerApi.V3 qualified as Api 7 | import PlutusTx 8 | import PlutusTx.AssocMap qualified as Map 9 | import PlutusTx.Prelude 10 | 11 | {-# INLINEABLE checkParameterChangeProposingPurpose #-} 12 | checkParameterChangeProposingPurpose :: Script.ProposingPurposeType () 13 | checkParameterChangeProposingPurpose _ (Api.ProposalProcedure _ _ (Api.ParameterChange _ (Api.ChangedParameters dat) _)) _ _ = 14 | let innerMap = unsafeFromBuiltinData @(Map.Map Integer Integer) dat 15 | in ((Map.toList innerMap == [(0, 100)]) || traceError "wrong map") 16 | checkParameterChangeProposingPurpose _ _ _ _ = traceError "Wrong proposal procedure" 17 | 18 | checkProposingScript :: Script.Versioned Script.Script 19 | checkProposingScript = 20 | Script.toVersioned 21 | $ Script.MultiPurposeScript @() 22 | $ Script.toScript $$(compile [||script||]) 23 | where 24 | script = 25 | Script.mkMultiPurposeScript 26 | $ Script.falseTypedMultiPurposeScript 27 | `Script.withProposingPurpose` checkParameterChangeProposingPurpose 28 | 29 | -- | A dummy false proposing validator 30 | alwaysFalseProposingValidator :: Script.Versioned Script.Script 31 | alwaysFalseProposingValidator = 32 | Script.toVersioned 33 | $ Script.MultiPurposeScript @() 34 | $ Script.toScript $$(compile [||script||]) 35 | where 36 | script = 37 | Script.mkMultiPurposeScript 38 | $ Script.falseTypedMultiPurposeScript 39 | `Script.withProposingPurpose` (\_ _ () () -> False) 40 | 41 | -- | A dummy true proposing validator 42 | alwaysTrueProposingValidator :: Script.Versioned Script.Script 43 | alwaysTrueProposingValidator = 44 | Script.toVersioned 45 | $ Script.MultiPurposeScript @() 46 | $ Script.toScript $$(compile [||script||]) 47 | where 48 | script = 49 | Script.mkMultiPurposeScript 50 | $ Script.falseTypedMultiPurposeScript 51 | `Script.withProposingPurpose` (\_ _ () () -> True) 52 | -------------------------------------------------------------------------------- /tests/Plutus/ReferenceInputs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} 3 | 4 | module Plutus.ReferenceInputs where 5 | 6 | import Plutus.Script.Utils.V2 qualified as Script 7 | import PlutusLedgerApi.V2 qualified as Api 8 | import PlutusTx 9 | import PlutusTx.AssocMap qualified as Map 10 | import PlutusTx.List 11 | import PlutusTx.Prelude 12 | import Prelude qualified as HS 13 | 14 | -- Foo, Bar and Baz are dummy scripts to test reference inputs. They serve no 15 | -- purpose and make no real sense. 16 | -- 17 | -- Foo contains a pkh in its datum. It can only be spent by ANOTHER public key. 18 | -- 19 | -- Bar has no datum nor redeemer. Its outputs can only be spent by a public key 20 | -- who can provide a Foo UTxO containing its pkh as reference input (that is a 21 | -- UTxO they could not actually spend, according the the design of Foo). 22 | -- 23 | -- Baz has no datum nor redeemer. Its outputs can only be spent when a reference 24 | -- input is provided with a hashed datum contain the integer 10. 25 | -- 26 | -- The datum in Foo outputs in expected to be inlined. 27 | 28 | data Foo 29 | 30 | newtype FooDatum = FooDatum Api.PubKeyHash deriving (HS.Show) 31 | 32 | instance Eq FooDatum where 33 | FooDatum pkh1 == FooDatum pkh2 = pkh1 == pkh2 34 | 35 | makeLift ''FooDatum 36 | unstableMakeIsData ''FooDatum 37 | 38 | instance Script.ValidatorTypes Foo where 39 | type RedeemerType Foo = () 40 | type DatumType Foo = FooDatum 41 | 42 | -- | Outputs can only be spent by pks whose hash is not the one in the 43 | -- datum. 44 | {-# INLINEABLE fooValidator #-} 45 | fooValidator :: FooDatum -> () -> Api.ScriptContext -> Bool 46 | fooValidator (FooDatum pkh) _ (Api.ScriptContext txInfo _) = 47 | pkh `notElem` Api.txInfoSignatories txInfo 48 | 49 | fooTypedValidator :: Script.TypedValidator Foo 50 | fooTypedValidator = 51 | let wrap = Script.mkUntypedValidator 52 | in Script.mkTypedValidator @Foo 53 | $$(compile [||fooValidator||]) 54 | $$(compile [||wrap||]) 55 | 56 | -- | Outputs can only be spent by pks who provide a reference input to 57 | -- a Foo in which they are mentioned (in an inlined datum). 58 | {-# INLINEABLE barValidator #-} 59 | barValidator :: () -> () -> Api.ScriptContext -> Bool 60 | barValidator _ _ (Api.ScriptContext txInfo _) = 61 | any f (Api.txInfoReferenceInputs txInfo) 62 | where 63 | f :: Api.TxInInfo -> Bool 64 | f (Api.TxInInfo _ (Api.TxOut _ _ (Api.OutputDatum (Api.Datum datum)) _)) = 65 | case Api.fromBuiltinData @FooDatum datum of 66 | Nothing -> False 67 | Just (FooDatum pkh) -> pkh `elem` Api.txInfoSignatories txInfo 68 | f _ = False 69 | 70 | barTypedValidator :: Script.TypedValidator () 71 | barTypedValidator = 72 | let wrap = Script.mkUntypedValidator 73 | in Script.mkTypedValidator 74 | $$(compile [||barValidator||]) 75 | $$(compile [||wrap||]) 76 | 77 | {-# INLINEABLE bazValidator #-} 78 | bazValidator :: () -> () -> Api.ScriptContext -> Bool 79 | bazValidator _ _ context = 80 | let info = Api.scriptContextTxInfo context 81 | refInputs = Api.txInfoReferenceInputs info 82 | txData = Api.txInfoData info 83 | in case refInputs of 84 | [myRefInput] -> 85 | let Api.TxOut _ _ dat _ = Api.txInInfoResolved myRefInput 86 | in case dat of 87 | (Api.OutputDatumHash hash) -> case Map.lookup hash txData of 88 | Nothing -> False 89 | Just (Api.Datum a) -> unsafeFromBuiltinData @Integer a == 10 90 | _ -> False 91 | _ -> False 92 | 93 | bazTypedValidator :: Script.TypedValidator () 94 | bazTypedValidator = 95 | let wrap = Script.mkUntypedValidator 96 | in Script.mkTypedValidator 97 | $$(compile [||bazValidator||]) 98 | $$(compile [||wrap||]) 99 | -------------------------------------------------------------------------------- /tests/Plutus/ReferenceScripts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} 3 | 4 | module Plutus.ReferenceScripts where 5 | 6 | import Plutus.Script.Utils.V2 qualified as Script 7 | import PlutusLedgerApi.V2 qualified as Api 8 | import PlutusTx 9 | import PlutusTx.List 10 | import PlutusTx.Prelude 11 | 12 | -- | This validator ensures that the given public key signs the 13 | -- transaction. 14 | requireSignerValidator :: Api.PubKeyHash -> Script.TypedValidator () 15 | requireSignerValidator = 16 | Script.mkTypedValidatorParam 17 | $$(compile [||val||]) 18 | $$(compile [||wrap||]) 19 | where 20 | val :: Api.PubKeyHash -> () -> () -> Api.ScriptContext -> Bool 21 | val pkh _ _ (Api.ScriptContext txInfo _) = 22 | traceIfFalse "the required signer is missing" 23 | $ elem pkh (Api.txInfoSignatories txInfo) 24 | 25 | wrap = Script.mkUntypedValidator 26 | 27 | -- | This validator ensures that there is a transaction input that has 28 | -- a reference script with the given hash. 29 | requireRefScriptValidator :: Api.ScriptHash -> Script.TypedValidator () 30 | requireRefScriptValidator = 31 | Script.mkTypedValidatorParam 32 | $$(compile [||val||]) 33 | $$(compile [||wrap||]) 34 | where 35 | val :: Api.ScriptHash -> () -> () -> Api.ScriptContext -> Bool 36 | val expectedScriptHash _ _ (Api.ScriptContext txInfo _) = 37 | traceIfFalse "there is no reference input with the correct script hash" 38 | $ any 39 | ( \(Api.TxInInfo _ (Api.TxOut _ _ _ mRefScriptHash)) -> 40 | Just expectedScriptHash == mRefScriptHash 41 | ) 42 | (Api.txInfoReferenceInputs txInfo) 43 | 44 | wrap = Script.mkUntypedValidator 45 | -------------------------------------------------------------------------------- /tests/Plutus/Withdrawals.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Plutus.Withdrawals where 4 | 5 | import Plutus.Script.Utils.V3 qualified as Script 6 | import PlutusLedgerApi.V3 qualified as Api 7 | import PlutusTx 8 | import PlutusTx.AssocMap qualified as Map 9 | import PlutusTx.Prelude 10 | 11 | {-# INLINEABLE checkWithdrawalPurpose #-} 12 | checkWithdrawalPurpose :: Script.RewardingPurposeType' Integer Api.TxInfo 13 | checkWithdrawalPurpose cred quantity (Api.TxInfo {txInfoWdrl}) = 14 | case Map.toList txInfoWdrl of 15 | [(cred', Api.Lovelace n)] -> 16 | if cred == cred' 17 | then (n == quantity) || traceError "Wrong quantity." 18 | else traceError "Wrong credential." 19 | _ -> traceError "Wrong withdrawal." 20 | 21 | checkWithdrawalMPScript :: Script.MultiPurposeScript () 22 | checkWithdrawalMPScript = 23 | Script.MultiPurposeScript $ Script.toScript $$(PlutusTx.compile [||script||]) 24 | where 25 | script = 26 | Script.mkMultiPurposeScript 27 | $ Script.falseTypedMultiPurposeScript 28 | `Script.withRewardingPurpose` checkWithdrawalPurpose 29 | 30 | trueWithdrawalMPScript :: Script.MultiPurposeScript () 31 | trueWithdrawalMPScript = 32 | Script.MultiPurposeScript $ Script.toScript $$(PlutusTx.compile [||script||]) 33 | where 34 | script = 35 | Script.mkMultiPurposeScript 36 | $ Script.falseTypedMultiPurposeScript 37 | `Script.withRewardingPurpose` ((\_ _ _ -> True) :: Script.RewardingPurposeType' Integer Api.TxInfo) 38 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | import Spec.Attack qualified as Attack 2 | import Spec.Balancing qualified as Balancing 3 | import Spec.BasicUsage qualified as BasicUsage 4 | import Spec.InitialDistribution qualified as InititalDistribution 5 | import Spec.InlineDatums qualified as InlineDatums 6 | import Spec.Ltl qualified as Ltl 7 | import Spec.MinAda qualified as MinAda 8 | import Spec.MultiPurpose qualified as MultiPurpose 9 | import Spec.ProposingScript qualified as ProposingScript 10 | import Spec.ReferenceInputs qualified as ReferenceInputs 11 | import Spec.ReferenceScripts qualified as ReferenceScripts 12 | import Spec.Slot qualified as Slot 13 | import Spec.Tweak qualified as Tweak 14 | import Spec.Withdrawals qualified as Withdrawals 15 | import Test.Tasty 16 | 17 | main :: IO () 18 | main = 19 | defaultMain $ 20 | testGroup 21 | "cooked-validators" 22 | [ Attack.tests, 23 | Balancing.tests, 24 | BasicUsage.tests, 25 | InititalDistribution.tests, 26 | InlineDatums.tests, 27 | Ltl.tests, 28 | MinAda.tests, 29 | MultiPurpose.tests, 30 | ProposingScript.tests, 31 | ReferenceInputs.tests, 32 | ReferenceScripts.tests, 33 | Slot.tests, 34 | Tweak.tests, 35 | Withdrawals.tests 36 | ] 37 | -------------------------------------------------------------------------------- /tests/Spec/Attack.hs: -------------------------------------------------------------------------------- 1 | module Spec.Attack (tests) where 2 | 3 | import Spec.Attack.DatumHijacking qualified as DatumHijacking 4 | import Spec.Attack.DoubleSat qualified as DoubleSat 5 | import Spec.Attack.DupToken qualified as DupToken 6 | import Test.Tasty 7 | 8 | tests :: TestTree 9 | tests = 10 | testGroup 11 | "Attack DSL" 12 | [ DupToken.tests, 13 | DatumHijacking.tests, 14 | DoubleSat.tests 15 | ] 16 | -------------------------------------------------------------------------------- /tests/Spec/Attack/DupToken.hs: -------------------------------------------------------------------------------- 1 | module Spec.Attack.DupToken (tests) where 2 | 3 | import Cooked 4 | import Data.Set qualified as Set 5 | import Plutus.Attack.DupToken 6 | import Plutus.Script.Utils.V3 qualified as Script 7 | import PlutusLedgerApi.V1.Value qualified as Api 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | 11 | dupTokenTrace :: (MonadBlockChain m) => Script.Versioned Script.MintingPolicy -> Api.TokenName -> Integer -> Wallet -> m () 12 | dupTokenTrace pol tName amount recipient = validateTxSkel_ skel 13 | where 14 | skel = 15 | let mints = txSkelMintsFromList [mint pol emptyTxSkelRedeemer tName amount] 16 | mintedValue = txSkelMintsValue mints 17 | in txSkelTemplate 18 | { txSkelMints = mints, 19 | txSkelOuts = [recipient `receives` Value mintedValue], 20 | txSkelSigners = [wallet 3] 21 | } 22 | 23 | tests :: TestTree 24 | tests = 25 | testGroup 26 | "token duplication attack" 27 | [ testGroup "unit tests on a 'TxSkel'" $ 28 | let attacker = wallet 6 29 | tName1 = Api.TokenName "MockToken1" 30 | tName2 = Api.TokenName "MockToken2" 31 | pol1 = carefulPolicy tName1 1 32 | pol2 = carelessPolicy 33 | ac1 = Api.assetClass (Script.toCurrencySymbol pol1) tName1 34 | ac2 = Api.assetClass (Script.toCurrencySymbol pol2) tName2 35 | skelIn = 36 | txSkelTemplate 37 | { txSkelMints = 38 | txSkelMintsFromList 39 | [ mint pol1 emptyTxSkelRedeemer tName1 5, 40 | mint pol2 emptyTxSkelRedeemer tName2 7 41 | ], 42 | txSkelOuts = 43 | [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Script.lovelace 1234), 44 | wallet 2 `receives` Value (Api.assetClassValue ac2 2) 45 | ], 46 | txSkelSigners = [wallet 3] 47 | } 48 | skelOut select = runTweak (dupTokenAttack select attacker) skelIn 49 | skelExpected v1 v2 = 50 | let increment = Api.assetClassValue ac1 (v1 - 5) <> Api.assetClassValue ac2 (v2 - 7) 51 | in [ Right 52 | ( increment, 53 | txSkelTemplate 54 | { txSkelLabel = Set.singleton $ TxLabel DupTokenLbl, 55 | txSkelMints = 56 | txSkelMintsFromList 57 | [ mint pol1 emptyTxSkelRedeemer tName1 v1, 58 | mint pol2 emptyTxSkelRedeemer tName2 v2 59 | ], 60 | txSkelOuts = 61 | [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Script.lovelace 1234), 62 | wallet 2 `receives` Value (Api.assetClassValue ac2 2), 63 | attacker `receives` Value increment 64 | ], 65 | txSkelSigners = [wallet 3] 66 | } 67 | ) 68 | ] 69 | in [ testCase "add one token in every asset class" $ 70 | skelExpected 6 8 @=? mcrValue <$> skelOut (\_ n -> n + 1), 71 | testCase "no modified transaction if no increase in value specified" $ 72 | [] @=? mcrValue <$> skelOut (\_ n -> n), 73 | testCase "add tokens depending on the asset class" $ 74 | skelExpected 10 7 @=? mcrValue <$> skelOut (\ac n -> if ac == ac1 then n + 5 else n) 75 | ], 76 | testCooked "careful minting policy" $ 77 | let tName = Api.TokenName "MockToken" 78 | pol = carefulPolicy tName 1 79 | in mustFailInPhase2Test $ 80 | somewhere 81 | (dupTokenAttack (\_ n -> n + 1) (wallet 6)) 82 | (dupTokenTrace pol tName 1 (wallet 1)), 83 | testCooked "careless minting policy" $ 84 | mustSucceedTest $ 85 | somewhere 86 | (dupTokenAttack (\_ n -> n + 1) (wallet 6)) 87 | (dupTokenTrace carelessPolicy (Api.TokenName "MockToken") 1 (wallet 1)), 88 | testCase "pre-existing tokens are left alone" $ 89 | let attacker = wallet 6 90 | pol = carelessPolicy 91 | tName1 = Api.TokenName "mintedToken" 92 | ac1 = Api.assetClass (Script.toCurrencySymbol pol) tName1 93 | ac2 = Api.assetClass (Script.toCurrencySymbol Script.trueMintingMPScript) (Api.TokenName "preExistingToken") 94 | skelIn = 95 | txSkelTemplate 96 | { txSkelMints = txSkelMintsFromList [mint pol emptyTxSkelRedeemer tName1 1], 97 | txSkelOuts = [wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Api.assetClassValue ac2 2)], 98 | txSkelSigners = [wallet 2] 99 | } 100 | skelExpected = 101 | [ Right 102 | ( Api.assetClassValue ac1 1, 103 | txSkelTemplate 104 | { txSkelLabel = Set.singleton $ TxLabel DupTokenLbl, 105 | txSkelMints = txSkelMintsFromList [mint pol emptyTxSkelRedeemer tName1 2], 106 | txSkelOuts = 107 | [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Api.assetClassValue ac2 2), 108 | attacker `receives` Value (Api.assetClassValue ac1 1) 109 | ], 110 | txSkelSigners = [wallet 2] 111 | } 112 | ) 113 | ] 114 | skelOut = runTweak (dupTokenAttack (\_ i -> i + 1) attacker) skelIn 115 | in skelExpected @=? mcrValue <$> skelOut 116 | ] 117 | -------------------------------------------------------------------------------- /tests/Spec/BasicUsage.hs: -------------------------------------------------------------------------------- 1 | module Spec.BasicUsage where 2 | 3 | import Cooked 4 | import Data.Map qualified as Map 5 | import Plutus.Script.Utils.V3 qualified as Script 6 | import PlutusLedgerApi.V3 qualified as Api 7 | import Test.Tasty 8 | 9 | alice, bob, carrie :: Wallet 10 | alice = wallet 1 11 | bob = wallet 2 12 | carrie = wallet 3 13 | 14 | pkToPk :: (MonadBlockChain m) => Wallet -> Wallet -> Integer -> m () 15 | pkToPk sender recipient amount = 16 | validateTxSkel_ $ 17 | txSkelTemplate 18 | { txSkelOuts = [recipient `receives` Value (Script.ada amount)], 19 | txSkelSigners = [sender] 20 | } 21 | 22 | multiplePksToPks :: (MonadBlockChain m) => m () 23 | multiplePksToPks = 24 | do 25 | pkToPk alice bob 10 26 | pkToPk bob carrie 10 27 | pkToPk carrie alice 10 28 | 29 | mintingQuickValue :: (MonadBlockChain m) => m () 30 | mintingQuickValue = 31 | validateTxSkel_ 32 | txSkelTemplate 33 | { txSkelMints = txSkelMintsFromList [mint Script.trueMintingMPScript emptyTxSkelRedeemer (Api.TokenName "banana") 10], 34 | txSkelOuts = [alice `receives` Value (Script.multiPurposeScriptValue Script.trueMintingMPScript (Api.TokenName "banana") 10)], 35 | txSkelSigners = [alice] 36 | } 37 | 38 | payToAlwaysTrueValidator :: (MonadBlockChain m) => m Api.TxOutRef 39 | payToAlwaysTrueValidator = 40 | head 41 | <$> ( validateTxSkel' $ 42 | txSkelTemplate 43 | { txSkelOuts = [Script.trueSpendingMPScript @() `receives` Value (Script.ada 10)], 44 | txSkelSigners = [alice] 45 | } 46 | ) 47 | 48 | consumeAlwaysTrueValidator :: (MonadBlockChain m) => m () 49 | consumeAlwaysTrueValidator = do 50 | outref <- payToAlwaysTrueValidator 51 | validateTxSkel_ $ 52 | txSkelTemplate 53 | { txSkelIns = Map.fromList [(outref, someTxSkelRedeemer ())], 54 | txSkelOuts = [alice `receives` Value (Script.ada 10)], 55 | txSkelSigners = [alice] 56 | } 57 | 58 | tests :: TestTree 59 | tests = 60 | testGroup 61 | "Basic usage" 62 | [ testCooked "Payment from alice to bob, with auto-balancing" $ mustSucceedTest $ pkToPk alice bob 10, 63 | testCooked "Circular payments of 10 ada between alice bob and carrie" $ mustSucceedTest multiplePksToPks, 64 | testCooked "Minting quick tokens" $ mustSucceedTest mintingQuickValue, 65 | testCooked "Paying to the always true validator" $ mustSucceedTest payToAlwaysTrueValidator, 66 | testCooked "Consuming the always true validator" $ mustSucceedTest consumeAlwaysTrueValidator 67 | ] 68 | -------------------------------------------------------------------------------- /tests/Spec/InitialDistribution.hs: -------------------------------------------------------------------------------- 1 | module Spec.InitialDistribution where 2 | 3 | import Cooked 4 | import Data.Map qualified as Map 5 | import Data.Maybe (catMaybes) 6 | import Plutus.Script.Utils.V3 qualified as Script 7 | import Test.Tasty 8 | 9 | alice, bob :: Wallet 10 | (alice, bob) = (wallet 1, wallet 2) 11 | 12 | -- | An initial distribution where alice owns a UTxO with a datum of 13 | -- type Int and value 10 for each datum kind 14 | initialDistributionWithDatum :: InitialDistribution 15 | initialDistributionWithDatum = 16 | InitialDistribution $ [receives alice] <*> ([VisibleHashedDatum, HiddenHashedDatum] <*> [10 :: Integer]) 17 | 18 | -- | An initial distribution where alice owns a UTxO with a reference 19 | -- script corresponding to the always succeed validators and bob owns 20 | -- 2 UTxOs with 100 ADA 21 | initialDistributionWithReferenceScript :: InitialDistribution 22 | initialDistributionWithReferenceScript = 23 | InitialDistribution $ 24 | (alice `receives` (Value (Script.ada 2) <&&> ReferenceScript (Script.trueSpendingMPScript @()))) 25 | : replicate 2 (bob `receives` Value (Script.ada 100)) 26 | 27 | getValueFromInitialDatum :: (MonadBlockChain m) => m [Integer] 28 | getValueFromInitialDatum = do 29 | aliceUtxos <- runUtxoSearch $ utxosOwnedBySearch alice 30 | catMaybes <$> mapM (typedDatumFromTxOutRef @Integer . fst) aliceUtxos 31 | 32 | spendReferenceAlwaysTrueValidator :: (MonadBlockChain m) => m () 33 | spendReferenceAlwaysTrueValidator = do 34 | [(referenceScriptTxOutRef, _)] <- runUtxoSearch $ utxosOwnedBySearch alice 35 | (scriptTxOutRef : _) <- 36 | validateTxSkel' $ 37 | txSkelTemplate 38 | { txSkelOuts = [Script.trueSpendingMPScript @() `receives` Value (Script.ada 2)], 39 | txSkelSigners = [bob] 40 | } 41 | validateTxSkel_ $ 42 | txSkelTemplate 43 | { txSkelOuts = [alice `receives` Value (Script.ada 2)], 44 | txSkelIns = Map.singleton scriptTxOutRef $ someTxSkelRedeemer () `withReferenceInput` referenceScriptTxOutRef, 45 | txSkelSigners = [bob] 46 | } 47 | 48 | tests :: TestTree 49 | tests = 50 | testGroup 51 | "Initial distributions" 52 | [ testCooked "Reading datums placed in the initial distribution, inlined or hashed" $ 53 | mustSucceedTest getValueFromInitialDatum 54 | `withInitDist` initialDistributionWithDatum 55 | `withResultProp` (testBool . (== [10, 10])), 56 | testCooked "Spending a script placed as a reference script in the initial distribution" $ 57 | mustSucceedTest spendReferenceAlwaysTrueValidator 58 | `withInitDist` initialDistributionWithReferenceScript 59 | ] 60 | -------------------------------------------------------------------------------- /tests/Spec/MinAda.hs: -------------------------------------------------------------------------------- 1 | module Spec.MinAda where 2 | 3 | import Cooked 4 | import Optics.Core ((^.)) 5 | import Plutus.Script.Utils.Value qualified as Script 6 | import PlutusLedgerApi.V1.Value qualified as Api 7 | import PlutusTx qualified 8 | import PlutusTx.Eq qualified as PlutusTx 9 | import Test.Tasty 10 | 11 | newtype HeavyDatum = HeavyDatum [Integer] 12 | deriving (Show, Eq) 13 | 14 | PlutusTx.unstableMakeIsData ''HeavyDatum 15 | 16 | instance PlutusTx.Eq HeavyDatum where 17 | (==) = (==) 18 | 19 | heavyDatum :: HeavyDatum 20 | heavyDatum = HeavyDatum (take 100 [0 ..]) 21 | 22 | instance PrettyCooked HeavyDatum where 23 | prettyCookedOpt opts (HeavyDatum ints) = prettyItemizeNoTitle opts "-" ints 24 | 25 | paymentWithMinAda :: (MonadBlockChain m) => m Integer 26 | paymentWithMinAda = do 27 | tx <- 28 | validateTxSkel 29 | txSkelTemplate 30 | { txSkelOuts = [wallet 2 `receives` VisibleHashedDatum heavyDatum], 31 | txSkelSigners = [wallet 1] 32 | } 33 | Api.getLovelace . (^. Script.adaL) . txSkelOutValue . snd . (!! 0) <$> utxosFromCardanoTx tx 34 | 35 | paymentWithoutMinAda :: (MonadBlockChain m) => Integer -> m () 36 | paymentWithoutMinAda paidLovelaces = do 37 | validateTxSkel_ 38 | txSkelTemplate 39 | { txSkelOuts = [wallet 2 `receives` (FixedValue (Script.lovelace paidLovelaces) <&&> VisibleHashedDatum heavyDatum)], 40 | txSkelSigners = [wallet 1] 41 | } 42 | 43 | tests :: TestTree 44 | tests = 45 | testGroup 46 | "MinAda auto adjustment of transaction outputs" 47 | [ testCooked "adjusted transaction passes" $ mustSucceedTest paymentWithMinAda, 48 | testCooked "adjusted transaction contains minimal amount" $ mustFailInPhase1Test $ paymentWithMinAda >>= paymentWithoutMinAda . (+ (-1)) 49 | ] 50 | -------------------------------------------------------------------------------- /tests/Spec/MultiPurpose.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Spec.MultiPurpose where 4 | 5 | import Cooked 6 | import Data.Default 7 | import Data.Map qualified as HMap 8 | import Plutus.MultiPurpose 9 | import Plutus.Script.Utils.V3 qualified as Script 10 | import PlutusLedgerApi.V1.Value qualified as Api 11 | import PlutusLedgerApi.V3 qualified as Api 12 | import Prettyprinter qualified as PP 13 | import Test.Tasty 14 | 15 | instance PrettyCooked MintingRed where 16 | prettyCooked = PP.viaShow 17 | 18 | instance PrettyCooked SpendingRed where 19 | prettyCooked = PP.viaShow 20 | 21 | alice, bob :: Wallet 22 | alice = wallet 1 23 | bob = wallet 2 24 | 25 | runScript :: (MonadModalBlockChain m) => m () 26 | runScript = do 27 | [oRef@(Api.TxOutRef txId _), oRef', oRef''] <- 28 | validateTxSkel' $ 29 | txSkelTemplate 30 | { txSkelOuts = 31 | [ alice `receives` Value (Script.ada 3), 32 | alice `receives` Value (Script.ada 5) 33 | ], 34 | txSkelSigners = [bob] 35 | } 36 | 37 | script <- define "My multipurpose script" $ mpScript txId 38 | let (mintSkel1, _, tn1) = mkMintSkel alice oRef script 39 | (mintSkel2, mintValue2, tn2) = mkMintSkel alice oRef' script 40 | (mintSkel3, mintValue3, tn3) = mkMintSkel bob oRef'' script 41 | 42 | (oRefScript : _) <- validateTxSkel' mintSkel1 43 | (oRefScript1 : _) <- validateTxSkel' mintSkel2 44 | (oRefScript2 : _) <- validateTxSkel' mintSkel3 45 | 46 | (oRefScript1' : oRefScript2' : _) <- 47 | validateTxSkel' $ 48 | txSkelTemplate 49 | { txSkelSigners = [alice], 50 | txSkelIns = 51 | HMap.fromList 52 | [ (oRefScript, someTxSkelRedeemer Close), 53 | (oRefScript1, someTxSkelRedeemer Step), 54 | (oRefScript2, someTxSkelRedeemer Step) 55 | ], 56 | txSkelOuts = 57 | [ script `receives` (InlineDatum (0 :: Integer) <&&> Value mintValue2), 58 | script `receives` (InlineDatum (1 :: Integer) <&&> Value mintValue3) 59 | ], 60 | txSkelMints = txSkelMintsFromList [burn script (someTxSkelRedeemer BurnToken) tn1 1] 61 | } 62 | 63 | (oRefScript2'' : _) <- 64 | validateTxSkel' $ 65 | txSkelTemplate 66 | { txSkelSigners = [bob], 67 | txSkelIns = 68 | HMap.fromList 69 | [ (oRefScript1', someTxSkelRedeemer Close), 70 | (oRefScript2', someTxSkelRedeemer Step) 71 | ], 72 | txSkelOuts = 73 | [ script `receives` (InlineDatum (0 :: Integer) <&&> Value mintValue3) 74 | ], 75 | txSkelMints = txSkelMintsFromList [burn script (someTxSkelRedeemer BurnToken) tn2 1] 76 | } 77 | 78 | validateTxSkel_ $ 79 | txSkelTemplate 80 | { txSkelSigners = [alice], 81 | txSkelIns = HMap.singleton oRefScript2'' (someTxSkelRedeemer Close), 82 | txSkelMints = txSkelMintsFromList [burn script (someTxSkelRedeemer BurnToken) tn3 1] 83 | } 84 | where 85 | mkMintSkel :: Wallet -> Api.TxOutRef -> Script.MultiPurposeScript MPTag -> (TxSkel, Api.Value, Api.TokenName) 86 | mkMintSkel signer oRef@(Api.TxOutRef _ ix) script = 87 | let tn = txOutRefToToken oRef 88 | mints = txSkelMintsFromList [mint script (someTxSkelRedeemer (MintToken oRef)) tn 1] 89 | mintValue = txSkelMintsValue mints 90 | in ( txSkelTemplate 91 | { txSkelIns = HMap.singleton oRef emptyTxSkelRedeemer, 92 | txSkelMints = mints, 93 | txSkelOuts = [script `receives` (InlineDatum ix <&&> Value (txSkelMintsValue mints))], 94 | txSkelSigners = [signer] 95 | }, 96 | mintValue, 97 | tn 98 | ) 99 | 100 | tests :: TestTree 101 | tests = 102 | testGroup 103 | "Multi purpose scripts" 104 | [ testCooked "Using a script as minting and spending in the same scenario" $ mustSucceedTest runScript `withPrettyOpts` def {pcOptPrintTxOutRefs = PCOptTxOutRefsFull}, 105 | testGroup 106 | "The Spending purpose behaves properly" 107 | [ testCooked "We cannot redirect any output to a private key" $ 108 | mustFailWithSizeTest 6 $ 109 | somewhere (datumHijackingAttack @(Script.MultiPurposeScript MPTag) alice) runScript, 110 | testCooked "We cannot redirect any output to another script" $ 111 | mustFailWithSizeTest 6 $ 112 | somewhere (datumHijackingAttack @(Script.MultiPurposeScript MPTag) (Script.trueSpendingMPScript @())) runScript 113 | ], 114 | testGroup 115 | "The Minting purpose behaves properly" 116 | [ testCooked "We cannot duplicate the tokens" $ 117 | mustFailWithSizeTest 6 $ 118 | somewhere (dupTokenAttack (\_ n -> n + 1) alice) runScript, 119 | testCooked "We cannot mint additional tokens" $ 120 | mustFailWithSizeTest 6 $ 121 | somewhere (addTokenAttack (const [(Api.TokenName "myToken", 1)]) alice) runScript 122 | ] 123 | ] 124 | -------------------------------------------------------------------------------- /tests/Spec/ProposingScript.hs: -------------------------------------------------------------------------------- 1 | module Spec.ProposingScript where 2 | 3 | import Cooked 4 | import Plutus.ProposingScript 5 | import Plutus.Script.Utils.V3 qualified as Script 6 | import Test.Tasty 7 | 8 | testProposingScript :: 9 | (MonadBlockChain m) => 10 | -- | Whether or not to automatically fetch a reference script 11 | Bool -> 12 | -- | Whether or not to automatically attach the constitution 13 | Bool -> 14 | -- | The official constitution script 15 | Script.Versioned Script.Script -> 16 | -- | The optionally attached unofficial constitution script 17 | Maybe (Script.Versioned Script.Script) -> 18 | -- | The governance action to propose 19 | TxGovAction -> 20 | m () 21 | testProposingScript autoRefScript autoConstitution constitution mScript govAction = do 22 | setConstitutionScript constitution 23 | validateTxSkel_ $ 24 | txSkelTemplate 25 | { txSkelOuts = [wallet 1 `receives` ReferenceScript constitution], 26 | txSkelSigners = [wallet 1] 27 | } 28 | validateTxSkel_ $ 29 | txSkelTemplate 30 | { txSkelSigners = [wallet 1], 31 | txSkelProposals = 32 | [ TxSkelProposal 33 | { txSkelProposalAddress = Script.toAddress (wallet 1), 34 | txSkelProposalAction = govAction, 35 | txSkelProposalAnchor = Nothing, 36 | txSkelProposalWitness = (,if autoRefScript then emptyTxSkelRedeemer else emptyTxSkelRedeemerNoAutoFill) <$> mScript, 37 | txSkelProposalAutoConstitution = autoConstitution 38 | } 39 | ] 40 | } 41 | 42 | tests :: TestTree 43 | tests = 44 | testGroup 45 | "Proposing scripts" 46 | [ testGroup 47 | "No automated constitution attachment" 48 | [ testCooked "Failure when executing the wrong constitution script" $ 49 | mustFailInPhase1WithMsgTest "InvalidPolicyHash" $ 50 | testProposingScript False False checkProposingScript (Just alwaysTrueProposingValidator) (TxGovActionParameterChange [FeePerByte 100]), 51 | testCooked "Success when executing the right constitution script" $ 52 | mustSucceedTest $ 53 | testProposingScript False False alwaysTrueProposingValidator (Just alwaysTrueProposingValidator) (TxGovActionParameterChange [FeePerByte 100]), 54 | testCooked "Success when executing a more complex constitution script" $ 55 | mustSucceedTest $ 56 | testProposingScript False False checkProposingScript (Just checkProposingScript) (TxGovActionParameterChange [FeePerByte 100]), 57 | testCooked "Failure when executing a more complex constitution script with the wrong proposal" $ 58 | mustFailInPhase2Test $ 59 | testProposingScript False False checkProposingScript (Just checkProposingScript) (TxGovActionParameterChange [FeePerByte 50]), 60 | testCooked "Success when executing a more complex constitution script as a reference script" $ 61 | mustSucceedTest (testProposingScript True False checkProposingScript (Just checkProposingScript) (TxGovActionParameterChange [FeePerByte 100])) 62 | `withJournalProp` happened "MCLogAddedReferenceScript", 63 | testCooked "Failure when executing a dummy proposal script with the wrong proposal kind" $ 64 | mustFailInPhase2Test $ 65 | testProposingScript False False alwaysTrueProposingValidator (Just alwaysTrueProposingValidator) TxGovActionNoConfidence 66 | ], 67 | testGroup 68 | "Automated constitution attachment" 69 | [ testCooked "Success when auto assigning the constitution script" $ 70 | mustSucceedTest $ 71 | testProposingScript False True checkProposingScript Nothing (TxGovActionParameterChange [FeePerByte 100]), 72 | testCooked "Success when auto assigning the constitution script and using it as a reference script" $ 73 | mustSucceedTest (testProposingScript True True checkProposingScript Nothing (TxGovActionParameterChange [FeePerByte 100])) 74 | `withJournalProp` happened "MCLogAddedReferenceScript", 75 | testCooked "Success when auto assigning the constitution script while overriding an existing one" $ 76 | mustSucceedTest $ 77 | testProposingScript False True checkProposingScript (Just alwaysFalseProposingValidator) (TxGovActionParameterChange [FeePerByte 100]) 78 | ] 79 | ] 80 | -------------------------------------------------------------------------------- /tests/Spec/ReferenceInputs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Spec.ReferenceInputs where 4 | 5 | import Cooked 6 | import Data.Map qualified as Map 7 | import Data.Set qualified as Set 8 | import Plutus.ReferenceInputs 9 | import Plutus.Script.Utils.V2 qualified as Script 10 | import Prettyprinter qualified as PP 11 | import Test.Tasty qualified as Tasty 12 | 13 | instance PrettyCooked FooDatum where 14 | prettyCookedOpt opts (FooDatum pkh) = "FooDatum" PP.<+> prettyHash opts pkh 15 | 16 | trace1 :: (MonadBlockChain m) => m () 17 | trace1 = do 18 | txOutRefFoo : txOutRefBar : _ <- 19 | validateTxSkel' 20 | txSkelTemplate 21 | { txSkelOuts = 22 | [ fooTypedValidator `receives` (Value (Script.ada 4) <&&> InlineDatum (FooDatum $ Script.toPubKeyHash $ wallet 3)), 23 | barTypedValidator `receives` Value (Script.ada 5) 24 | ], 25 | txSkelSigners = [wallet 2] 26 | } 27 | validateTxSkel_ 28 | txSkelTemplate 29 | { txSkelIns = Map.singleton txOutRefBar $ someTxSkelRedeemer (), 30 | txSkelInsReference = Set.singleton txOutRefFoo, 31 | txSkelOuts = [wallet 4 `receives` Value (Script.ada 5)], 32 | txSkelSigners = [wallet 3] 33 | } 34 | 35 | trace2 :: (MonadBlockChain m) => m () 36 | trace2 = do 37 | refORef : scriptORef : _ <- 38 | validateTxSkel' 39 | ( txSkelTemplate 40 | { txSkelOuts = 41 | [ wallet 1 `receives` (Value (Script.ada 2) <&&> VisibleHashedDatum (10 :: Integer)), 42 | bazTypedValidator `receives` Value (Script.ada 10) 43 | ], 44 | txSkelSigners = [wallet 2] 45 | } 46 | ) 47 | validateTxSkel_ $ 48 | txSkelTemplate 49 | { txSkelSigners = [wallet 1], 50 | txSkelIns = Map.singleton scriptORef (someTxSkelRedeemer ()), 51 | txSkelInsReference = Set.singleton refORef 52 | } 53 | 54 | tests :: Tasty.TestTree 55 | tests = 56 | Tasty.testGroup 57 | "Reference inputs" 58 | [ testCooked "We can reference an input that can't be spent" $ mustSucceedTest trace1, 59 | testCooked "We can decode the datum hash from a reference input" $ mustSucceedTest trace2 60 | ] 61 | -------------------------------------------------------------------------------- /tests/Spec/Slot.hs: -------------------------------------------------------------------------------- 1 | module Spec.Slot (tests) where 2 | 3 | import Cooked.MockChain.BlockChain 4 | import Cooked.MockChain.Direct 5 | import Ledger.Slot qualified as Ledger 6 | import PlutusLedgerApi.V3 qualified as Api 7 | import Test.Tasty 8 | import Test.Tasty.QuickCheck 9 | 10 | tests :: TestTree 11 | tests = 12 | testGroup 13 | "time handling" 14 | [ testProperty "bounds computed by slotToMSRange are included in slot" $ 15 | \n -> 16 | case mcrValue $ runMockChain $ do 17 | (l, r) <- slotToMSRange $ Ledger.Slot n 18 | Ledger.Slot nl <- getEnclosingSlot l 19 | Ledger.Slot nr <- getEnclosingSlot r 20 | return (nl, nr) of 21 | Left _err -> False 22 | Right (nl, nr) -> nl == n && nr == n, 23 | testProperty "bounds computed by slotToMSRange are maximal" $ 24 | \n -> 25 | case mcrValue $ runMockChain $ do 26 | (l, r) <- slotToMSRange $ Ledger.Slot n 27 | Ledger.Slot nl <- getEnclosingSlot (l - 1) 28 | Ledger.Slot nr <- getEnclosingSlot (r + 1) 29 | return (nl, nr) of 30 | Left _err -> False 31 | Right (nl, nr) -> nl == n - 1 && nr == n + 1, 32 | testProperty "time is always included in enclosing slot" $ 33 | \t -> case mcrValue $ runMockChain $ slotToMSRange =<< getEnclosingSlot (Api.POSIXTime t) of 34 | Left _err -> False 35 | Right (Api.POSIXTime a, Api.POSIXTime b) -> a <= t && a <= b 36 | ] 37 | -------------------------------------------------------------------------------- /tests/Spec/Tweak.hs: -------------------------------------------------------------------------------- 1 | module Spec.Tweak (tests) where 2 | 3 | import Spec.Tweak.Common qualified as Common 4 | import Spec.Tweak.OutPermutations qualified as OutPermutations 5 | import Spec.Tweak.TamperDatum qualified as TamperDatum 6 | import Spec.Tweak.ValidityRange qualified as ValidityRange 7 | import Test.Tasty 8 | 9 | tests :: TestTree 10 | tests = 11 | testGroup 12 | "Tweaks" 13 | [ Common.tests, 14 | OutPermutations.tests, 15 | TamperDatum.tests, 16 | ValidityRange.tests 17 | ] 18 | -------------------------------------------------------------------------------- /tests/Spec/Tweak/Common.hs: -------------------------------------------------------------------------------- 1 | module Spec.Tweak.Common (tests) where 2 | 3 | import Cooked 4 | import Data.List (subsequences) 5 | import Optics.Core 6 | import Plutus.Script.Utils.Value qualified as Script 7 | import PlutusLedgerApi.V1.Value qualified as Api 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | 11 | alice :: Wallet 12 | alice = wallet 1 13 | 14 | mkSkel :: [Integer] -> TxSkel 15 | mkSkel l = set txSkelOutsL (receives alice . Value . Script.lovelace <$> l) txSkelTemplate 16 | 17 | tests :: TestTree 18 | tests = 19 | testGroup 20 | "building blocks for tweaks" 21 | [ testGroup "overMaybeSelectingTweak" $ 22 | let skel = mkSkel [123, 234, 345] 23 | in [ testCase "return empty list and don't change anything if no applicable modifications" $ -- this one is a regression test 24 | [Right ([], skel)] 25 | @=? mcrValue 26 | <$> runTweak 27 | ( overMaybeSelectingTweak 28 | (txSkelOutsL % traversed % txSkelOutValueL) 29 | (const Nothing) 30 | (const True) 31 | ) 32 | skel, 33 | testCase "select applied modification by index" $ 34 | [Right ([Script.lovelace 345], mkSkel [123, 234, 789])] 35 | @=? mcrValue 36 | <$> runTweak 37 | ( overMaybeSelectingTweak 38 | (txSkelOutsL % traversed % txSkelOutValueL % txSkelOutValueContentL) 39 | ( \value -> 40 | if value `Api.geq` Script.lovelace 200 41 | then Just $ Script.lovelace 789 42 | else Nothing 43 | ) 44 | (== 1) 45 | ) 46 | skel, 47 | testCase "return unmodified foci in the right order" $ 48 | [Right ([Script.lovelace 123, Script.lovelace 345], mkSkel [789, 234, 789])] 49 | @=? mcrValue 50 | <$> runTweak 51 | ( overMaybeSelectingTweak 52 | (txSkelOutsL % traversed % txSkelOutValueL % txSkelOutValueContentL) 53 | (const $ Just $ Script.lovelace 789) 54 | (`elem` [0, 2]) 55 | ) 56 | skel 57 | ], 58 | testGroup "combineModsTweak" $ 59 | let skelIn = mkSkel [0, 0, 0] 60 | skelOut x y z = Right ([0 | x /= 0] ++ [1 | y /= 0] ++ [2 | z /= 0], mkSkel [x, y, z]) 61 | in [ testCase "all combinations of modifications" $ 62 | assertSameSets 63 | [ -- one changed focus 64 | skelOut 1 0 0, 65 | skelOut 2 0 0, 66 | skelOut 0 1 0, 67 | skelOut 0 2 0, 68 | skelOut 0 0 1, 69 | skelOut 0 0 2, 70 | -- two changed foci 71 | skelOut 1 1 0, 72 | skelOut 1 2 0, 73 | skelOut 2 1 0, 74 | skelOut 2 2 0, 75 | skelOut 1 0 1, 76 | skelOut 1 0 2, 77 | skelOut 2 0 1, 78 | skelOut 2 0 2, 79 | skelOut 0 1 1, 80 | skelOut 0 1 2, 81 | skelOut 0 2 1, 82 | skelOut 0 2 2, 83 | -- three changed foci 84 | skelOut 1 1 1, 85 | skelOut 1 1 2, 86 | skelOut 1 2 1, 87 | skelOut 1 2 2, 88 | skelOut 2 1 1, 89 | skelOut 2 1 2, 90 | skelOut 2 2 1, 91 | skelOut 2 2 2 92 | ] 93 | ( mcrValue 94 | <$> runTweak 95 | ( combineModsTweak 96 | (tail . subsequences) 97 | (txSkelOutsL % itraversed % txSkelOutValueL % txSkelOutValueContentL % Script.adaL) 98 | (\i x -> return [(x + 1, i), (x + 2, i)]) 99 | ) 100 | skelIn 101 | ), 102 | testCase "separate modifications" $ 103 | assertSameSets 104 | [ -- one changed focus 105 | skelOut 1 0 0, 106 | skelOut 2 0 0, 107 | skelOut 0 1 0, 108 | skelOut 0 2 0, 109 | skelOut 0 0 1, 110 | skelOut 0 0 2 111 | ] 112 | ( mcrValue 113 | <$> runTweak 114 | ( combineModsTweak 115 | (map (: [])) 116 | (txSkelOutsL % itraversed % txSkelOutValueL % txSkelOutValueContentL % Script.adaL) 117 | (\i x -> return [(x + 1, i), (x + 2, i)]) 118 | ) 119 | skelIn 120 | ) 121 | ] 122 | ] 123 | -------------------------------------------------------------------------------- /tests/Spec/Tweak/OutPermutations.hs: -------------------------------------------------------------------------------- 1 | module Spec.Tweak.OutPermutations (tests) where 2 | 3 | import Cooked 4 | import Cooked.Tweak.OutPermutations 5 | import Data.Either (rights) 6 | import Data.List (group) 7 | import Plutus.Script.Utils.Value qualified as Script 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | 11 | tests :: TestTree 12 | tests = 13 | testGroup 14 | "output permutation tweak" 15 | [ testCase 16 | "tests for 'distinctPermutations'" 17 | $ let assertPermutEq actual expected = 18 | assertSameSets actual expected 19 | .&&. (length actual @?= length expected) 20 | in testConjoin $ 21 | map 22 | ( \(input, expected) -> 23 | assertPermutEq (distinctPermutations @Int input) expected 24 | ) 25 | [ ( [], 26 | [[]] 27 | ), 28 | ( [1, 2, 3], 29 | [ [1, 2, 3], 30 | [1, 3, 2], 31 | [2, 1, 3], 32 | [2, 3, 1], 33 | [3, 1, 2], 34 | [3, 2, 1] 35 | ] 36 | ), 37 | ( [1, 1], 38 | [[1, 1]] 39 | ), 40 | ( [1, 2, 1], 41 | [ [2, 1, 1], 42 | [1, 2, 1], 43 | [1, 1, 2] 44 | ] 45 | ), 46 | ( [2, 1, 3, 1], 47 | [ [1, 1, 2, 3], 48 | [1, 1, 3, 2], 49 | [1, 2, 1, 3], 50 | [1, 3, 1, 2], 51 | [1, 2, 3, 1], 52 | [1, 3, 2, 1], 53 | [2, 1, 1, 3], 54 | [3, 1, 1, 2], 55 | [2, 1, 3, 1], 56 | [3, 1, 2, 1], 57 | [2, 3, 1, 1], 58 | [3, 2, 1, 1] 59 | ] 60 | ) 61 | ], 62 | testGroup "tests for PermutOutTweakMode:" $ 63 | let a = wallet 1 `receives` Value (Script.lovelace 123) 64 | b = wallet 2 `receives` Value (Script.lovelace 123) 65 | c = wallet 3 `receives` Value (Script.lovelace 123) 66 | skel x y z = txSkelTemplate {txSkelOuts = [x, y, z]} 67 | in [ testCase "KeepIdentity (Just 2)" $ 68 | assertSameSets 69 | (map (Right . ((),)) [skel a b c, skel b a c]) 70 | (mcrValue <$> runTweak (allOutPermutsTweak $ KeepIdentity $ Just 2) (skel a b c)), 71 | testCase "KeepIdentity Nothing" $ 72 | assertSameSets 73 | (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]) 74 | (mcrValue <$> runTweak (allOutPermutsTweak $ KeepIdentity Nothing) (skel a b c)), 75 | testCase "OmitIdentity (Just 2)" $ 76 | assertSameSets 77 | [Right ((), skel b a c)] 78 | (mcrValue <$> runTweak (allOutPermutsTweak $ OmitIdentity $ Just 2) (skel a b c)), 79 | testCase "OmitIdentity Nothing" $ 80 | assertSameSets 81 | (map (Right . ((),)) [skel a c b, skel b a c, skel b c a, skel c a b, skel c b a]) 82 | (mcrValue <$> runTweak (allOutPermutsTweak $ OmitIdentity Nothing) (skel a b c)) 83 | ], 84 | testGroup "tests for a single random outputs permutation:" $ 85 | let l = (\i -> wallet i `receives` Value (Script.lovelace 123)) <$> [1 .. 5] 86 | runs = txSkelOuts . snd <$> rights (mcrValue <$> ((\i -> runTweak (singleOutPermutTweak i) txSkelTemplate {txSkelOuts = l}) =<< [1 .. 5])) 87 | in [ testCase "All permutations contain the correct elements" $ 88 | mapM_ (assertSameSets l) runs, 89 | testCase "All permutations are different from the initial distribution" $ 90 | mapM_ (assertBool "Lists should be different" . (l /=)) runs, 91 | testCase "Permutations are different with different seeds" $ 92 | assertBool "There should be at least 2 different permutations" (length (group runs) == 5) 93 | ] 94 | ] 95 | -------------------------------------------------------------------------------- /tests/Spec/Tweak/TamperDatum.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Tests for 'Cooked.Tweak.TamperDatum'. 4 | module Spec.Tweak.TamperDatum where 5 | 6 | import Cooked 7 | import Data.Either 8 | import Data.Maybe (mapMaybe) 9 | import Data.Set qualified as Set 10 | import Optics.Core 11 | import Plutus.Script.Utils.Value qualified as Script 12 | import PlutusTx qualified 13 | import Prettyprinter (viaShow) 14 | import Test.Tasty (TestTree, testGroup) 15 | import Test.Tasty.HUnit (testCase, (@=?)) 16 | 17 | instance PrettyCooked (Integer, Integer) where 18 | prettyCookedOpt _ = viaShow 19 | 20 | alice :: Wallet 21 | alice = wallet 1 22 | 23 | tamperDatumTweakTest :: TestTree 24 | tamperDatumTweakTest = 25 | testCase "tamperDatumTweak" $ 26 | [ Right 27 | ( [(52, 53)], 28 | txSkelTemplate 29 | { txSkelLabel = Set.singleton $ TxLabel TamperDatumLbl, 30 | txSkelOuts = 31 | [ alice `receives` VisibleHashedDatum (52 :: Integer, 54 :: Integer), 32 | alice `receives` Value (Script.lovelace 234), 33 | alice `receives` VisibleHashedDatum (76 :: Integer, 77 :: Integer) 34 | ] 35 | } 36 | ) 37 | ] 38 | @=? mcrValue 39 | <$> runTweak 40 | ( tamperDatumTweak @(Integer, Integer) 41 | (\(x, y) -> if y == 77 then Nothing else Just (x, y + 1)) 42 | ) 43 | ( txSkelTemplate 44 | { txSkelOuts = 45 | [ alice `receives` VisibleHashedDatum (52 :: Integer, 53 :: Integer), 46 | alice `receives` Value (Script.lovelace 234), 47 | alice `receives` VisibleHashedDatum (76 :: Integer, 77 :: Integer) 48 | ] 49 | } 50 | ) 51 | 52 | malformDatumTweakTest :: TestTree 53 | malformDatumTweakTest = 54 | testCase "malformDatumTweak" $ 55 | let allBuiltinData :: TxSkel -> [PlutusTx.BuiltinData] 56 | allBuiltinData txSkel = 57 | mapMaybe 58 | ( fmap PlutusTx.toBuiltinData 59 | . preview (txSkelOutDatumL % txSkelOutDatumContentAT) 60 | ) 61 | (txSkelOuts txSkel) 62 | 63 | txSkelWithDatums1And4 :: (PlutusTx.ToData a, PlutusTx.ToData b) => a -> b -> [PlutusTx.BuiltinData] 64 | txSkelWithDatums1And4 datum1 datum4 = 65 | [ PlutusTx.toBuiltinData datum1, 66 | PlutusTx.toBuiltinData (76 :: Integer, 77 :: Integer), 67 | PlutusTx.toBuiltinData datum4 68 | ] 69 | in assertSameSets 70 | [ txSkelWithDatums1And4 (52 :: Integer, ()) (84 :: Integer, 85 :: Integer), -- datum1 changed, datum4 untouched 71 | txSkelWithDatums1And4 False (84 :: Integer, 85 :: Integer), -- datum1 changed, datum4 untouched 72 | txSkelWithDatums1And4 (52 :: Integer, ()) (84 :: Integer, ()), -- datum1 changed, datum4 as well 73 | txSkelWithDatums1And4 False False, -- datum1 changed, datum4 as well 74 | txSkelWithDatums1And4 (52 :: Integer, ()) False, -- datum1 changed, datum4 as well 75 | txSkelWithDatums1And4 False (84 :: Integer, ()), -- datum1 changed, datum4 as well 76 | txSkelWithDatums1And4 (52 :: Integer, 53 :: Integer) (84 :: Integer, ()), -- datum1 untouched, datum4 changed 77 | txSkelWithDatums1And4 (52 :: Integer, 53 :: Integer) False -- datum1 untouched, datum4 changed 78 | ] 79 | ( fmap (allBuiltinData . snd) . rights $ 80 | mcrValue 81 | <$> runTweak 82 | ( malformDatumTweak @(Integer, Integer) 83 | ( \(x, y) -> 84 | if y == 77 85 | then [] 86 | else 87 | [ PlutusTx.toBuiltinData (x, ()), 88 | PlutusTx.toBuiltinData False 89 | ] 90 | ) 91 | ) 92 | ( txSkelTemplate 93 | { txSkelOuts = 94 | [ alice `receives` VisibleHashedDatum (52 :: Integer, 53 :: Integer), 95 | alice `receives` Value (Script.lovelace 234), 96 | alice `receives` VisibleHashedDatum (76 :: Integer, 77 :: Integer), 97 | alice `receives` VisibleHashedDatum (84 :: Integer, 85 :: Integer) 98 | ] 99 | } 100 | ) 101 | ) 102 | 103 | tests :: TestTree 104 | tests = 105 | testGroup 106 | "Tamper datum tweaks" 107 | [ tamperDatumTweakTest, 108 | malformDatumTweakTest 109 | ] 110 | -------------------------------------------------------------------------------- /tests/Spec/Tweak/ValidityRange.hs: -------------------------------------------------------------------------------- 1 | module Spec.Tweak.ValidityRange (tests) where 2 | 3 | import Control.Monad 4 | import Cooked 5 | import Data.Either (rights) 6 | import Data.Function (on) 7 | import Ledger.Slot qualified as Ledger 8 | import PlutusLedgerApi.V1.Interval qualified as Api 9 | import Test.Tasty (TestTree, testGroup) 10 | import Test.Tasty.HUnit (Assertion, assertBool, testCase) 11 | 12 | toSlotRange :: Integer -> Integer -> Api.Interval Ledger.Slot 13 | toSlotRange = Api.interval `on` Ledger.Slot 14 | 15 | toSlotRangeTranslate :: Ledger.Slot -> Integer -> Integer -> Api.Interval Ledger.Slot 16 | toSlotRangeTranslate translation a b = 17 | toSlotRange 18 | (Ledger.getSlot translation + a) 19 | (Ledger.getSlot translation + b) 20 | 21 | checkIsValidDuring :: (MonadTweak m) => m Assertion 22 | checkIsValidDuring = do 23 | b <- hasFullTimeRangeTweak 24 | b1 <- isValidDuringTweak $ toSlotRange 101 1015 25 | void $ setValidityRangeTweak $ toSlotRange 101 1015 26 | b2 <- isValidDuringTweak $ toSlotRange 110 1000 27 | b3 <- isValidDuringTweak $ toSlotRange 80 1015 28 | return $ 29 | assertBool "interval inclusions are wrong" $ 30 | b && b1 && b2 && not b3 31 | 32 | checkAddToValidityRange :: (MonadTweak m) => m Assertion 33 | checkAddToValidityRange = do 34 | timeOrigin <- currentSlot 35 | void $ centerAroundValidityRangeTweak (timeOrigin + Ledger.Slot 100) 80 36 | b <- isValidDuringTweak $ toSlotRangeTranslate timeOrigin 25 35 37 | b1 <- isValidAtTweak (timeOrigin + Ledger.Slot 130) 38 | void $ intersectValidityRangeTweak $ toSlotRangeTranslate timeOrigin 110 220 39 | b2 <- isValidAtTweak (timeOrigin + Ledger.Slot 130) 40 | void $ awaitSlot $ timeOrigin + Ledger.Slot 130 41 | b3 <- isValidNowTweak 42 | void $ awaitSlot $ Ledger.Slot 200 43 | b4 <- isValidNowTweak 44 | void makeValidityRangeNowTweak 45 | b5 <- isValidNowTweak 46 | return $ 47 | assertBool "interval intersection is wrong" $ 48 | b && b1 && b2 && b3 && not b4 && b5 49 | 50 | checkMoveCurrentSlot :: (MonadTweak m) => m Assertion 51 | checkMoveCurrentSlot = do 52 | void $ setValidityRangeTweak $ toSlotRange 10 20 53 | void waitUntilValidTweak 54 | b1 <- (\now -> now >= 10 && now <= 20) <$> currentSlot 55 | b2 <- isValidNowTweak 56 | void $ setValidityRangeTweak $ toSlotRange 15 25 57 | void waitUntilValidTweak 58 | b3 <- (\now -> now >= 15 && now <= 25) <$> currentSlot 59 | return $ assertBool "Time shift did not occur" $ b1 && b2 && b3 60 | 61 | tests :: TestTree 62 | tests = 63 | testGroup 64 | "Validity range tweaks" 65 | [ testCase "Validity inclusion" $ fst . head . rights $ mcrValue <$> runTweak checkIsValidDuring txSkelTemplate, 66 | testCase "Validity intersection" $ fst . head . rights $ mcrValue <$> runTweak checkAddToValidityRange txSkelTemplate, 67 | testCase "Time shifting in validity range" $ fst . head . rights $ mcrValue <$> runTweak checkMoveCurrentSlot txSkelTemplate 68 | ] 69 | -------------------------------------------------------------------------------- /tests/Spec/Withdrawals.hs: -------------------------------------------------------------------------------- 1 | module Spec.Withdrawals where 2 | 3 | import Cooked 4 | import Plutus.Withdrawals 5 | import Test.Tasty 6 | 7 | testWithdrawingScript :: (MonadModalBlockChain m) => Integer -> Integer -> Integer -> Integer -> m () 8 | testWithdrawingScript reward deposit inRedeemer actual = do 9 | registerStakingCred checkWithdrawalMPScript (reward * 1_000) (deposit * 1_000) 10 | validateTxSkel_ $ 11 | txSkelTemplate 12 | { txSkelSigners = [wallet 1], 13 | txSkelWithdrawals = 14 | scriptWithdrawal 15 | checkWithdrawalMPScript 16 | (someTxSkelRedeemer (inRedeemer * 1_000)) 17 | (actual * 1_000) 18 | } 19 | 20 | tests :: TestTree 21 | tests = 22 | testGroup 23 | "Withdrawing scripts" 24 | [ testCooked "We can use a withdrawing script" $ mustSucceedTest $ testWithdrawingScript 2 2 2 2, 25 | testCooked "But the script might fail" $ mustFailInPhase2WithMsgTest "Wrong quantity" $ testWithdrawingScript 2 2 2 1, 26 | testCooked "The amount of deposited lovelace is irrelevant" $ mustSucceedTest $ testWithdrawingScript 2 100 2 2, 27 | testCooked "We cannot withdraw more than our rewards" $ mustFailInPhase1WithMsgTest "WithdrawalsNotInRewardsCERTS" $ testWithdrawingScript 1 2 2 2, 28 | testCooked "We cannot withdraw less than our rewards either" $ mustFailInPhase1WithMsgTest "WithdrawalsNotInRewardsCERTS" $ testWithdrawingScript 3 2 2 2, 29 | testCooked "We cannot withdraw if we are not registered" $ 30 | mustFailInPhase1WithMsgTest "WithdrawalsNotInRewardsCERTS" $ 31 | testWithdrawingScript 2 2 2 2 32 | `withTweak` setTweak txSkelWithdrawalsL (scriptWithdrawal trueWithdrawalMPScript (someTxSkelRedeemer (2_000 :: Integer)) 2_000), 33 | testCooked "A wallet can also make a withdrawal" $ 34 | mustSucceedTest $ 35 | testWithdrawingScript 2 2 2 2 36 | `withTweak` do 37 | registerStakingCred (wallet 1) 2_000 0 38 | setTweak txSkelWithdrawalsL (pkWithdrawal (wallet 1) 2_000) 39 | ] 40 | --------------------------------------------------------------------------------