├── .coverage └── template.overlay ├── .editorconfig ├── .envrc ├── .github └── workflows │ ├── check-hlint.yml │ ├── check-stylish-haskell.yml │ └── haddock.yml ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── CODEOWNERS ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── ChangeLog.md ├── LICENSE ├── README.md ├── cabal.project ├── cardano-coin-selection.cabal ├── flake.lock ├── flake.nix ├── information └── repository-creation-process.md ├── scripts ├── hlint.sh └── stylish-haskell.sh └── src ├── internal ├── Internal.hs └── Internal │ ├── Coin.hs │ ├── Invariant.hs │ └── Rounding.hs ├── library └── Cardano │ ├── CoinSelection.hs │ └── CoinSelection │ ├── Algorithm.hs │ ├── Algorithm │ ├── LargestFirst.hs │ ├── Migration.hs │ └── RandomImprove.hs │ └── Fee.hs └── test ├── Cardano ├── CoinSelection │ ├── Algorithm │ │ ├── LargestFirstSpec.hs │ │ ├── MigrationSpec.hs │ │ └── RandomImproveSpec.hs │ ├── FeeSpec.hs │ └── TypesSpec.hs ├── CoinSelectionSpec.hs └── Test │ └── Utilities.hs ├── Internal └── CoinSpec.hs ├── Spec.hs └── Test └── Vector ├── Shuffle.hs └── ShuffleSpec.hs /.coverage/template.overlay: -------------------------------------------------------------------------------- 1 | module "Internal.Coin" { 2 | tick "getSum" [Record accessor]; 3 | tick "unCoin" [Record accessor]; 4 | tick function "==" [derived Eq instance]; 5 | tick function "compare" [derived Ord instance]; 6 | tick function "showsPrec" [derived Show instance]; 7 | } 8 | 9 | module "Internal.Invariant" { 10 | inside "invariant" { 11 | tick "error msg" [Never executed invariant]; 12 | } 13 | } 14 | 15 | module "Internal.Rounding" { 16 | tick function "==" [derived Eq instance]; 17 | tick function "showsPrec" [derived Show instance]; 18 | } 19 | 20 | module "Cardano.CoinSelection" { 21 | tick function "==" [derived Eq instance]; 22 | tick function "showsPrec" [derived Show instance]; 23 | 24 | tick "calculatedInputLimit" [Record accessor]; 25 | tick "inputCountAvailable" [Record accessor]; 26 | tick "inputCountRequired" [Record accessor]; 27 | tick "inputValueAvailable" [Record accessor]; 28 | tick "inputValueRequired" [Record accessor]; 29 | tick "coinSelection" [Record accessor]; 30 | tick "inputsRemaining" [Record accessor]; 31 | } 32 | 33 | module "Cardano.CoinSelection.Fee" { 34 | tick function "<>" [derived Monoid instance]; 35 | tick function "==" [derived Eq instance]; 36 | tick function "compare" [derived Ord instance]; 37 | tick function "showsPrec" [derived Show instance]; 38 | } 39 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | indent_style = space 5 | indent_size = 2 6 | end_of_line = lf 7 | charset = utf-8 8 | trim_trailing_whitespace = true 9 | insert_final_newline = true 10 | 11 | [Makefile] 12 | indent_style = tab 13 | indent_size = 8 14 | 15 | [*.hs] 16 | indent_size = 4 17 | max_line_length = 80 18 | -------------------------------------------------------------------------------- /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.github/workflows/check-hlint.yml: -------------------------------------------------------------------------------- 1 | name: Check HLint 2 | 3 | on: 4 | merge_group: 5 | pull_request: 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | 11 | defaults: 12 | run: 13 | shell: bash 14 | 15 | steps: 16 | 17 | - uses: actions/checkout@v3 18 | 19 | - uses: haskell-actions/hlint-scan@v1 20 | -------------------------------------------------------------------------------- /.github/workflows/check-stylish-haskell.yml: -------------------------------------------------------------------------------- 1 | name: Check Stylish Haskell 2 | 3 | on: 4 | merge_group: 5 | pull_request: 6 | 7 | # When pushing branches (and/or updating PRs), we do want to cancel previous 8 | # build runs. We assume they are stale now; and do not want to spend CI time and 9 | # resources on continuing to continue those runs. This is what the concurrency.group 10 | # value lets us express. When using merge queues, we now have to consider 11 | # - runs triggers by commits per pull-request 12 | # we want to cancel any previous run. So they should all get the same group (per PR) 13 | # - runs refs/heads/gh-readonly-queue/ (they should all get their 14 | # unique git ref, we don't want to cancel any of the ones in the queue) 15 | # - if it's neither, we fall back to the run_id (this is a unique number for each 16 | # workflow run; it does not change if you "rerun" a job) 17 | concurrency: 18 | group: ${{ github.workflow }}-${{ github.event.type }}-${{ startsWith(github.ref, 'refs/heads/gh-readonly-queue/') && github.ref || github.event.pull_request.number || github.run_id }} 19 | cancel-in-progress: true 20 | 21 | jobs: 22 | check-stylish-haskell: 23 | runs-on: ubuntu-latest 24 | 25 | strategy: 26 | fail-fast: false 27 | 28 | env: 29 | # Modify this value to "invalidate" the cabal cache. 30 | CABAL_CACHE_VERSION: "2023-07-12" 31 | 32 | STYLISH_HASKELL_VERSION: "0.14.4.0" 33 | 34 | STYLISH_HASKELL_PATHS: > 35 | ./ 36 | 37 | steps: 38 | - name: Download stylish-haskell 39 | if: runner.os == 'Linux' 40 | run: | 41 | version="${{ env.STYLISH_HASKELL_VERSION }}" 42 | 43 | curl -sL \ 44 | "https://github.com/haskell/stylish-haskell/releases/download/v$version/stylish-haskell-v$version-linux-x86_64.tar.gz" \ 45 | | tar -C "/tmp" -xz 46 | 47 | echo "PATH=/tmp/stylish-haskell-v$version-linux-x86_64:$PATH" >> $GITHUB_ENV 48 | 49 | - uses: actions/checkout@v3 50 | 51 | - name: Run stylish-haskell over all Haskell files (always succeeds) 52 | run: | 53 | git add . 54 | git stash 55 | 56 | for x in $(git ls-tree --full-tree --name-only -r HEAD ${{ env.STYLISH_HASKELL_PATHS }}); do 57 | if [ "${x##*.}" == "hs" ]; then 58 | if grep -qE '^#' $x; then 59 | echo "$x contains CPP. Skipping." 60 | else 61 | stylish-haskell -i $x 62 | fi 63 | fi 64 | done 65 | 66 | git --no-pager diff 67 | 68 | - name: Run stylish-haskell over all modified files 69 | run: | 70 | git add . 71 | git stash 72 | git fetch origin ${{ github.base_ref }} --unshallow 73 | for x in $(git diff --name-only --diff-filter=ACMR origin/${{ github.base_ref }}..HEAD ${{ env.STYLISH_HASKELL_PATHS }}); do 74 | if [ "${x##*.}" == "hs" ]; then 75 | if grep -qE '^#' $x; then 76 | echo "$x contains CPP. Skipping." 77 | else 78 | stylish-haskell -i $x 79 | fi 80 | fi 81 | done 82 | 83 | git --no-pager diff --exit-code 84 | -------------------------------------------------------------------------------- /.github/workflows/haddock.yml: -------------------------------------------------------------------------------- 1 | name: "Haddock documentation" 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | 12 | defaults: 13 | run: 14 | shell: bash 15 | 16 | steps: 17 | - name: Install Nix 18 | uses: cachix/install-nix-action@v18 19 | with: 20 | # Use last stable nixos channel and the same nix as in channel: 21 | install_url: https://releases.nixos.org/nix/nix-2.11.1/install 22 | nix_path: nixpkgs=channel:nixos-22.11 23 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 24 | extra_nix_config: | 25 | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} 26 | experimental-features = nix-command flakes 27 | allow-import-from-derivation = true 28 | substituters = https://cache.nixos.org https://cache.iog.io 29 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= 30 | 31 | - uses: actions/checkout@v3 32 | 33 | - name: Fetch nix cache and update cabal indices 34 | run: | 35 | nix develop .\#haddockShell --command \ 36 | cabal update 37 | 38 | - name: Build whole project 39 | run: | 40 | nix develop .\#haddockShell --command \ 41 | cabal build all 42 | 43 | - name: Build documentation 44 | run: | 45 | nix develop .\#haddockShell --command \ 46 | cabal haddock-project --local --output=./haddocks --internal --foreign-libraries 47 | 48 | - name: Compress haddocks 49 | run: | 50 | tar -czf haddocks.tgz -C haddocks . 51 | 52 | - name: Upload haddocks artifact 53 | uses: actions/upload-artifact@v2 54 | if: ${{ always() }} 55 | continue-on-error: true 56 | with: 57 | name: haddocks 58 | path: ./haddocks.tgz 59 | 60 | - name: Deploy documentation to gh-pages 🚀 61 | if: github.ref == 'refs/heads/master' 62 | uses: peaceiris/actions-gh-pages@v3 63 | with: 64 | github_token: ${{ secrets.GITHUB_TOKEN || github.token }} 65 | publish_dir: haddocks 66 | cname: coin-selection.cardano.intersectmbo.org 67 | force_orphan: true 68 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell ### 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dump-hi 11 | *.dyn_hi 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | .stack-work/ 21 | cabal.project.local 22 | cabal.project.local~ 23 | .HTF/ 24 | .ghc.environment.* 25 | .ghci 26 | *.tix 27 | stack.yaml.lock 28 | haddocks 29 | 30 | ### Nix ### 31 | result* 32 | .stack-to-nix.cache 33 | 34 | .direnv 35 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Specify additional command line arguments 10 | # 11 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 12 | 13 | 14 | # Control which extensions/flags/modules/functions can be used 15 | # 16 | # - extensions: 17 | # - default: false # all extension are banned by default 18 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 19 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 20 | # 21 | # - flags: 22 | # - {name: -w, within: []} # -w is allowed nowhere 23 | # 24 | # - modules: 25 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 26 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 27 | # 28 | # - functions: 29 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 30 | 31 | - modules: 32 | # Enforce some common qualified imports aliases across the codebase 33 | - {name: [Data.Aeson, Data.Aeson.Types], as: Aeson} 34 | - {name: [Data.ByteArray], as: BA} 35 | - {name: [Data.ByteString.Base16], as: B16} 36 | - {name: [Data.ByteString.Char8], as: B8} 37 | - {name: [Data.ByteString.Lazy], as: BL} 38 | - {name: [Data.ByteString], as: BS} 39 | - {name: [Data.Foldable], as: F} 40 | - {name: [Data.List.NonEmpty], as: NE} 41 | - {name: [Data.List], as: L} 42 | - {name: [Data.Map.Strict], as: Map} 43 | - {name: [Data.Sequence], as: Seq} 44 | - {name: [Data.Set, Data.HashSet], as: Set} 45 | - {name: [Data.Text, Data.Text.Encoding], as: T} 46 | - {name: [Data.Vector], as: V} 47 | 48 | # Ignore some build-in rules 49 | - ignore: {name: "Reduce duplication"} # This is a decision left to developers and reviewers 50 | - ignore: {name: "Redundant bracket"} # Not everyone knows precedences of every operators in Haskell. Brackets help readability. 51 | - ignore: {name: "Redundant do"} # Just an annoying hlint built-in, GHC may remove redundant do if he wants 52 | - ignore: {name: "Monoid law, left identity"} # Using 'mempty' can be useful to vertically-align elements 53 | - ignore: {name: "Use ?~"} # It's actually much clearer to do (.~ Just ...) than having to load yet-another-lens-operator 54 | - ignore: {name: "Use camelCase"} # Sometimes useful in test code. 55 | - ignore: {name: "Redundant lambda"} # Sometimes useful in test code. 56 | - ignore: {name: "Collapse lambdas"} # Sometimes useful in test code. 57 | - ignore: {name: "Use section"} # Useful for aligning elements vertically. 58 | 59 | # Add custom hints for this project 60 | # 61 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 62 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 63 | 64 | 65 | # Turn on hints that are off by default 66 | # 67 | # Ban "module X(module X) where", to require a real export list 68 | # - warn: {name: Use explicit module export list} 69 | # 70 | # Replace a $ b $ c with a . b $ c 71 | # - group: {name: dollar, enabled: true} 72 | # 73 | # Generalise map to fmap, ++ to <> 74 | # - group: {name: generalise, enabled: true} 75 | 76 | 77 | # Ignore some builtin hints 78 | # - ignore: {name: Use let} 79 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 80 | 81 | 82 | # Define some custom infix operators 83 | # - fixity: infixr 3 ~^#^~ 84 | 85 | 86 | # To generate a suitable file for HLint do: 87 | # $ hlint --default > .hlint.yaml 88 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # Stylish-haskell configuration file 2 | # 3 | # See `stylish-haskell --defaults` or 4 | # https://github.com/jaspervdj/stylish-haskell/blob/master/data/stylish-haskell.yaml 5 | # for usage. 6 | 7 | columns: 80 # Should match .editorconfig 8 | steps: 9 | - imports: 10 | align: none 11 | empty_list_align: inherit 12 | list_align: new_line 13 | list_padding: 4 14 | long_list_align: new_line_multiline 15 | pad_module_names: false 16 | separate_lists: true 17 | space_surround: true 18 | 19 | - language_pragmas: 20 | align: false 21 | remove_redundant: true 22 | style: vertical 23 | -------------------------------------------------------------------------------- /CODEOWNERS: -------------------------------------------------------------------------------- 1 | # These owners will be the default owners for everything in the repository. 2 | # 3 | # Unless a later match takes precedence, these owners will be requested for 4 | # review when someone opens a pull request. 5 | # 6 | * @Anviking @HeinrichApfelmus @jonathanknowles @paolino @paweljakubas @Unisay 7 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | See [code of conduct]. 2 | 3 | [code of conduct]: https://github.com/input-output-hk/cardano-engineering-handbook/blob/main/CODE-OF-CONDUCT.md 4 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository provides reference implementations of algorithms for coin selection and change generation, as specified by [CIP-2](https://cips.cardano.org/cips/cip2/). 2 | 3 | If you find an implementation bug, we'd be very grateful if you could let us know by raising an issue on our [issue tracker](https://github.com/input-output-hk/cardano-coin-selection/issues). 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## [1.0.1] - 2020-05-13 2 | 3 | ### Improvements 4 | 5 | * Adjusted the Largest-First algorithm to pay for outputs collectively instead 6 | of individually. 7 | 8 | The updated algorithm should now be successful at paying for any set of 9 | outputs of total value **_v_** provided that the total value **_u_** of 10 | available inputs satisfies **_u_** ≥ **_v_**. 11 | 12 | The cardinality restriction requiring the number of inputs to be greater than 13 | the number of outputs has been removed. 14 | 15 | See the following commits for more details: 16 | 17 | * `aae26dddb727779f` 18 | ([PR #73](https://github.com/input-output-hk/cardano-coin-selection/pull/73)) 19 | * `65d5108bac63251f` 20 | ([PR #76](https://github.com/input-output-hk/cardano-coin-selection/pull/76)) 21 | 22 | ### Fixes 23 | 24 | * Fixed a small issue with the migration algorithm that caused it to 25 | occasionally return more change than actually available. 26 | 27 | This issue only occurred in extreme situations, where the total value of the 28 | available UTxO set was less than the dust threshold value. 29 | 30 | See the following commits for more details: 31 | 32 | * `14ef17a9647974a8` 33 | ([PR #77](https://github.com/input-output-hk/cardano-coin-selection/pull/77)) 34 | 35 | ## [1.0.0] - 2020-04-29 36 | 37 | Initial release. 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright © 2019-2024 Intersect MBO 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | ## Overview 5 | 6 | This repository provides reference implementations of algorithms for coin selection and change generation, as specified by [CIP-2](https://cips.cardano.org/cips/cip2/). 7 | 8 | ## Documentation 9 | 10 | API documentation is available [here](https://coin-selection.cardano.intersectmbo.org). 11 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | -- run `nix flake lock --update-input hackage` after updating index-state. 2 | repository cardano-haskell-packages 3 | url: https://chap.intersectmbo.org/ 4 | secure: True 5 | root-keys: 6 | 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f 7 | 443abb7fb497a134c343faf52f0b659bd7999bc06b7f63fa76dc99d631f9bea1 8 | a86a1f6ce86c449c46666bda44268677abf29b5b2d2eb5ec7af903ec2f117a82 9 | bcec67e8e99cabfa7764d75ad9b158d72bfacf70ca1d0ec8bc6b4406d1bf8413 10 | c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56 11 | d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee 12 | 13 | -- See CONTRIBUTING for information about these, including some Nix commands 14 | -- you need to run if you change them 15 | index-state: 16 | , hackage.haskell.org 2024-03-26T06:28:59Z 17 | , cardano-haskell-packages 2024-05-06T13:38:48Z 18 | 19 | packages: 20 | ./ 21 | 22 | -------------------------------------------------------------------------------- /cardano-coin-selection.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 955257d9cc818ae774b8798f360815648a42e3808e53b8363c5195d1864c716a 8 | 9 | name: cardano-coin-selection 10 | version: 1.0.1 11 | synopsis: Algorithms for coin selection and fee balancing. 12 | description: Please see the README on GitHub at 13 | category: Cardano 14 | homepage: https://github.com/IntersectMBO/cardano-coin-selection#readme 15 | bug-reports: https://github.com/IntersectMBO/cardano-coin-selection/issues 16 | author: Intersect MBO 17 | maintainer: operations@iohk.io 18 | copyright: 2020 Intersect MBO 19 | license: Apache-2.0 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | ChangeLog.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/IntersectMBO/cardano-coin-selection 28 | 29 | flag release 30 | description: Compile executables for a release. 31 | manual: True 32 | default: False 33 | 34 | library 35 | exposed-modules: 36 | Cardano.CoinSelection 37 | Cardano.CoinSelection.Algorithm 38 | Cardano.CoinSelection.Algorithm.LargestFirst 39 | Cardano.CoinSelection.Algorithm.Migration 40 | Cardano.CoinSelection.Algorithm.RandomImprove 41 | Cardano.CoinSelection.Fee 42 | Internal 43 | Internal.Coin 44 | Internal.Invariant 45 | Internal.Rounding 46 | other-modules: 47 | Paths_cardano_coin_selection 48 | hs-source-dirs: 49 | src/library 50 | src/internal 51 | default-extensions: NoImplicitPrelude 52 | ghc-options: -Wall -Wcompat -fwarn-redundant-constraints 53 | build-depends: 54 | base >=4.7 && <5 55 | , bytestring 56 | , containers 57 | , cryptonite 58 | , deepseq 59 | , quiet 60 | , text 61 | , transformers >=0.5.6.0 62 | if flag(release) 63 | ghc-options: -Werror 64 | default-language: Haskell2010 65 | 66 | test-suite unit 67 | type: exitcode-stdio-1.0 68 | main-is: Spec.hs 69 | other-modules: 70 | Cardano.CoinSelection.Algorithm.LargestFirstSpec 71 | Cardano.CoinSelection.Algorithm.MigrationSpec 72 | Cardano.CoinSelection.Algorithm.RandomImproveSpec 73 | Cardano.CoinSelection.FeeSpec 74 | Cardano.CoinSelection.TypesSpec 75 | Cardano.CoinSelectionSpec 76 | Cardano.Test.Utilities 77 | Internal.CoinSpec 78 | Test.Vector.Shuffle 79 | Test.Vector.ShuffleSpec 80 | Paths_cardano_coin_selection 81 | hs-source-dirs: 82 | src/test 83 | default-extensions: NoImplicitPrelude 84 | ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -threaded -rtsopts -with-rtsopts=-N 85 | build-depends: 86 | QuickCheck 87 | , base >=4.7 && <5 88 | , bytestring 89 | , cardano-coin-selection 90 | , containers 91 | , cryptonite 92 | , deepseq 93 | , fmt ^>= 0.6 94 | , hspec 95 | , memory 96 | , quiet 97 | , random 98 | , text 99 | , transformers >=0.5.6.0 100 | , vector 101 | if flag(release) 102 | ghc-options: -Werror 103 | default-language: Haskell2010 104 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "CHaP": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1715357583, 7 | "narHash": "sha256-UdvQfk7No0b2L68tNjbOwnnR9PU30x93FzJTIwaXT60=", 8 | "owner": "intersectmbo", 9 | "repo": "cardano-haskell-packages", 10 | "rev": "3a1dae0cd9af0e2e8734d73a9acbe2cdfff369d0", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "intersectmbo", 15 | "ref": "repo", 16 | "repo": "cardano-haskell-packages", 17 | "type": "github" 18 | } 19 | }, 20 | "HTTP": { 21 | "flake": false, 22 | "locked": { 23 | "lastModified": 1451647621, 24 | "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", 25 | "owner": "phadej", 26 | "repo": "HTTP", 27 | "rev": "9bc0996d412fef1787449d841277ef663ad9a915", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "phadej", 32 | "repo": "HTTP", 33 | "type": "github" 34 | } 35 | }, 36 | "blst": { 37 | "flake": false, 38 | "locked": { 39 | "lastModified": 1656163412, 40 | "narHash": "sha256-xero1aTe2v4IhWIJaEDUsVDOfE77dOV5zKeHWntHogY=", 41 | "owner": "supranational", 42 | "repo": "blst", 43 | "rev": "03b5124029979755c752eec45f3c29674b558446", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "supranational", 48 | "repo": "blst", 49 | "rev": "03b5124029979755c752eec45f3c29674b558446", 50 | "type": "github" 51 | } 52 | }, 53 | "cabal-32": { 54 | "flake": false, 55 | "locked": { 56 | "lastModified": 1603716527, 57 | "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", 58 | "owner": "haskell", 59 | "repo": "cabal", 60 | "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "owner": "haskell", 65 | "ref": "3.2", 66 | "repo": "cabal", 67 | "type": "github" 68 | } 69 | }, 70 | "cabal-34": { 71 | "flake": false, 72 | "locked": { 73 | "lastModified": 1645834128, 74 | "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", 75 | "owner": "haskell", 76 | "repo": "cabal", 77 | "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", 78 | "type": "github" 79 | }, 80 | "original": { 81 | "owner": "haskell", 82 | "ref": "3.4", 83 | "repo": "cabal", 84 | "type": "github" 85 | } 86 | }, 87 | "cabal-36": { 88 | "flake": false, 89 | "locked": { 90 | "lastModified": 1669081697, 91 | "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", 92 | "owner": "haskell", 93 | "repo": "cabal", 94 | "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", 95 | "type": "github" 96 | }, 97 | "original": { 98 | "owner": "haskell", 99 | "ref": "3.6", 100 | "repo": "cabal", 101 | "type": "github" 102 | } 103 | }, 104 | "cardano-shell": { 105 | "flake": false, 106 | "locked": { 107 | "lastModified": 1608537748, 108 | "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", 109 | "owner": "input-output-hk", 110 | "repo": "cardano-shell", 111 | "rev": "9392c75087cb9a3d453998f4230930dea3a95725", 112 | "type": "github" 113 | }, 114 | "original": { 115 | "owner": "input-output-hk", 116 | "repo": "cardano-shell", 117 | "type": "github" 118 | } 119 | }, 120 | "flake-compat": { 121 | "flake": false, 122 | "locked": { 123 | "lastModified": 1672831974, 124 | "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", 125 | "owner": "input-output-hk", 126 | "repo": "flake-compat", 127 | "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", 128 | "type": "github" 129 | }, 130 | "original": { 131 | "owner": "input-output-hk", 132 | "ref": "hkm/gitlab-fix", 133 | "repo": "flake-compat", 134 | "type": "github" 135 | } 136 | }, 137 | "flake-utils": { 138 | "inputs": { 139 | "systems": "systems" 140 | }, 141 | "locked": { 142 | "lastModified": 1681378341, 143 | "narHash": "sha256-2qUN04W6X9cHHytEsJTM41CmusifPTC0bgTtYsHSNY8=", 144 | "owner": "hamishmack", 145 | "repo": "flake-utils", 146 | "rev": "2767bafdb189cd623354620c2dacbeca8fd58b17", 147 | "type": "github" 148 | }, 149 | "original": { 150 | "owner": "hamishmack", 151 | "ref": "hkm/nested-hydraJobs", 152 | "repo": "flake-utils", 153 | "type": "github" 154 | } 155 | }, 156 | "ghc-8.6.5-iohk": { 157 | "flake": false, 158 | "locked": { 159 | "lastModified": 1600920045, 160 | "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", 161 | "owner": "input-output-hk", 162 | "repo": "ghc", 163 | "rev": "95713a6ecce4551240da7c96b6176f980af75cae", 164 | "type": "github" 165 | }, 166 | "original": { 167 | "owner": "input-output-hk", 168 | "ref": "release/8.6.5-iohk", 169 | "repo": "ghc", 170 | "type": "github" 171 | } 172 | }, 173 | "ghc98X": { 174 | "flake": false, 175 | "locked": { 176 | "lastModified": 1696643148, 177 | "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=", 178 | "ref": "ghc-9.8", 179 | "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6", 180 | "revCount": 61642, 181 | "submodules": true, 182 | "type": "git", 183 | "url": "https://gitlab.haskell.org/ghc/ghc" 184 | }, 185 | "original": { 186 | "ref": "ghc-9.8", 187 | "submodules": true, 188 | "type": "git", 189 | "url": "https://gitlab.haskell.org/ghc/ghc" 190 | } 191 | }, 192 | "ghc99": { 193 | "flake": false, 194 | "locked": { 195 | "lastModified": 1701580282, 196 | "narHash": "sha256-drA01r3JrXnkKyzI+owMZGxX0JameMzjK0W5jJE/+V4=", 197 | "ref": "refs/heads/master", 198 | "rev": "f5eb0f2982e9cf27515e892c4bdf634bcfb28459", 199 | "revCount": 62197, 200 | "submodules": true, 201 | "type": "git", 202 | "url": "https://gitlab.haskell.org/ghc/ghc" 203 | }, 204 | "original": { 205 | "submodules": true, 206 | "type": "git", 207 | "url": "https://gitlab.haskell.org/ghc/ghc" 208 | } 209 | }, 210 | "hackage": { 211 | "flake": false, 212 | "locked": { 213 | "lastModified": 1710721411, 214 | "narHash": "sha256-0B1YATLPUKKOexhhfSFkTQlZH6o4yWJ/0WJeyZMxBKg=", 215 | "owner": "input-output-hk", 216 | "repo": "hackage.nix", 217 | "rev": "99719945242bc0c965560ed708868aa088748524", 218 | "type": "github" 219 | }, 220 | "original": { 221 | "owner": "input-output-hk", 222 | "repo": "hackage.nix", 223 | "type": "github" 224 | } 225 | }, 226 | "haskellNix": { 227 | "inputs": { 228 | "HTTP": "HTTP", 229 | "cabal-32": "cabal-32", 230 | "cabal-34": "cabal-34", 231 | "cabal-36": "cabal-36", 232 | "cardano-shell": "cardano-shell", 233 | "flake-compat": "flake-compat", 234 | "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", 235 | "ghc98X": "ghc98X", 236 | "ghc99": "ghc99", 237 | "hackage": "hackage", 238 | "hls-1.10": "hls-1.10", 239 | "hls-2.0": "hls-2.0", 240 | "hls-2.2": "hls-2.2", 241 | "hls-2.3": "hls-2.3", 242 | "hls-2.4": "hls-2.4", 243 | "hls-2.5": "hls-2.5", 244 | "hls-2.6": "hls-2.6", 245 | "hpc-coveralls": "hpc-coveralls", 246 | "hydra": "hydra", 247 | "iserv-proxy": "iserv-proxy", 248 | "nix-tools-static": "nix-tools-static", 249 | "nixpkgs": [ 250 | "haskellNix", 251 | "nixpkgs-unstable" 252 | ], 253 | "nixpkgs-2003": "nixpkgs-2003", 254 | "nixpkgs-2105": "nixpkgs-2105", 255 | "nixpkgs-2111": "nixpkgs-2111", 256 | "nixpkgs-2205": "nixpkgs-2205", 257 | "nixpkgs-2211": "nixpkgs-2211", 258 | "nixpkgs-2305": "nixpkgs-2305", 259 | "nixpkgs-2311": "nixpkgs-2311", 260 | "nixpkgs-unstable": "nixpkgs-unstable", 261 | "old-ghc-nix": "old-ghc-nix", 262 | "stackage": "stackage" 263 | }, 264 | "locked": { 265 | "lastModified": 1708649400, 266 | "narHash": "sha256-iDwTrACFFetPuTc0efdZ5pukmMMj/e9rPIYAUJxSo1E=", 267 | "owner": "input-output-hk", 268 | "repo": "haskell.nix", 269 | "rev": "a3e36bb1cc1f4ab1dbe1b12d5bf68220ba3daf64", 270 | "type": "github" 271 | }, 272 | "original": { 273 | "owner": "input-output-hk", 274 | "repo": "haskell.nix", 275 | "type": "github" 276 | } 277 | }, 278 | "hls-1.10": { 279 | "flake": false, 280 | "locked": { 281 | "lastModified": 1680000865, 282 | "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", 283 | "owner": "haskell", 284 | "repo": "haskell-language-server", 285 | "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", 286 | "type": "github" 287 | }, 288 | "original": { 289 | "owner": "haskell", 290 | "ref": "1.10.0.0", 291 | "repo": "haskell-language-server", 292 | "type": "github" 293 | } 294 | }, 295 | "hls-2.0": { 296 | "flake": false, 297 | "locked": { 298 | "lastModified": 1687698105, 299 | "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", 300 | "owner": "haskell", 301 | "repo": "haskell-language-server", 302 | "rev": "783905f211ac63edf982dd1889c671653327e441", 303 | "type": "github" 304 | }, 305 | "original": { 306 | "owner": "haskell", 307 | "ref": "2.0.0.1", 308 | "repo": "haskell-language-server", 309 | "type": "github" 310 | } 311 | }, 312 | "hls-2.2": { 313 | "flake": false, 314 | "locked": { 315 | "lastModified": 1693064058, 316 | "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", 317 | "owner": "haskell", 318 | "repo": "haskell-language-server", 319 | "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", 320 | "type": "github" 321 | }, 322 | "original": { 323 | "owner": "haskell", 324 | "ref": "2.2.0.0", 325 | "repo": "haskell-language-server", 326 | "type": "github" 327 | } 328 | }, 329 | "hls-2.3": { 330 | "flake": false, 331 | "locked": { 332 | "lastModified": 1695910642, 333 | "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", 334 | "owner": "haskell", 335 | "repo": "haskell-language-server", 336 | "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", 337 | "type": "github" 338 | }, 339 | "original": { 340 | "owner": "haskell", 341 | "ref": "2.3.0.0", 342 | "repo": "haskell-language-server", 343 | "type": "github" 344 | } 345 | }, 346 | "hls-2.4": { 347 | "flake": false, 348 | "locked": { 349 | "lastModified": 1699862708, 350 | "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", 351 | "owner": "haskell", 352 | "repo": "haskell-language-server", 353 | "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", 354 | "type": "github" 355 | }, 356 | "original": { 357 | "owner": "haskell", 358 | "ref": "2.4.0.1", 359 | "repo": "haskell-language-server", 360 | "type": "github" 361 | } 362 | }, 363 | "hls-2.5": { 364 | "flake": false, 365 | "locked": { 366 | "lastModified": 1701080174, 367 | "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", 368 | "owner": "haskell", 369 | "repo": "haskell-language-server", 370 | "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", 371 | "type": "github" 372 | }, 373 | "original": { 374 | "owner": "haskell", 375 | "ref": "2.5.0.0", 376 | "repo": "haskell-language-server", 377 | "type": "github" 378 | } 379 | }, 380 | "hls-2.6": { 381 | "flake": false, 382 | "locked": { 383 | "lastModified": 1705325287, 384 | "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", 385 | "owner": "haskell", 386 | "repo": "haskell-language-server", 387 | "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", 388 | "type": "github" 389 | }, 390 | "original": { 391 | "owner": "haskell", 392 | "ref": "2.6.0.0", 393 | "repo": "haskell-language-server", 394 | "type": "github" 395 | } 396 | }, 397 | "hpc-coveralls": { 398 | "flake": false, 399 | "locked": { 400 | "lastModified": 1607498076, 401 | "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", 402 | "owner": "sevanspowell", 403 | "repo": "hpc-coveralls", 404 | "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", 405 | "type": "github" 406 | }, 407 | "original": { 408 | "owner": "sevanspowell", 409 | "repo": "hpc-coveralls", 410 | "type": "github" 411 | } 412 | }, 413 | "hydra": { 414 | "inputs": { 415 | "nix": "nix", 416 | "nixpkgs": [ 417 | "haskellNix", 418 | "hydra", 419 | "nix", 420 | "nixpkgs" 421 | ] 422 | }, 423 | "locked": { 424 | "lastModified": 1671755331, 425 | "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", 426 | "owner": "NixOS", 427 | "repo": "hydra", 428 | "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", 429 | "type": "github" 430 | }, 431 | "original": { 432 | "id": "hydra", 433 | "type": "indirect" 434 | } 435 | }, 436 | "incl": { 437 | "inputs": { 438 | "nixlib": "nixlib" 439 | }, 440 | "locked": { 441 | "lastModified": 1693483555, 442 | "narHash": "sha256-Beq4WhSeH3jRTZgC1XopTSU10yLpK1nmMcnGoXO0XYo=", 443 | "owner": "divnix", 444 | "repo": "incl", 445 | "rev": "526751ad3d1e23b07944b14e3f6b7a5948d3007b", 446 | "type": "github" 447 | }, 448 | "original": { 449 | "owner": "divnix", 450 | "repo": "incl", 451 | "type": "github" 452 | } 453 | }, 454 | "iohkNix": { 455 | "inputs": { 456 | "blst": "blst", 457 | "nixpkgs": "nixpkgs_2", 458 | "secp256k1": "secp256k1", 459 | "sodium": "sodium" 460 | }, 461 | "locked": { 462 | "lastModified": 1702362799, 463 | "narHash": "sha256-cU8cZXNuo5GRwrSvWqdaqoW5tJ2HWwDEOvWwIVPDPmo=", 464 | "owner": "input-output-hk", 465 | "repo": "iohk-nix", 466 | "rev": "b426fb9e0b109a9d1dd2e1476f9e0bd8bb715142", 467 | "type": "github" 468 | }, 469 | "original": { 470 | "owner": "input-output-hk", 471 | "repo": "iohk-nix", 472 | "type": "github" 473 | } 474 | }, 475 | "iserv-proxy": { 476 | "flake": false, 477 | "locked": { 478 | "lastModified": 1691634696, 479 | "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", 480 | "ref": "hkm/remote-iserv", 481 | "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", 482 | "revCount": 14, 483 | "type": "git", 484 | "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" 485 | }, 486 | "original": { 487 | "ref": "hkm/remote-iserv", 488 | "type": "git", 489 | "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" 490 | } 491 | }, 492 | "lowdown-src": { 493 | "flake": false, 494 | "locked": { 495 | "lastModified": 1633514407, 496 | "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", 497 | "owner": "kristapsdz", 498 | "repo": "lowdown", 499 | "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", 500 | "type": "github" 501 | }, 502 | "original": { 503 | "owner": "kristapsdz", 504 | "repo": "lowdown", 505 | "type": "github" 506 | } 507 | }, 508 | "nix": { 509 | "inputs": { 510 | "lowdown-src": "lowdown-src", 511 | "nixpkgs": "nixpkgs", 512 | "nixpkgs-regression": "nixpkgs-regression" 513 | }, 514 | "locked": { 515 | "lastModified": 1661606874, 516 | "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", 517 | "owner": "NixOS", 518 | "repo": "nix", 519 | "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", 520 | "type": "github" 521 | }, 522 | "original": { 523 | "owner": "NixOS", 524 | "ref": "2.11.0", 525 | "repo": "nix", 526 | "type": "github" 527 | } 528 | }, 529 | "nix-tools-static": { 530 | "flake": false, 531 | "locked": { 532 | "lastModified": 1706266250, 533 | "narHash": "sha256-9t+GRk3eO9muCtKdNAwBtNBZ5dH1xHcnS17WaQyftwA=", 534 | "owner": "input-output-hk", 535 | "repo": "haskell-nix-example", 536 | "rev": "580cb6db546a7777dad3b9c0fa487a366c045c4e", 537 | "type": "github" 538 | }, 539 | "original": { 540 | "owner": "input-output-hk", 541 | "ref": "nix", 542 | "repo": "haskell-nix-example", 543 | "type": "github" 544 | } 545 | }, 546 | "nixlib": { 547 | "locked": { 548 | "lastModified": 1667696192, 549 | "narHash": "sha256-hOdbIhnpWvtmVynKcsj10nxz9WROjZja+1wRAJ/C9+s=", 550 | "owner": "nix-community", 551 | "repo": "nixpkgs.lib", 552 | "rev": "babd9cd2ca6e413372ed59fbb1ecc3c3a5fd3e5b", 553 | "type": "github" 554 | }, 555 | "original": { 556 | "owner": "nix-community", 557 | "repo": "nixpkgs.lib", 558 | "type": "github" 559 | } 560 | }, 561 | "nixpkgs": { 562 | "locked": { 563 | "lastModified": 1657693803, 564 | "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", 565 | "owner": "NixOS", 566 | "repo": "nixpkgs", 567 | "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", 568 | "type": "github" 569 | }, 570 | "original": { 571 | "owner": "NixOS", 572 | "ref": "nixos-22.05-small", 573 | "repo": "nixpkgs", 574 | "type": "github" 575 | } 576 | }, 577 | "nixpkgs-2003": { 578 | "locked": { 579 | "lastModified": 1620055814, 580 | "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", 581 | "owner": "NixOS", 582 | "repo": "nixpkgs", 583 | "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", 584 | "type": "github" 585 | }, 586 | "original": { 587 | "owner": "NixOS", 588 | "ref": "nixpkgs-20.03-darwin", 589 | "repo": "nixpkgs", 590 | "type": "github" 591 | } 592 | }, 593 | "nixpkgs-2105": { 594 | "locked": { 595 | "lastModified": 1659914493, 596 | "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", 597 | "owner": "NixOS", 598 | "repo": "nixpkgs", 599 | "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", 600 | "type": "github" 601 | }, 602 | "original": { 603 | "owner": "NixOS", 604 | "ref": "nixpkgs-21.05-darwin", 605 | "repo": "nixpkgs", 606 | "type": "github" 607 | } 608 | }, 609 | "nixpkgs-2111": { 610 | "locked": { 611 | "lastModified": 1659446231, 612 | "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", 613 | "owner": "NixOS", 614 | "repo": "nixpkgs", 615 | "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", 616 | "type": "github" 617 | }, 618 | "original": { 619 | "owner": "NixOS", 620 | "ref": "nixpkgs-21.11-darwin", 621 | "repo": "nixpkgs", 622 | "type": "github" 623 | } 624 | }, 625 | "nixpkgs-2205": { 626 | "locked": { 627 | "lastModified": 1685573264, 628 | "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", 629 | "owner": "NixOS", 630 | "repo": "nixpkgs", 631 | "rev": "380be19fbd2d9079f677978361792cb25e8a3635", 632 | "type": "github" 633 | }, 634 | "original": { 635 | "owner": "NixOS", 636 | "ref": "nixpkgs-22.05-darwin", 637 | "repo": "nixpkgs", 638 | "type": "github" 639 | } 640 | }, 641 | "nixpkgs-2211": { 642 | "locked": { 643 | "lastModified": 1688392541, 644 | "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", 645 | "owner": "NixOS", 646 | "repo": "nixpkgs", 647 | "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", 648 | "type": "github" 649 | }, 650 | "original": { 651 | "owner": "NixOS", 652 | "ref": "nixpkgs-22.11-darwin", 653 | "repo": "nixpkgs", 654 | "type": "github" 655 | } 656 | }, 657 | "nixpkgs-2305": { 658 | "locked": { 659 | "lastModified": 1701362232, 660 | "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", 661 | "owner": "NixOS", 662 | "repo": "nixpkgs", 663 | "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", 664 | "type": "github" 665 | }, 666 | "original": { 667 | "owner": "NixOS", 668 | "ref": "nixpkgs-23.05-darwin", 669 | "repo": "nixpkgs", 670 | "type": "github" 671 | } 672 | }, 673 | "nixpkgs-2311": { 674 | "locked": { 675 | "lastModified": 1701386440, 676 | "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", 677 | "owner": "NixOS", 678 | "repo": "nixpkgs", 679 | "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", 680 | "type": "github" 681 | }, 682 | "original": { 683 | "owner": "NixOS", 684 | "ref": "nixpkgs-23.11-darwin", 685 | "repo": "nixpkgs", 686 | "type": "github" 687 | } 688 | }, 689 | "nixpkgs-regression": { 690 | "locked": { 691 | "lastModified": 1643052045, 692 | "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", 693 | "owner": "NixOS", 694 | "repo": "nixpkgs", 695 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 696 | "type": "github" 697 | }, 698 | "original": { 699 | "owner": "NixOS", 700 | "repo": "nixpkgs", 701 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 702 | "type": "github" 703 | } 704 | }, 705 | "nixpkgs-unstable": { 706 | "locked": { 707 | "lastModified": 1694822471, 708 | "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", 709 | "owner": "NixOS", 710 | "repo": "nixpkgs", 711 | "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", 712 | "type": "github" 713 | }, 714 | "original": { 715 | "owner": "NixOS", 716 | "repo": "nixpkgs", 717 | "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", 718 | "type": "github" 719 | } 720 | }, 721 | "nixpkgs_2": { 722 | "locked": { 723 | "lastModified": 1684171562, 724 | "narHash": "sha256-BMUWjVWAUdyMWKk0ATMC9H0Bv4qAV/TXwwPUvTiC5IQ=", 725 | "owner": "nixos", 726 | "repo": "nixpkgs", 727 | "rev": "55af203d468a6f5032a519cba4f41acf5a74b638", 728 | "type": "github" 729 | }, 730 | "original": { 731 | "owner": "nixos", 732 | "ref": "release-22.11", 733 | "repo": "nixpkgs", 734 | "type": "github" 735 | } 736 | }, 737 | "old-ghc-nix": { 738 | "flake": false, 739 | "locked": { 740 | "lastModified": 1631092763, 741 | "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", 742 | "owner": "angerman", 743 | "repo": "old-ghc-nix", 744 | "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", 745 | "type": "github" 746 | }, 747 | "original": { 748 | "owner": "angerman", 749 | "ref": "master", 750 | "repo": "old-ghc-nix", 751 | "type": "github" 752 | } 753 | }, 754 | "root": { 755 | "inputs": { 756 | "CHaP": "CHaP", 757 | "flake-utils": "flake-utils", 758 | "haskellNix": "haskellNix", 759 | "incl": "incl", 760 | "iohkNix": "iohkNix", 761 | "nixpkgs": [ 762 | "haskellNix", 763 | "nixpkgs-unstable" 764 | ] 765 | } 766 | }, 767 | "secp256k1": { 768 | "flake": false, 769 | "locked": { 770 | "lastModified": 1683999695, 771 | "narHash": "sha256-9nJJVENMXjXEJZzw8DHzin1DkFkF8h9m/c6PuM7Uk4s=", 772 | "owner": "bitcoin-core", 773 | "repo": "secp256k1", 774 | "rev": "acf5c55ae6a94e5ca847e07def40427547876101", 775 | "type": "github" 776 | }, 777 | "original": { 778 | "owner": "bitcoin-core", 779 | "ref": "v0.3.2", 780 | "repo": "secp256k1", 781 | "type": "github" 782 | } 783 | }, 784 | "sodium": { 785 | "flake": false, 786 | "locked": { 787 | "lastModified": 1675156279, 788 | "narHash": "sha256-0uRcN5gvMwO7MCXVYnoqG/OmeBFi8qRVnDWJLnBb9+Y=", 789 | "owner": "input-output-hk", 790 | "repo": "libsodium", 791 | "rev": "dbb48cce5429cb6585c9034f002568964f1ce567", 792 | "type": "github" 793 | }, 794 | "original": { 795 | "owner": "input-output-hk", 796 | "repo": "libsodium", 797 | "rev": "dbb48cce5429cb6585c9034f002568964f1ce567", 798 | "type": "github" 799 | } 800 | }, 801 | "stackage": { 802 | "flake": false, 803 | "locked": { 804 | "lastModified": 1708646943, 805 | "narHash": "sha256-2yKh9HEWW+QvmUClepBuEQY0hgcPvCVoVHgrl3QPg8k=", 806 | "owner": "input-output-hk", 807 | "repo": "stackage.nix", 808 | "rev": "6cd41c982e508c0ea3bb872ebccfdd7a65a58b2b", 809 | "type": "github" 810 | }, 811 | "original": { 812 | "owner": "input-output-hk", 813 | "repo": "stackage.nix", 814 | "type": "github" 815 | } 816 | }, 817 | "systems": { 818 | "locked": { 819 | "lastModified": 1681028828, 820 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 821 | "owner": "nix-systems", 822 | "repo": "default", 823 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 824 | "type": "github" 825 | }, 826 | "original": { 827 | "owner": "nix-systems", 828 | "repo": "default", 829 | "type": "github" 830 | } 831 | } 832 | }, 833 | "root": "root", 834 | "version": 7 835 | } 836 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "cardano-coin-selection"; 3 | 4 | inputs = { 5 | haskellNix.url = "github:input-output-hk/haskell.nix"; 6 | nixpkgs.follows = "haskellNix/nixpkgs-unstable"; 7 | iohkNix.url = "github:input-output-hk/iohk-nix"; 8 | incl.url = "github:divnix/incl"; 9 | flake-utils.url = "github:hamishmack/flake-utils/hkm/nested-hydraJobs"; 10 | 11 | CHaP.url = "github:intersectmbo/cardano-haskell-packages?ref=repo"; 12 | CHaP.flake = false; 13 | }; 14 | 15 | outputs = inputs: let 16 | supportedSystems = [ 17 | "x86_64-linux" 18 | # disabling to reduce CI time initially. Uncomment later 19 | #"x86_64-darwin" 20 | #"aarch64-linux" 21 | #"aarch64-darwin" 22 | ]; 23 | in 24 | {inherit (inputs) incl;} 25 | // inputs.flake-utils.lib.eachSystem supportedSystems ( 26 | system: let 27 | # setup our nixpkgs with the haskell.nix overlays, and the iohk-nix 28 | # overlays... 29 | nixpkgs = import inputs.nixpkgs { 30 | overlays = [ 31 | # iohkNix.overlays.crypto provide libsodium-vrf, libblst and libsecp256k1. 32 | inputs.iohkNix.overlays.crypto 33 | # haskellNix.overlay can be configured by later overlays, so need to come before them. 34 | inputs.haskellNix.overlay 35 | # configure haskell.nix to use iohk-nix crypto librairies. 36 | inputs.iohkNix.overlays.haskell-nix-crypto 37 | ]; 38 | inherit system; 39 | inherit (inputs.haskellNix) config; 40 | }; 41 | inherit (nixpkgs) lib; 42 | 43 | # see flake `variants` below for alternative compilers 44 | defaultCompiler = "ghc964"; 45 | haddockShellCompiler = defaultCompiler; 46 | # We use cabalProject' to ensure we don't build the plan for 47 | # all systems. 48 | cabalProject = nixpkgs.haskell-nix.cabalProject' ({config, ...}: { 49 | src = ./.; 50 | name = "cardano-coin-selection"; 51 | compiler-nix-name = lib.mkDefault defaultCompiler; 52 | 53 | # we also want cross compilation to windows on linux (and only with default compiler). 54 | #crossPlatforms = p: 55 | # lib.optional (system == "x86_64-linux" && config.compiler-nix-name == defaultCompiler) 56 | # p.mingwW64; 57 | 58 | # CHaP input map, so we can find CHaP packages (needs to be more 59 | # recent than the index-state we set!). Can be updated with 60 | # 61 | # nix flake lock --update-input CHaP 62 | # 63 | inputMap = { 64 | "https://chap.intersectmbo.org/" = inputs.CHaP; 65 | }; 66 | # tools we want in our shell, from hackage 67 | shell.tools = 68 | { 69 | cabal = "3.10.2.0"; 70 | ghcid = "0.8.9"; 71 | } 72 | // lib.optionalAttrs (config.compiler-nix-name == defaultCompiler) { 73 | # tools that work only with default compiler 74 | fourmolu = "0.14.0.0"; 75 | hlint = "3.6.1"; 76 | stylish-haskell = "0.14.5.0"; 77 | haskell-language-server = "2.7.0.0"; 78 | }; 79 | # and from nixpkgs or other inputs 80 | shell.nativeBuildInputs = with nixpkgs; [ gh jq yq-go ]; 81 | # disable Hoogle until someone request it 82 | shell.withHoogle = false; 83 | # Skip cross compilers for the shell 84 | shell.crossPlatforms = _: []; 85 | 86 | # package customizations as needed. Where cabal.project is not 87 | # specific enough, or doesn't allow setting these. 88 | modules = [ 89 | ({pkgs, ...}: { 90 | packages.cardano-coin-selection.configureFlags = ["--ghc-option=-Werror"]; 91 | packages.cardano-coin-selection.components.tests.unit.build-tools = [ 92 | config.hsPkgs.hspec-discover.components.exes.hspec-discover 93 | ]; 94 | }) 95 | { 96 | packages.crypton-x509-system.postPatch = '' 97 | substituteInPlace crypton-x509-system.cabal --replace 'Crypt32' 'crypt32' 98 | ''; 99 | } 100 | ]; 101 | }); 102 | # ... and construct a flake from the cabal project 103 | flake = cabalProject.flake ( 104 | lib.optionalAttrs (system == "x86_64-linux") { 105 | # on linux, build/test other supported compilers 106 | variants = lib.genAttrs ["ghc8107"] (compiler-nix-name: { 107 | inherit compiler-nix-name; 108 | }); 109 | } 110 | ); 111 | in 112 | lib.recursiveUpdate flake rec { 113 | project = cabalProject; 114 | # add a required job, that's basically all hydraJobs. 115 | hydraJobs = 116 | nixpkgs.callPackages inputs.iohkNix.utils.ciJobsAggregates 117 | { 118 | ciJobs = 119 | flake.hydraJobs 120 | // { 121 | # This ensure hydra send a status for the required job (even if no change other than commit hash) 122 | revision = nixpkgs.writeText "revision" (inputs.self.rev or "dirty"); 123 | }; 124 | } 125 | // { haddockShell = devShells.haddockShell; }; 126 | legacyPackages = rec { 127 | inherit cabalProject nixpkgs; 128 | # also provide hydraJobs through legacyPackages to allow building without system prefix: 129 | inherit hydraJobs; 130 | # expose cardano-coin-selection binary at top-level 131 | cardano-coin-selection = cabalProject.hsPkgs.cardano-coin-selection.components.library; 132 | }; 133 | devShells = let 134 | profilingShell = p: { 135 | # `nix develop .#profiling` (or `.#ghc927.profiling): a shell with profiling enabled 136 | profiling = (p.appendModule {modules = [{enableLibraryProfiling = true;}];}).shell; 137 | }; 138 | in 139 | profilingShell cabalProject 140 | # Add GHC 9.6 shell for haddocks 141 | // 142 | { haddockShell = let 143 | p = cabalProject.appendModule {compiler-nix-name = haddockShellCompiler;}; 144 | in 145 | p.shell // (profilingShell p); 146 | }; 147 | # formatter used by nix fmt 148 | formatter = nixpkgs.alejandra; 149 | } 150 | ); 151 | 152 | nixConfig = { 153 | extra-substituters = [ 154 | "https://cache.iog.io" 155 | ]; 156 | extra-trusted-public-keys = [ 157 | "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" 158 | ]; 159 | allow-import-from-derivation = true; 160 | }; 161 | } 162 | -------------------------------------------------------------------------------- /information/repository-creation-process.md: -------------------------------------------------------------------------------- 1 | # Introduction 2 | 3 | This article documents the process that we used to create the 4 | `cardano-coin-selection` repository. 5 | 6 | # Contents 7 | 8 | * [Overview](#overview) 9 | * [Background](#background) 10 | * [Process](#process) 11 | * [Step 1: Clone Source Repository](#step-1-clone-source-repository) 12 | * [Step 2: Remove Irrelevant Files](#step-2-remove-irrelevant-files) 13 | * [Step 3: Identify Content Ancestors](#step-3-identify-content-ancestors) 14 | * [Step 4: Filter Commit History](#step-4-filter-commit-history) 15 | * [Step 5: Verify Commit History](#step-5-verify-commit-history) 16 | 17 | # Overview 18 | 19 | The `cardano-coin-selection` repository was created by taking a clone of the 20 | pre-existing `cardano-wallet` repository and *filtering out* a *relevant 21 | subset* of the version control history. 22 | 23 | This article provides a record of the steps we used to perform this operation. 24 | 25 | # Background 26 | 27 | Filtering the version control history of a repository is non-trivial. 28 | 29 | One issue is that files in a repository are often renamed several times over 30 | the course of their history, and other files are composed of content from 31 | multiple ancestor files. 32 | 33 | Assuming that we'd like to generate a *new* repository from a *subset* of the 34 | files in some source repository, we have to find a way to retain the history of 35 | not just the subset of files that we're interested in, but *also* the histories 36 | of all files that served as *content ancestors* for that subset of files. 37 | 38 | If we just naively filter for commits that affect the subset of files we're 39 | interested in, we run the risk of losing those commits that affect older 40 | versions of files that existed at different paths. 41 | 42 | In general, we'd like to keep commits for both: 43 | 44 | * all files of interest; and 45 | * all ancestors of files that are of interest. 46 | 47 | ## Example 48 | 49 | For example, suppose that the module `Cardano.Wallet.Primitive.Types` includes 50 | content from files that once existed at the following paths: 51 | 52 | * `lib/core/src/Cardano/Wallet/Types.hs` 53 | * `lib/core/src/Cardano/Wallet/Primitive/Types.hs` 54 | * `src/Cardano/Wallet/Primitive.hs` 55 | * `src/Cardano/Wallet/Primitive/Types.hs` 56 | 57 | We'd ideally like to keep commits relating to all of those paths. 58 | 59 | # Process 60 | 61 | Here is a record of the steps we used to create the `cardano-coin-selection` 62 | repository. 63 | 64 | ## Step 1: Clone Source Repository 65 | 66 | We start with a fresh clone of the source repository (in our case, the 67 | `cardano-wallet` repository). 68 | 69 | ## Step 2: Remove Irrelevant Files 70 | 71 | In this step, we identify the files that we want to keep, and remove all files 72 | that are irrelevant. 73 | 74 | To achieve this, we make a *single commit* to the `master` branch that removes 75 | all unwanted files from the repository. The result of applying this commit 76 | should be precisely the set of files we want to keep. 77 | 78 | Note that in the case of Haskell modules, we need to be somewhat careful, and 79 | avoid deleting any modules that define functions imported by the modules we 80 | want to keep. To avoid deleting too much, we need to determine the *transitive 81 | closure* of module dependencies required by the modules that we're interested 82 | in. 83 | 84 | A safe way to achieve this is to *iteratively* remove files that we're not 85 | interested in, while confirming that it is still possible to build the 86 | remaining subset, repeating the process until all unwanted files are deleted. 87 | 88 | ### Example 89 | 90 | Suppose that we want to keep file `src/ImportantModule.hs`, but that it imports 91 | functions defined in the following modules: 92 | 93 | * `src/Wibble.hs` 94 | * `src/Wobble.hs` 95 | 96 | Furthermore, suppose that `src/Wibble.hs` imports functions from the following 97 | modules: 98 | 99 | * `src/Foo.hs` 100 | * `src/Bar.hs` 101 | 102 | If we wish to keep `src/ImportantModule.hs`, we should therefore also keep: 103 | 104 | * `src/Wibble.hs` 105 | * `src/Wobble.hs` 106 | * `src/Foo.hs` 107 | * `src/Bar.hs` 108 | 109 | ## Step 3: Identify Content Ancestors 110 | 111 | In this step, we identify the historic ancestors of all files that we want to 112 | keep. 113 | 114 | We generate a list of path names for *all current files*, as well as path names 115 | for *all historical ancestor files*, using the following script: 116 | 117 | `find-paths.sh`: 118 | ```sh 119 | for x in $(git ls-tree -r master --name-only) 120 | do 121 | git log --follow --name-status -- $x \ 122 | | egrep R[0-9]+ \ 123 | | awk '{print $2; print $3}' \ 124 | | sort -u 125 | done 126 | ``` 127 | 128 | Run the script from the root of the repository, as follows: 129 | ```sh 130 | find-paths.sh | sort -u > files-to-keep 131 | ``` 132 | 133 | ## Step 4: Filter Commit History 134 | 135 | In this step, we *filter* the version control history, removing all commits 136 | that are unrelated to the list of files identified in the previous step. 137 | 138 | Run the following command, using the `git-filter-repo` tool: 139 | 140 | ```sh 141 | git filter-repo --paths-from-file files-to-keep 142 | ``` 143 | 144 | ## Step 5: Verify Commit History 145 | 146 | In this step, we verify that we have retained all relevant parts of the 147 | history. 148 | 149 | Re-run the `find-paths` script from the root of the repository, as follows: 150 | ```sh 151 | find-paths.sh | sort -u > files-kept 152 | ``` 153 | 154 | The content of `files-kept` should be **identical** to `files-to-keep`. 155 | -------------------------------------------------------------------------------- /scripts/hlint.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . 3 | -------------------------------------------------------------------------------- /scripts/stylish-haskell.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | curl -sSL https://raw.github.com/jaspervdj/stylish-haskell/master/scripts/latest.sh | sh -s $(find . -type f -name "*.hs" ! -path "*.stack-work*") -i 3 | if [ -z "$(git status --porcelain)" ]; then 4 | echo "No style errors detected." 5 | else 6 | echo "Style errors detected:" 7 | git diff 8 | exit 1 9 | fi 10 | -------------------------------------------------------------------------------- /src/internal/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | 4 | -- | 5 | -- Copyright: © 2018-2024 Intersect MBO 6 | -- License: Apache-2.0 7 | -- 8 | -- This module hierarchy provides types and functions that are not intended to 9 | -- be part of the public API. 10 | -- 11 | -- Types and functions defined herein are not guaranteed to be forwards or 12 | -- backwards compatible across different versions of the library. 13 | -- 14 | module Internal 15 | ( module Internal.Invariant 16 | , module Internal.Rounding 17 | ) where 18 | 19 | import Internal.Invariant 20 | import Internal.Rounding 21 | -------------------------------------------------------------------------------- /src/internal/Internal/Coin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# OPTIONS_HADDOCK hide #-} 5 | 6 | -- | 7 | -- Copyright: © 2018-2024 Intersect MBO 8 | -- License: Apache-2.0 9 | -- 10 | module Internal.Coin 11 | ( 12 | -- * Types 13 | Coin 14 | 15 | -- Construction and Deconstruction 16 | , coinFromIntegral 17 | , coinFromNatural 18 | , coinToIntegral 19 | , coinToNatural 20 | 21 | -- * Unary Operations 22 | , pred 23 | , succ 24 | 25 | -- * Binary Operations 26 | , add 27 | , sub 28 | , mul 29 | , div 30 | , mod 31 | 32 | -- * Calculating Distances 33 | , distance 34 | 35 | -- * Value Tests 36 | , isZero 37 | 38 | -- * Special Values 39 | , zero 40 | , one 41 | 42 | ) where 43 | 44 | import Prelude hiding ( div, fromIntegral, mod, pred, succ ) 45 | 46 | import GHC.Generics ( Generic ) 47 | import Numeric.Natural ( Natural ) 48 | import Quiet ( Quiet (Quiet) ) 49 | 50 | import qualified Prelude 51 | 52 | -- | Represents a non-negative integral amount of currency. 53 | -- 54 | -- Use 'coinFromNatural' to create a coin from a natural number. 55 | -- 56 | -- Use 'coinToNatural' to convert a coin into a natural number. 57 | -- 58 | -- @since 1.0.0 59 | newtype Coin = Coin { unCoin :: Natural } 60 | deriving stock (Eq, Generic, Ord) 61 | deriving Show via (Quiet Coin) 62 | 63 | -- | Creates a coin from an integral number. 64 | -- 65 | -- Returns a coin if (and only if) the given input is not negative. 66 | -- 67 | coinFromIntegral :: Integral i => i -> Maybe Coin 68 | coinFromIntegral i 69 | | i >= 0 = Just $ Coin $ Prelude.fromIntegral i 70 | | otherwise = Nothing 71 | 72 | -- | Creates a coin from a natural number. 73 | -- 74 | -- @since 1.0.0 75 | coinFromNatural :: Natural -> Coin 76 | coinFromNatural = Coin 77 | 78 | -- | Converts the given coin into an integral number. 79 | -- 80 | coinToIntegral :: Integral i => Coin -> i 81 | coinToIntegral (Coin i) = Prelude.fromIntegral i 82 | 83 | -- | Converts the given coin into a natural number. 84 | -- 85 | -- @since 1.0.0 86 | coinToNatural :: Coin -> Natural 87 | coinToNatural = unCoin 88 | 89 | add :: Coin -> Coin -> Coin 90 | add (Coin x) (Coin y) = Coin $ x + y 91 | 92 | sub :: Coin -> Coin -> Maybe Coin 93 | sub (Coin x) (Coin y) = coinFromIntegral $ toInteger x - toInteger y 94 | 95 | mul :: Integral i => Coin -> i -> Maybe Coin 96 | mul (Coin x) y = coinFromIntegral $ toInteger x * toInteger y 97 | 98 | div :: Integral i => Coin -> i -> Maybe Coin 99 | div (Coin x) y 100 | | y <= 0 = Nothing 101 | | otherwise = coinFromIntegral $ toInteger x `Prelude.div` toInteger y 102 | 103 | mod :: Integral i => Coin -> i -> Maybe Coin 104 | mod (Coin x) y 105 | | y <= 0 = Nothing 106 | | otherwise = coinFromIntegral $ toInteger x `Prelude.mod` toInteger y 107 | 108 | distance :: Coin -> Coin -> Coin 109 | distance (Coin x) (Coin y) 110 | | x >= y = Coin $ x - y 111 | | otherwise = Coin $ y - x 112 | 113 | pred :: Coin -> Maybe Coin 114 | pred x = x `sub` one 115 | 116 | succ :: Coin -> Coin 117 | succ x = x `add` one 118 | 119 | isZero :: Coin -> Bool 120 | isZero = (== zero) 121 | 122 | zero :: Coin 123 | zero = Coin 0 124 | 125 | one :: Coin 126 | one = Coin 1 127 | 128 | newtype Sum a = Sum { getSum :: a } 129 | deriving stock (Eq, Generic, Ord) 130 | deriving Show via (Quiet (Sum a)) 131 | 132 | instance Monoid Coin where 133 | mempty = zero 134 | 135 | instance Semigroup Coin where 136 | (<>) = add 137 | -------------------------------------------------------------------------------- /src/internal/Internal/Invariant.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | 3 | -- | 4 | -- Copyright: © 2018-2024 Intersect MBO 5 | -- License: Apache-2.0 6 | -- 7 | -- Provides internal functions relating to verification of invariants. 8 | -- 9 | module Internal.Invariant 10 | ( invariant 11 | ) where 12 | 13 | import Prelude 14 | 15 | -- | Checks whether or not an invariant holds, by applying the given predicate 16 | -- to the given value. 17 | -- 18 | -- If the invariant does not hold (indicated by the predicate function 19 | -- returning 'False'), throws an error with the specified message. 20 | -- 21 | -- >>> invariant "not empty" [1,2,3] (not . null) 22 | -- [1, 2, 3] 23 | -- 24 | -- >>> invariant "not empty" [] (not . null) 25 | -- *** Exception: not empty 26 | invariant 27 | :: String 28 | -- ^ The message 29 | -> a 30 | -- ^ The value to test 31 | -> (a -> Bool) 32 | -- ^ The predicate 33 | -> a 34 | invariant msg a predicate = 35 | if predicate a then a else error msg 36 | -------------------------------------------------------------------------------- /src/internal/Internal/Rounding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | {-# OPTIONS_HADDOCK hide #-} 4 | 5 | -- | 6 | -- Copyright: © 2018-2024 Intersect MBO 7 | -- License: Apache-2.0 8 | -- 9 | -- Provides internal types and functions relating to rounding of fractional 10 | -- numbers. 11 | -- 12 | module Internal.Rounding 13 | ( RoundingDirection (..) 14 | , round 15 | ) where 16 | 17 | import Prelude hiding ( round ) 18 | 19 | -- | Indicates a rounding direction to be used when converting from a 20 | -- fractional value to an integral value. 21 | -- 22 | -- See 'round'. 23 | -- 24 | data RoundingDirection 25 | = RoundUp 26 | -- ^ Round up to the nearest integral value. 27 | | RoundDown 28 | -- ^ Round down to the nearest integral value. 29 | deriving (Eq, Show) 30 | 31 | -- | Use the given rounding direction to round the given fractional value, 32 | -- producing an integral result. 33 | -- 34 | round :: (RealFrac a, Integral b) => RoundingDirection -> a -> b 35 | round = \case 36 | RoundUp -> ceiling 37 | RoundDown -> floor 38 | -------------------------------------------------------------------------------- /src/library/Cardano/CoinSelection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | 7 | {-# OPTIONS_HADDOCK prune #-} 8 | 9 | -- | 10 | -- Copyright: © 2018-2024 Intersect MBO 11 | -- License: Apache-2.0 12 | -- 13 | -- Provides general functions and types relating to coin selection. 14 | -- 15 | -- The 'CoinSelection' type represents a __coin selection__, the basis for a 16 | -- /transaction/ in a UTxO-based blockchain. 17 | -- 18 | -- The 'CoinSelectionAlgorithm' type provides a __common interface__ to 19 | -- algorithms that generate coin selections. 20 | -- 21 | -- For a guide to __algorithms provided by this library__, see the 22 | -- "Cardano.CoinSelection.Algorithm" module. 23 | -- 24 | -- To adjust coin selections in order to __pay for transaction fees__, see 25 | -- the "Cardano.CoinSelection.Fee" module. 26 | -- 27 | module Cardano.CoinSelection 28 | ( 29 | -- * Coin Selections 30 | CoinSelection (..) 31 | , sumInputs 32 | , sumOutputs 33 | , sumChange 34 | 35 | -- * Coin Selection Algorithms 36 | , CoinSelectionAlgorithm (..) 37 | , CoinSelectionParameters (..) 38 | , CoinSelectionResult (..) 39 | , CoinSelectionLimit (..) 40 | 41 | -- * Coins 42 | , Coin 43 | , coinFromNatural 44 | , coinToNatural 45 | 46 | -- * Coin Maps 47 | , CoinMap (..) 48 | , CoinMapEntry (..) 49 | , coinMapFromList 50 | , coinMapToList 51 | , coinMapValue 52 | 53 | -- * Coin Selection Errors 54 | , CoinSelectionError (..) 55 | , InputValueInsufficientError (..) 56 | , InputCountInsufficientError (..) 57 | , InputLimitExceededError (..) 58 | , InputsExhaustedError (..) 59 | 60 | -- # Internal Functions 61 | , coinMapRandomEntry 62 | 63 | ) where 64 | 65 | import Prelude 66 | 67 | import Control.Arrow ( (&&&) ) 68 | import Control.Monad.Trans.Except ( ExceptT (..) ) 69 | import Crypto.Number.Generate ( generateBetween ) 70 | import Crypto.Random.Types ( MonadRandom ) 71 | import Data.Map.Strict ( Map ) 72 | import Data.Word ( Word16 ) 73 | import GHC.Generics ( Generic ) 74 | import Internal.Coin ( Coin, coinFromNatural, coinToNatural ) 75 | import Numeric.Natural ( Natural ) 76 | import Quiet ( Quiet (Quiet) ) 77 | 78 | import qualified Data.Foldable as F 79 | import qualified Data.Map.Strict as Map 80 | 81 | -------------------------------------------------------------------------------- 82 | -- Coin Map 83 | -------------------------------------------------------------------------------- 84 | 85 | -- | A mapping from unique keys to associated 'Coin' values. 86 | -- 87 | -- A 'CoinMap' can be used to represent: 88 | -- 89 | -- * a UTxO set, where each key within the map refers to an unspent output 90 | -- from a previous transaction. 91 | -- 92 | -- * a set of 'inputs' to a 'CoinSelection', where each input is an entry 93 | -- selected from a UTxO set by a 'CoinSelectionAlgorithm'. 94 | -- 95 | -- * a set of 'outputs' for a 'CoinSelection', where each key within the map 96 | -- refers to the address of a payment recipient. 97 | -- 98 | -- A 'CoinMap' can be constructed with the 'coinMapFromList' function. 99 | -- 100 | -- The total value of a 'CoinMap' is given by the 'coinMapValue' function. 101 | -- 102 | -- @since 1.0.0 103 | newtype CoinMap a = CoinMap { unCoinMap :: Map a Coin } 104 | deriving (Eq, Generic) 105 | deriving Show via (Quiet (CoinMap a)) 106 | 107 | instance Foldable CoinMap where 108 | foldMap f = F.fold . fmap (f . entryKey) . coinMapToList 109 | 110 | instance Ord a => Monoid (CoinMap a) where 111 | mempty = CoinMap mempty 112 | 113 | instance Ord a => Semigroup (CoinMap a) where 114 | CoinMap a <> CoinMap b = CoinMap $ Map.unionWith (<>) a b 115 | 116 | -- | An entry for a 'CoinMap'. 117 | -- 118 | -- @since 1.0.0 119 | data CoinMapEntry a = CoinMapEntry 120 | { entryKey 121 | :: a 122 | -- ^ The unique key associated with this entry. 123 | , entryValue 124 | :: Coin 125 | -- ^ The coin value associated with this entry. 126 | } deriving (Eq, Generic, Ord, Show) 127 | 128 | -- | Constructs a 'CoinMap' from a list of entries. 129 | -- 130 | -- See 'CoinMapEntry'. 131 | -- 132 | -- @since 1.0.0 133 | coinMapFromList :: Ord a => [CoinMapEntry a] -> CoinMap a 134 | coinMapFromList = CoinMap 135 | . Map.fromListWith (<>) 136 | . fmap (entryKey &&& entryValue) 137 | 138 | -- | Converts a 'CoinMap' to a list of entries. 139 | -- 140 | -- See 'CoinMapEntry'. 141 | -- 142 | -- @since 1.0.0 143 | coinMapToList :: CoinMap a -> [CoinMapEntry a] 144 | coinMapToList = fmap (uncurry CoinMapEntry) . Map.toList . unCoinMap 145 | 146 | -- | Calculates the total coin value associated with a 'CoinMap'. 147 | -- 148 | -- @since 1.0.0 149 | coinMapValue :: CoinMap a -> Coin 150 | coinMapValue = mconcat . fmap entryValue . coinMapToList 151 | 152 | -------------------------------------------------------------------------------- 153 | -- Coin Selection 154 | -------------------------------------------------------------------------------- 155 | 156 | -- | Provides a __common interface__ for coin selection algorithms. 157 | -- 158 | -- The function 'selectCoins', when applied to the given 159 | -- 'CoinSelectionParameters' object (with /available inputs/ and /requested/ 160 | -- /outputs/), will generate a 'CoinSelectionResult' (with /remaining inputs/ 161 | -- and a /coin selection/). 162 | -- 163 | -- For implementations provided by this library, see 164 | -- "Cardano.CoinSelection.Algorithm". 165 | -- 166 | -- @since 1.0.0 167 | newtype CoinSelectionAlgorithm i o m = CoinSelectionAlgorithm 168 | { selectCoins 169 | :: CoinSelectionParameters i o 170 | -> ExceptT CoinSelectionError m (CoinSelectionResult i o) 171 | } 172 | 173 | -- | The complete set of parameters required for a 'CoinSelectionAlgorithm'. 174 | -- 175 | -- The 'inputsAvailable' and 'outputsRequested' fields are both maps of unique 176 | -- keys to associated 'Coin' values, where: 177 | -- 178 | -- * Each key-value pair in the 'inputsAvailable' map corresponds to an 179 | -- __unspent output__ from a previous transaction that is /available/ 180 | -- /for selection as an input/ by the coin selection algorithm. The /key/ 181 | -- is a unique reference to that output, and the /value/ is the amount of 182 | -- unspent value associated with it. 183 | -- 184 | -- * Each key-value pair in the 'outputsRequested' map corresponds to a 185 | -- __payment__ whose value is /to be paid for/ by the coin selection 186 | -- algorithm. The /key/ is a unique reference to a payment recipient, 187 | -- and the /value/ is the amount of money to pay to that recipient. 188 | -- 189 | -- A coin selection algorithm will select a __subset__ of inputs from 190 | -- 'inputsAvailable' in order to pay for __all__ the outputs in 191 | -- 'outputsRequested', where: 192 | -- 193 | -- * Inputs __selected__ by the algorithm are included in the 'inputs' 194 | -- set of the generated 'CoinSelection'. 195 | -- 196 | -- * Inputs __not__ selected by the algorithm are included in the 197 | -- 'inputsRemaining' set of the 'CoinSelectionResult'. 198 | -- 199 | -- The number of inputs that can selected is limited by 'limit'. 200 | -- 201 | -- The total value of 'inputsAvailable' must be /greater than or equal to/ 202 | -- the total value of 'outputsRequested', as given by the 'coinMapValue' 203 | -- function. 204 | -- 205 | -- @since 1.0.0 206 | data CoinSelectionParameters i o = CoinSelectionParameters 207 | { inputsAvailable :: CoinMap i 208 | -- ^ The set of inputs available for selection. 209 | , outputsRequested :: CoinMap o 210 | -- ^ The set of outputs requested for payment. 211 | , limit :: CoinSelectionLimit 212 | -- ^ A limit on the number of inputs that can be selected. 213 | } 214 | deriving Generic 215 | 216 | -- | Represents the __result__ of running a coin selection algorithm. 217 | -- 218 | -- See 'CoinSelectionAlgorithm'. 219 | -- 220 | -- @since 1.0.0 221 | data CoinSelectionResult i o = CoinSelectionResult 222 | { coinSelection :: CoinSelection i o 223 | -- ^ The generated coin selection. 224 | , inputsRemaining :: CoinMap i 225 | -- ^ The set of inputs that were __not__ selected. 226 | } deriving (Eq, Show) 227 | 228 | -- | A __coin selection__ is the basis for a /transaction/. 229 | -- 230 | -- It consists of a selection of 'inputs', 'outputs', and 'change'. 231 | -- 232 | -- The 'inputs' and 'outputs' fields are both maps of unique keys to associated 233 | -- 'Coin' values, where: 234 | -- 235 | -- * Each key-value pair in the 'inputs' map corresponds to an 236 | -- __unspent output__ from a previous transaction (also known as a UTxO). 237 | -- The /key/ is a unique reference to that output, and the /value/ is the 238 | -- amount of unspent value associated with it. 239 | -- 240 | -- * Each key-value pair in the 'outputs' map corresponds to a __payment__. 241 | -- The /key/ is a unique reference to a payment recipient, and the /value/ 242 | -- is the amount of money to pay to that recipient. 243 | -- 244 | -- The 'change' field is a set of coins to be returned to the originator of the 245 | -- transaction. 246 | -- 247 | -- The 'CoinSelectionAlgorithm' type provides a common interface for generating 248 | -- coin selections. 249 | -- 250 | -- @since 1.0.0 251 | data CoinSelection i o = CoinSelection 252 | { inputs :: CoinMap i 253 | -- ^ The set of inputs. 254 | , outputs :: CoinMap o 255 | -- ^ The set of outputs. 256 | , change :: [Coin] 257 | -- ^ The set of change. 258 | } 259 | deriving (Generic, Show, Eq) 260 | 261 | instance (Ord i, Ord o) => Semigroup (CoinSelection i o) where 262 | a <> b = CoinSelection 263 | { inputs = inputs a <> inputs b 264 | , outputs = outputs a <> outputs b 265 | , change = change a <> change b 266 | } 267 | 268 | instance (Ord i, Ord o) => Monoid (CoinSelection i o) where 269 | mempty = CoinSelection mempty mempty mempty 270 | 271 | -- | Calculate the total sum of all 'inputs' for the given 'CoinSelection'. 272 | -- 273 | -- @since 1.0.0 274 | sumInputs :: CoinSelection i o -> Coin 275 | sumInputs = coinMapValue . inputs 276 | 277 | -- | Calculate the total sum of all 'outputs' for the given 'CoinSelection'. 278 | -- 279 | -- @since 1.0.0 280 | sumOutputs :: CoinSelection i o -> Coin 281 | sumOutputs = coinMapValue . outputs 282 | 283 | -- | Calculate the total sum of all 'change' for the given 'CoinSelection'. 284 | -- 285 | -- @since 1.0.0 286 | sumChange :: CoinSelection i o -> Coin 287 | sumChange = mconcat . change 288 | 289 | -- | Defines an __inclusive upper bound__ on the /number/ of inputs that 290 | -- a 'CoinSelectionAlgorithm' is allowed to select. 291 | -- 292 | -- @since 1.0.0 293 | newtype CoinSelectionLimit = CoinSelectionLimit 294 | { calculateLimit 295 | :: Word16 -> Word16 296 | -- ^ Calculate the maximum number of inputs allowed for a given 297 | -- number of outputs. 298 | } deriving Generic 299 | 300 | -- | Represents the set of possible failures that can occur when attempting 301 | -- to produce a 'CoinSelection' with a 'CoinSelectionAlgorithm'. 302 | -- 303 | -- See 'selectCoins'. 304 | -- 305 | -- @since 1.0.0 306 | data CoinSelectionError 307 | = InputValueInsufficient 308 | InputValueInsufficientError 309 | | InputCountInsufficient 310 | InputCountInsufficientError 311 | | InputLimitExceeded 312 | InputLimitExceededError 313 | | InputsExhausted 314 | InputsExhaustedError 315 | deriving (Eq, Show) 316 | 317 | -- | Indicates that the total value of 'inputsAvailable' is less than the total 318 | -- value of 'outputsRequested', making it /impossible/ to cover all payments, 319 | -- /regardless/ of which algorithm is chosen. 320 | -- 321 | -- @since 1.0.0 322 | data InputValueInsufficientError = 323 | InputValueInsufficientError 324 | { inputValueAvailable :: Coin 325 | -- ^ The total value of 'inputsAvailable'. 326 | , inputValueRequired :: Coin 327 | -- ^ The total value of 'outputsRequested'. 328 | } 329 | deriving (Eq, Show) 330 | 331 | -- | Indicates that the total count of entries in 'inputsAvailable' is /fewer/ 332 | -- /than/ required by the algorithm. The number required depends on the 333 | -- particular algorithm implementation. 334 | -- 335 | -- @since 1.0.0 336 | data InputCountInsufficientError = 337 | InputCountInsufficientError 338 | { inputCountAvailable :: Natural 339 | -- ^ The number of entries in 'inputsAvailable'. 340 | , inputCountRequired :: Natural 341 | -- ^ The number of entries required. 342 | } 343 | deriving (Eq, Show) 344 | 345 | -- | Indicates that all available entries in 'inputsAvailable' were depleted 346 | -- /before/ all the payments in 'outputsRequested' could be paid for. 347 | -- 348 | -- This condition can occur /even if/ the total value of 'inputsAvailable' is 349 | -- greater than or equal to the total value of 'outputsRequested', due to 350 | -- differences in the way that algorithms select inputs. 351 | -- 352 | -- @since 1.0.0 353 | data InputsExhaustedError = 354 | InputsExhaustedError 355 | deriving (Eq, Show) 356 | 357 | -- | Indicates that the coin selection algorithm is unable to cover the total 358 | -- value of 'outputsRequested' without exceeding the maximum number of inputs 359 | -- defined by 'limit'. 360 | -- 361 | -- See 'calculateLimit'. 362 | -- 363 | -- @since 1.0.0 364 | newtype InputLimitExceededError = 365 | InputLimitExceededError 366 | { calculatedInputLimit :: Word16 } 367 | deriving (Eq, Show) 368 | 369 | -------------------------------------------------------------------------------- 370 | -- Internal Functions 371 | -------------------------------------------------------------------------------- 372 | 373 | -- Selects an entry at random from a 'CoinMap', returning both the selected 374 | -- entry and the map with the entry removed. 375 | -- 376 | -- If the given map is empty, this function returns 'Nothing'. 377 | -- 378 | coinMapRandomEntry 379 | :: MonadRandom m 380 | => CoinMap a 381 | -> m (Maybe (CoinMapEntry a, CoinMap a)) 382 | coinMapRandomEntry (CoinMap m) 383 | | Map.null m = 384 | return Nothing 385 | | otherwise = Just <$> do 386 | ix <- fromEnum <$> generateBetween 0 (toEnum (Map.size m - 1)) 387 | let entry = uncurry CoinMapEntry $ Map.elemAt ix m 388 | let remainder = CoinMap $ Map.deleteAt ix m 389 | return (entry, remainder) 390 | -------------------------------------------------------------------------------- /src/library/Cardano/CoinSelection/Algorithm.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright: © 2018-2024 Intersect MBO 3 | -- License: Apache-2.0 4 | -- 5 | -- __Submodules__ of this module provide implementations of 6 | -- __coin selection algorithms__. 7 | -- 8 | -- Algorithms can be divided into two categories: 9 | -- 10 | -- * <#generalized-algorithms Generalized Algorithms> 11 | -- 12 | -- Algorithms that implement the general 13 | -- 'Cardano.CoinSelection.CoinSelectionAlgorithm' interface. 14 | -- 15 | -- * <#specialized-algorithms Specialized Algorithms> 16 | -- 17 | -- Algorithms that provide functionality suited to specialized purposes. 18 | -- 19 | -- = Generalized Algorithms #generalized-algorithms# 20 | -- 21 | -- The following algorithms implement the general 22 | -- 'Cardano.CoinSelection.CoinSelectionAlgorithm' interface: 23 | -- 24 | -- * __"Cardano.CoinSelection.Algorithm.LargestFirst"__ 25 | -- 26 | -- Provides an implementation of the __Largest-First__ algorithm. 27 | -- 28 | -- When selecting inputs from a given set of UTxO entries, this 29 | -- algorithm always selects the /largest/ entries /first/. 30 | -- 31 | -- * __"Cardano.CoinSelection.Algorithm.RandomImprove"__ 32 | -- 33 | -- Provides an implementation of the __Random-Improve__ algorithm. 34 | -- 35 | -- When selecting inputs from a given set of UTxO entries, this 36 | -- algorithm always selects entries at /random/. 37 | -- 38 | -- Once selections have been made, a second phase attempts to /improve/ 39 | -- on each of the existing selections in order to optimize change 40 | -- outputs. 41 | -- 42 | -- For __guidance on choosing an algorithm__ that's appropriate for your 43 | -- scenario, please consult the following article: 44 | -- 45 | -- 46 | -- 47 | -- = Specialized Algorithms #specialized-algorithms# 48 | -- 49 | -- The following algorithms provide functionality suited to specialized 50 | -- purposes: 51 | -- 52 | -- * __"Cardano.CoinSelection.Algorithm.Migration"__ 53 | -- 54 | -- Provides an algorithm for migrating all funds from one wallet to 55 | -- another. 56 | -- 57 | module Cardano.CoinSelection.Algorithm where 58 | -------------------------------------------------------------------------------- /src/library/Cardano/CoinSelection/Algorithm/LargestFirst.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | -- | 7 | -- Copyright: © 2018-2024 Intersect MBO 8 | -- License: Apache-2.0 9 | -- 10 | -- This module contains an implementation of the __Largest-First__ coin 11 | -- selection algorithm. 12 | -- 13 | module Cardano.CoinSelection.Algorithm.LargestFirst ( 14 | largestFirst 15 | ) where 16 | 17 | import Prelude 18 | 19 | import Cardano.CoinSelection 20 | ( CoinMap (..) 21 | , CoinMapEntry (..) 22 | , CoinSelection (..) 23 | , CoinSelectionAlgorithm (..) 24 | , CoinSelectionError (..) 25 | , CoinSelectionLimit (..) 26 | , CoinSelectionParameters (..) 27 | , CoinSelectionResult (..) 28 | , InputLimitExceededError (..) 29 | , InputValueInsufficientError (..) 30 | , coinMapFromList 31 | , coinMapToList 32 | , coinMapValue 33 | ) 34 | import Control.Monad.Trans.Except ( ExceptT (..), throwE ) 35 | import Data.Function ( (&) ) 36 | import Data.Ord ( Down (..) ) 37 | import Data.Word ( Word16 ) 38 | 39 | import qualified Data.Foldable as F 40 | import qualified Data.List as L 41 | import qualified Internal.Coin as C 42 | 43 | -- | An implementation of the __Largest-First__ coin selection algorithm. 44 | -- 45 | -- The Largest-First coin selection algorithm considers available inputs in 46 | -- /descending/ order of value, from /largest/ to /smallest/. 47 | -- 48 | -- When applied to a set of requested outputs, the algorithm repeatedly selects 49 | -- entries from the available inputs set until the total value of selected 50 | -- entries is greater than or equal to the total value of requested outputs. 51 | -- 52 | -- === Change Values 53 | -- 54 | -- If the total value of selected inputs is /greater than/ the total value of 55 | -- all requested outputs, the 'change' set of the resulting selection will 56 | -- contain /a single coin/ with the excess value. 57 | -- 58 | -- If the total value of selected inputs is /exactly equal to/ the total value 59 | -- of all requested outputs, the 'change' set of the resulting selection will 60 | -- be /empty/. 61 | -- 62 | -- === Failure Modes 63 | -- 64 | -- The algorithm terminates with an __error__ if: 65 | -- 66 | -- 1. The /total value/ of 'inputsAvailable' (the amount of money 67 | -- /available/) is /less than/ the total value of 'outputsRequested' (the 68 | -- amount of money /required/). 69 | -- 70 | -- See: __'InputValueInsufficientError'__. 71 | -- 72 | -- 2. It is not possible to cover the total value of 'outputsRequested' 73 | -- without selecting a number of inputs from 'inputsAvailable' that 74 | -- would exceed the maximum defined by 'limit'. 75 | -- 76 | -- See: __'InputLimitExceededError'__. 77 | -- 78 | -- @since 1.0.0 79 | largestFirst 80 | :: (Ord i, Monad m) 81 | => CoinSelectionAlgorithm i o m 82 | largestFirst = CoinSelectionAlgorithm payForOutputs 83 | 84 | payForOutputs 85 | :: forall i o m . (Ord i, Monad m) 86 | => CoinSelectionParameters i o 87 | -> ExceptT CoinSelectionError m (CoinSelectionResult i o) 88 | payForOutputs params 89 | | amountAvailable < amountRequired = 90 | throwE 91 | $ InputValueInsufficient 92 | $ InputValueInsufficientError amountAvailable amountRequired 93 | | length inputsSelected > inputCountMax = 94 | throwE 95 | $ InputLimitExceeded 96 | $ InputLimitExceededError 97 | $ fromIntegral inputCountMax 98 | | otherwise = 99 | pure CoinSelectionResult {coinSelection, inputsRemaining} 100 | where 101 | amountAvailable = 102 | coinMapValue $ inputsAvailable params 103 | amountRequired = 104 | coinMapValue $ outputsRequested params 105 | coinSelection = CoinSelection 106 | { inputs = 107 | inputsSelected 108 | , outputs = 109 | outputsRequested params 110 | , change = filter (> C.zero) 111 | $ F.toList 112 | $ coinMapValue inputsSelected `C.sub` amountRequired 113 | } 114 | inputsAvailableDescending :: [CoinMapEntry i] 115 | inputsAvailableDescending = inputsAvailable params 116 | & coinMapToList 117 | & L.sortOn (Down . entryValue) 118 | inputCountMax :: Int 119 | inputCountMax = outputsRequested params 120 | & coinMapToList 121 | & length 122 | & fromIntegral @Int @Word16 123 | & calculateLimit (limit params) 124 | & fromIntegral @Word16 @Int 125 | inputsSelected :: CoinMap i 126 | inputsSelected = inputsAvailableDescending 127 | & fmap entryValue 128 | & scanl1 (<>) 129 | & takeUntil (>= amountRequired) 130 | & zip inputsAvailableDescending 131 | & fmap fst 132 | & coinMapFromList 133 | inputsRemaining :: CoinMap i 134 | inputsRemaining = inputsAvailableDescending 135 | & drop (length inputsSelected) 136 | & coinMapFromList 137 | 138 | -------------------------------------------------------------------------------- 139 | -- Utilities 140 | -------------------------------------------------------------------------------- 141 | 142 | takeUntil :: (a -> Bool) -> [a] -> [a] 143 | takeUntil p = foldr (\x ys -> x : if p x then [] else ys) [] 144 | -------------------------------------------------------------------------------- /src/library/Cardano/CoinSelection/Algorithm/Migration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# OPTIONS_HADDOCK prune #-} 9 | 10 | -- | 11 | -- Copyright: © 2018-2024 Intersect MBO 12 | -- License: Apache-2.0 13 | -- 14 | -- This module contains an algorithm for migrating all funds from one wallet 15 | -- to another. 16 | -- 17 | -- See 'selectCoins'. 18 | -- 19 | module Cardano.CoinSelection.Algorithm.Migration 20 | ( 21 | -- * Coin Selection for Migration 22 | selectCoins 23 | , BatchSize (..) 24 | , idealBatchSize 25 | ) where 26 | 27 | import Prelude 28 | 29 | import Cardano.CoinSelection 30 | ( CoinMap 31 | , CoinMapEntry (..) 32 | , CoinSelection (..) 33 | , CoinSelectionLimit (..) 34 | , coinMapFromList 35 | , coinMapToList 36 | , coinMapValue 37 | , sumChange 38 | , sumInputs 39 | ) 40 | import Cardano.CoinSelection.Fee 41 | ( DustThreshold (..) 42 | , Fee (..) 43 | , FeeBalancingPolicy (..) 44 | , FeeEstimator (..) 45 | , FeeOptions (..) 46 | , isDust 47 | ) 48 | import Control.Monad.Trans.State ( State, evalState, get, put ) 49 | import Data.List.NonEmpty ( NonEmpty ((:|)) ) 50 | import Data.Maybe ( fromMaybe ) 51 | import Data.Word ( Word16 ) 52 | import GHC.Generics ( Generic ) 53 | import Internal.Coin ( Coin, coinFromIntegral, coinToIntegral ) 54 | 55 | import qualified Internal.Coin as C 56 | 57 | -------------------------------------------------------------------------------- 58 | -- Coin Selection for Migration 59 | -------------------------------------------------------------------------------- 60 | 61 | -- | Creates a __series__ of coin selections that, when published as 62 | -- transactions, will have the effect of migrating all funds from one 63 | -- wallet to another. 64 | -- 65 | -- Since UTxO-based blockchains typically impose limits on the sizes of 66 | -- individual transactions, and since individual UTxO sets can contain 67 | -- /arbitrarily/ many entries, migrating all funds from one wallet to another 68 | -- may require the creation of /several/ transactions. 69 | -- 70 | -- This function therefore /partitions/ the given set of inputs into multiple 71 | -- /batches/ of up to __/b/__ inputs, where __/b/__ is specified by the given 72 | -- 'BatchSize' parameter. (See 'idealBatchSize' for an automatic way to 73 | -- calculate a suitable batch size.) 74 | -- 75 | -- For each batch of inputs, this function creates a separate 'CoinSelection' 76 | -- with the given 'inputs' /and/ a generated 'change' set, where the 'change' 77 | -- set represents the value to be transferred to the target wallet, carefully 78 | -- adjusted to deduct a fee in accordance with the given 'FeeOptions' 79 | -- parameter. The set of 'outputs' for each coin selection is /purposefully/ 80 | -- left empty, as /all/ value is captured in the 'change' set. 81 | -- 82 | -- @since 1.0.0 83 | selectCoins 84 | :: forall i o . (Ord i, Ord o) 85 | => FeeOptions i o 86 | -- ^ The fee options. 87 | -> BatchSize 88 | -- ^ The maximum number of inputs to include in each selection. 89 | -> CoinMap i 90 | -- ^ The UTxO set to migrate. 91 | -> [CoinSelection i o] 92 | selectCoins options (BatchSize batchSize) utxo = 93 | evalState migrate (coinMapToList utxo) 94 | where 95 | FeeOptions {dustThreshold, feeEstimator, feeBalancingPolicy} = options 96 | 97 | migrate :: State [CoinMapEntry i] [CoinSelection i o] 98 | migrate = do 99 | batch <- getNextBatch 100 | if null batch then 101 | pure [] 102 | else case adjustForFee (mkCoinSelection batch) of 103 | Nothing -> pure [] 104 | Just coinSel -> do 105 | rest <- migrate 106 | pure (coinSel:rest) 107 | 108 | -- Construct a provisional 'CoinSelection' from the given selected inputs. 109 | -- Note that the selection may look a bit weird at first sight as it has 110 | -- no outputs (we are paying everything to ourselves!). 111 | mkCoinSelection :: [CoinMapEntry i] -> CoinSelection i o 112 | mkCoinSelection inputEntries = CoinSelection {inputs, outputs, change} 113 | where 114 | inputs = coinMapFromList inputEntries 115 | outputs = mempty 116 | change 117 | | null nonDustInputCoins && totalInputValue >= smallestNonDustCoin = 118 | [smallestNonDustCoin] 119 | | otherwise = 120 | nonDustInputCoins 121 | nonDustInputCoins = filter 122 | (not . isDust dustThreshold) 123 | (entryValue <$> inputEntries) 124 | smallestNonDustCoin = C.succ $ unDustThreshold dustThreshold 125 | totalInputValue = coinMapValue inputs 126 | 127 | -- | Attempt to balance the coin selection by reducing or increasing the 128 | -- change values based on the computed fees. 129 | adjustForFee :: CoinSelection i o -> Maybe (CoinSelection i o) 130 | adjustForFee !coinSel = case change coinSel of 131 | -- If there's no change, nothing to adjust 132 | [] -> Nothing 133 | 134 | -- No difference between required and computed, we're done 135 | (_ : _) | diff == 0 -> Just coinSel 136 | 137 | -- Otherwise, we have 2 cases: 138 | -- 139 | -- 1/ diff < 0 140 | -- We aren't giving enough as fee, so we need to reduce one output. 141 | -- 142 | -- 2/ diff > 0 143 | -- We have some surplus so we add it to an arbitrary output 144 | -- 145 | -- If both cases we can simply modify one output by adding `diff`, the 146 | -- sign of `diff` making for the right modification. 147 | -- We then recursively call ourselves for this might reduce the number 148 | -- of outputs and change the fee. 149 | (c : cs) -> do 150 | let coinSel' = coinSel 151 | { change = modifyFirst (c :| cs) (applyDiff diff) } 152 | let costOfSurplus 153 | = fromIntegral 154 | $ C.coinToNatural 155 | $ C.distance 156 | (unFee $ estimateFee feeEstimator coinSel') 157 | (unFee $ estimateFee feeEstimator coinSel ) 158 | if 159 | -- Adding the change costs less than not having it, so it's 160 | -- worth trying. 161 | | costOfSurplus < actualFee -> 162 | adjustForFee coinSel' 163 | 164 | -- Adding the change costs more than not having it, If we don't 165 | -- require strict balancing, we can leave the selection as-is. 166 | | feeBalancingPolicy == RequireMinimalFee -> 167 | pure coinSel 168 | 169 | -- Adding the change costs more than not having it. So, 170 | -- depending on our balancing policy, we may stop the balancing 171 | -- right here, or, if we must balance the selection discard the 172 | -- whole selection: it can't be balanced with this algorithm. 173 | -- 174 | -- Note that this last extreme case is reached when using an 175 | -- unstable fee policy (where values of outputs can influence 176 | -- the policy) AND, require transactions to be 100% balanced. 177 | -- This is a silly thing to do. 178 | | otherwise -> 179 | Nothing 180 | where 181 | applyDiff :: Integer -> Coin -> Coin 182 | applyDiff i c 183 | = fromMaybe C.zero 184 | $ coinFromIntegral (i + coinToIntegral c) 185 | 186 | diff :: Integer 187 | diff = actualFee - requiredFee 188 | where 189 | requiredFee 190 | = coinToIntegral $ unFee 191 | $ estimateFee feeEstimator coinSel 192 | 193 | actualFee :: Integer 194 | actualFee 195 | = coinToIntegral (sumInputs coinSel) 196 | - coinToIntegral (sumChange coinSel) 197 | 198 | -- | Apply the given function to the first coin of the list. If the 199 | -- operation makes the 'Coin' smaller than the dust threshold, the coin is 200 | -- discarded. 201 | modifyFirst :: NonEmpty Coin -> (Coin -> Coin) -> [Coin] 202 | modifyFirst (c :| cs) op 203 | | c' <= threshold = cs 204 | | otherwise = c' : cs 205 | where 206 | c' = op c 207 | threshold = unDustThreshold dustThreshold 208 | 209 | getNextBatch :: State [a] [a] 210 | getNextBatch = do 211 | xs <- get 212 | let (batch, rest) = splitAt (fromIntegral batchSize) xs 213 | put rest 214 | pure batch 215 | 216 | -- | An upper limit for the number of 'inputs' to include in each coin selection 217 | -- generated by 'selectCoins'. 218 | -- 219 | -- @since 1.0.0 220 | newtype BatchSize = BatchSize Word16 221 | deriving (Eq, Generic, Ord, Show) 222 | 223 | -- | Calculate an ideal batch size based on the given coin selection limit. 224 | -- 225 | -- @since 1.0.0 226 | idealBatchSize :: CoinSelectionLimit -> BatchSize 227 | idealBatchSize coinselOpts = BatchSize $ fixPoint 1 228 | where 229 | fixPoint :: Word16 -> Word16 230 | fixPoint !n 231 | | maxN n <= n = n 232 | | n == maxBound = n 233 | | otherwise = fixPoint (n + 1) 234 | where 235 | maxN :: Word16 -> Word16 236 | maxN = calculateLimit coinselOpts 237 | -------------------------------------------------------------------------------- /src/library/Cardano/CoinSelection/Algorithm/RandomImprove.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | -- | 6 | -- Copyright: © 2018-2024 Intersect MBO 7 | -- License: Apache-2.0 8 | -- 9 | -- This module contains an implementation of the __Random-Improve__ coin 10 | -- selection algorithm. 11 | -- 12 | module Cardano.CoinSelection.Algorithm.RandomImprove 13 | ( randomImprove 14 | ) where 15 | 16 | import Prelude 17 | 18 | import Cardano.CoinSelection 19 | ( CoinMap (..) 20 | , CoinMapEntry (..) 21 | , CoinSelection (..) 22 | , CoinSelectionAlgorithm (..) 23 | , CoinSelectionError (..) 24 | , CoinSelectionLimit (..) 25 | , CoinSelectionParameters (..) 26 | , CoinSelectionResult (..) 27 | , InputCountInsufficientError (..) 28 | , InputLimitExceededError (..) 29 | , InputValueInsufficientError (..) 30 | , InputsExhaustedError (..) 31 | , coinMapFromList 32 | , coinMapRandomEntry 33 | , coinMapToList 34 | , coinMapValue 35 | ) 36 | import Control.Monad ( foldM ) 37 | import Control.Monad.Trans.Class ( lift ) 38 | import Control.Monad.Trans.Except ( ExceptT (..), throwE ) 39 | import Control.Monad.Trans.Maybe ( MaybeT (..), runMaybeT ) 40 | import Crypto.Random.Types ( MonadRandom ) 41 | import Data.Ord ( Down (..) ) 42 | import Internal.Coin ( Coin ) 43 | 44 | import qualified Data.List as L 45 | import qualified Internal.Coin as C 46 | 47 | -- | An implementation of the __Random-Improve__ coin selection algorithm. 48 | -- 49 | -- = Overview 50 | -- 51 | -- The __Random-Improve__ coin selection algorithm works in __two phases__, by 52 | -- /first/ selecting UTxO entries /at random/ to pay for each of the given 53 | -- outputs, and /then/ attempting to /improve/ upon each of the selections. 54 | -- 55 | -- === Phase 1: Random Selection 56 | -- 57 | -- __In this phase, the algorithm randomly selects a minimal set of UTxO__ 58 | -- __entries to pay for each of the given outputs.__ 59 | -- 60 | -- During this phase, the algorithm: 61 | -- 62 | -- * processes outputs in /descending order of coin value/. 63 | -- 64 | -- * maintains a /remaining UTxO set/, initially equal to the given 65 | -- /UTxO set/ parameter. 66 | -- 67 | -- For each output of value __/v/__, the algorithm /randomly/ selects entries 68 | -- from the /remaining UTxO set/, until the total value of selected entries is 69 | -- greater than or equal to __/v/__. The selected entries are then associated 70 | -- with that output, and removed from the /remaining UTxO set/. 71 | -- 72 | -- This phase ends when every output has been associated with a selection of 73 | -- UTxO entries. 74 | -- 75 | -- However, if the remaining UTxO set is completely exhausted before all 76 | -- outputs can be processed, the algorithm terminates with an error. 77 | -- 78 | -- === Phase 2: Improvement 79 | -- 80 | -- __In this phase, the algorithm attempts to improve upon each of the UTxO__ 81 | -- __selections made in the previous phase, by conservatively expanding the__ 82 | -- __selection made for each output.__ 83 | -- 84 | -- During this phase, the algorithm: 85 | -- 86 | -- * processes outputs in /ascending order of coin value/. 87 | -- 88 | -- * continues to maintain the /remaining UTxO set/ produced by the previous 89 | -- phase. 90 | -- 91 | -- * maintains an /accumulated coin selection/, which is initially /empty/. 92 | -- 93 | -- For each output of value __/v/__, the algorithm: 94 | -- 95 | -- 1. __Calculates a /target range/__ for the total value of inputs used to 96 | -- pay for that output, defined by the triplet: 97 | -- 98 | -- (/minimum/, /ideal/, /maximum/) = (/v/, /2v/, /3v/) 99 | -- 100 | -- 2. __Attempts to /improve/ upon the /existing UTxO selection/__ for that 101 | -- output, by repeatedly selecting additional entries at random from the 102 | -- /remaining UTxO set/, stopping when the selection can be improved upon 103 | -- no further. 104 | -- 105 | -- A selection with value /v1/ is considered to be an /improvement/ over a 106 | -- selection with value /v0/ if __all__ of the following conditions are 107 | -- satisfied: 108 | -- 109 | -- * __Condition 1__: we have moved closer to the /ideal/ value: 110 | -- 111 | -- abs (/ideal/ − /v1/) < abs (/ideal/ − /v0/) 112 | -- 113 | -- * __Condition 2__: we have not exceeded the /maximum/ value: 114 | -- 115 | -- /v1/ ≤ /maximum/ 116 | -- 117 | -- * __Condition 3__: when counting cumulatively across all outputs 118 | -- considered so far, we have not selected more than the /maximum/ number 119 | -- of UTxO entries specified by 'limit'. 120 | -- 121 | -- 3. __Creates a /change value/__ for the output, equal to the total value 122 | -- of the /final UTxO selection/ for that output minus the value /v/ of 123 | -- that output. 124 | -- 125 | -- 4. __Updates the /accumulated coin selection/__: 126 | -- 127 | -- * Adds the /output/ to 'outputs'. 128 | -- * Adds the /improved UTxO selection/ to 'inputs'. 129 | -- * Adds the /change value/ to 'change'. 130 | -- 131 | -- This phase ends when every output has been processed, __or__ when the 132 | -- /remaining UTxO set/ has been exhausted, whichever occurs sooner. 133 | -- 134 | -- = Termination 135 | -- 136 | -- When both phases are complete, the algorithm terminates. 137 | -- 138 | -- The /accumulated coin selection/ and /remaining UTxO set/ are returned to 139 | -- the caller. 140 | -- 141 | -- === Failure Modes 142 | -- 143 | -- The algorithm terminates with an __error__ if: 144 | -- 145 | -- 1. The /total value/ of the initial UTxO set (the amount of money 146 | -- /available/) is /less than/ the total value of the output list (the 147 | -- amount of money /required/). 148 | -- 149 | -- See: __'InputValueInsufficientError'__. 150 | -- 151 | -- 2. The /number/ of entries in the initial UTxO set is /smaller than/ the 152 | -- number of requested outputs. 153 | -- 154 | -- Due to the nature of the algorithm, /at least one/ UTxO entry is 155 | -- required /for each/ output. 156 | -- 157 | -- See: __'InputCountInsufficientError'__. 158 | -- 159 | -- 3. Due to the particular /distribution/ of values within the initial UTxO 160 | -- set, the algorithm depletes all entries from the UTxO set /before/ it 161 | -- is able to pay for all requested outputs. 162 | -- 163 | -- See: __'InputsExhaustedError'__. 164 | -- 165 | -- 4. The /number/ of UTxO entries needed to pay for the requested outputs 166 | -- would /exceed/ the upper limit specified by 'limit'. 167 | -- 168 | -- See: __'InputLimitExceededError'__. 169 | -- 170 | -- = Motivating Principles 171 | -- 172 | -- There are several motivating principles behind the design of the algorithm. 173 | -- 174 | -- === Principle 1: Dust Management 175 | -- 176 | -- The probability that random selection will choose dust entries from a UTxO 177 | -- set increases with the proportion of dust in the set. 178 | -- 179 | -- Therefore, for a UTxO set with a large amount of dust, there's a high 180 | -- probability that a random subset will include a large amount of dust. 181 | -- 182 | -- === Principle 2: Change Management 183 | -- 184 | -- Ideally, coin selection algorithms should, over time, create a UTxO set that 185 | -- has /useful/ outputs: outputs that will allow us to process future payments 186 | -- with a minimum number of inputs. 187 | -- 188 | -- If for each payment request of value __/v/__ we create a change output of 189 | -- /roughly/ the same value __/v/__, then we will end up with a distribution of 190 | -- change values that matches the typical value distribution of payment 191 | -- requests. 192 | -- 193 | -- === Principle 3: Performance Management 194 | -- 195 | -- Searching the UTxO set for additional entries to improve our change outputs 196 | -- is /only/ useful if the UTxO set contains entries that are sufficiently 197 | -- small enough. But it is precisely when the UTxO set contains many small 198 | -- entries that it is less likely for a randomly-chosen UTxO entry to push the 199 | -- total above the upper bound. 200 | -- 201 | -- @since 1.0.0 202 | randomImprove 203 | :: (Ord i, Ord o, MonadRandom m) 204 | => CoinSelectionAlgorithm i o m 205 | randomImprove = CoinSelectionAlgorithm payForOutputs 206 | 207 | payForOutputs 208 | :: (Ord i, Ord o, MonadRandom m) 209 | => CoinSelectionParameters i o 210 | -> ExceptT CoinSelectionError m (CoinSelectionResult i o) 211 | payForOutputs params = do 212 | mRandomSelections <- lift $ runMaybeT $ foldM makeRandomSelection 213 | (inputCountMax, inputsAvailable params, []) outputsDescending 214 | case mRandomSelections of 215 | Just (inputCountRemaining, utxoRemaining, randomSelections) -> do 216 | (_, finalSelection, utxoRemaining') <- lift $ foldM 217 | improveSelection 218 | (inputCountRemaining, mempty, utxoRemaining) 219 | (reverse randomSelections) 220 | pure $ CoinSelectionResult finalSelection utxoRemaining' 221 | Nothing -> 222 | throwE errorCondition 223 | where 224 | errorCondition 225 | | amountAvailable < amountRequested = 226 | InputValueInsufficient $ 227 | InputValueInsufficientError 228 | amountAvailable amountRequested 229 | | utxoCount < outputCount = 230 | InputCountInsufficient $ 231 | InputCountInsufficientError 232 | utxoCount outputCount 233 | | utxoCount <= fromIntegral inputCountMax = 234 | InputsExhausted 235 | InputsExhaustedError 236 | | otherwise = 237 | InputLimitExceeded $ 238 | InputLimitExceededError $ 239 | fromIntegral inputCountMax 240 | amountAvailable = 241 | coinMapValue $ inputsAvailable params 242 | amountRequested = 243 | coinMapValue $ outputsRequested params 244 | inputCountMax = 245 | fromIntegral $ calculateLimit (limit params) $ fromIntegral outputCount 246 | outputCount = 247 | fromIntegral $ length $ coinMapToList $ outputsRequested params 248 | outputsDescending = 249 | L.sortOn (Down . entryValue) $ coinMapToList $ outputsRequested params 250 | utxoCount = 251 | fromIntegral $ L.length $ coinMapToList $ inputsAvailable params 252 | 253 | -- | Randomly select entries from the given UTxO set, until the total value of 254 | -- selected entries is greater than or equal to the given output value. 255 | -- 256 | -- Once a random selection has been made that meets the above criterion, this 257 | -- function returns that selection as is, making no attempt to improve upon 258 | -- the selection in any way. 259 | -- 260 | makeRandomSelection 261 | :: forall i o m . MonadRandom m 262 | => (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]) 263 | -> CoinMapEntry o 264 | -> MaybeT m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]) 265 | makeRandomSelection 266 | (inputCountRemaining, utxoRemaining, existingSelections) txout = do 267 | (utxoSelected, utxoRemaining') <- coverRandomly ([], utxoRemaining) 268 | return 269 | ( inputCountRemaining - fromIntegral (L.length utxoSelected) 270 | , utxoRemaining' 271 | , (utxoSelected, txout) : existingSelections 272 | ) 273 | where 274 | coverRandomly 275 | :: ([CoinMapEntry i], CoinMap i) 276 | -> MaybeT m ([CoinMapEntry i], CoinMap i) 277 | coverRandomly (selected, remaining) 278 | | L.length selected > fromIntegral inputCountRemaining = 279 | MaybeT $ return Nothing 280 | | sumEntries selected >= targetMin (mkTargetRange txout) = 281 | MaybeT $ return $ Just (selected, remaining) 282 | | otherwise = 283 | MaybeT (coinMapRandomEntry remaining) >>= \(picked, remaining') -> 284 | coverRandomly (picked : selected, remaining') 285 | 286 | -- | Perform an improvement to random selection on a given output. 287 | improveSelection 288 | :: forall i o m . (MonadRandom m, Ord i, Ord o) 289 | => (Integer, CoinSelection i o, CoinMap i) 290 | -> ([CoinMapEntry i], CoinMapEntry o) 291 | -> m (Integer, CoinSelection i o, CoinMap i) 292 | improveSelection (maxN0, selection, utxo0) (inps0, txout) = do 293 | (maxN, inps, utxo) <- improve (maxN0, inps0, utxo0) 294 | return 295 | ( maxN 296 | , selection <> CoinSelection 297 | { inputs = coinMapFromList inps 298 | , outputs = coinMapFromList [txout] 299 | , change = mkChange txout inps 300 | } 301 | , utxo 302 | ) 303 | where 304 | target = mkTargetRange txout 305 | 306 | improve 307 | :: (Integer, [CoinMapEntry i], CoinMap i) 308 | -> m (Integer, [CoinMapEntry i], CoinMap i) 309 | improve (maxN, inps, utxo) 310 | | maxN >= 1 && sumEntries inps < targetAim target = do 311 | coinMapRandomEntry utxo >>= \case 312 | Nothing -> 313 | return (maxN, inps, utxo) 314 | Just (io, utxo') | isImprovement io inps -> do 315 | let inps' = io : inps 316 | let maxN' = maxN - 1 317 | improve (maxN', inps', utxo') 318 | Just _ -> 319 | return (maxN, inps, utxo) 320 | | otherwise = 321 | return (maxN, inps, utxo) 322 | 323 | isImprovement :: CoinMapEntry i -> [CoinMapEntry i] -> Bool 324 | isImprovement io selected = 325 | let 326 | condA = -- (a) It doesn’t exceed a specified upper limit. 327 | sumEntries (io : selected) < targetMax target 328 | 329 | condB = -- (b) Addition gets us closer to the ideal change 330 | distanceA < distanceB 331 | where 332 | distanceA = C.distance 333 | (targetAim target) 334 | (sumEntries (io : selected)) 335 | distanceB = C.distance 336 | (targetAim target) 337 | (sumEntries selected) 338 | 339 | -- (c) Doesn't exceed maximum number of inputs 340 | -- Guaranteed by the precondition on 'improve'. 341 | in 342 | condA && condB 343 | 344 | -------------------------------------------------------------------------------- 345 | -- Internals 346 | -------------------------------------------------------------------------------- 347 | 348 | -- | Represents a target range of /total input values/ for a given output. 349 | -- 350 | -- In this context, /total input value/ refers to the total value of a set of 351 | -- inputs selected to pay for a given output. 352 | -- 353 | data TargetRange = TargetRange 354 | { targetMin :: Coin 355 | -- ^ The minimum value, corresponding to exactly the requested target 356 | -- amount, and a change amount of zero. 357 | , targetAim :: Coin 358 | -- ^ The ideal value, corresponding to exactly twice the requested 359 | -- target amount, and a change amount equal to the requested amount. 360 | , targetMax :: Coin 361 | -- ^ The maximum value, corresponding to exactly three times the 362 | -- requested amount, and a change amount equal to twice the requested 363 | -- amount. 364 | } 365 | 366 | -- | Compute the target range of /total input values/ for a given output. 367 | -- 368 | -- See 'TargetRange'. 369 | -- 370 | mkTargetRange :: CoinMapEntry o -> TargetRange 371 | mkTargetRange (CoinMapEntry _ c) = TargetRange 372 | { targetMin = c 373 | , targetAim = c `C.add` c 374 | , targetMax = c `C.add` c `C.add` c 375 | } 376 | 377 | -- | Compute change outputs from a target output and a selection of inputs. 378 | -- 379 | -- Pre-condition: 380 | -- 381 | -- The output must be less than (or equal to) the sum of the inputs. 382 | -- 383 | mkChange :: CoinMapEntry o -> [CoinMapEntry i] -> [Coin] 384 | mkChange (CoinMapEntry _ out) inps = 385 | case difference of 386 | Nothing -> 387 | error $ mconcat 388 | [ "mkChange: " 389 | , "output must be less than or equal to sum of inputs" 390 | ] 391 | Just d | C.isZero d -> 392 | [] 393 | Just d -> 394 | [d] 395 | where 396 | difference = sumEntries inps `C.sub` out 397 | 398 | -------------------------------------------------------------------------------- 399 | -- Utilities 400 | -------------------------------------------------------------------------------- 401 | 402 | sumEntries :: [CoinMapEntry i] -> Coin 403 | sumEntries = mconcat . fmap entryValue 404 | -------------------------------------------------------------------------------- /src/test/Cardano/CoinSelection/Algorithm/LargestFirstSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns #-} 7 | 8 | module Cardano.CoinSelection.Algorithm.LargestFirstSpec ( 9 | isValidLargestFirstError, 10 | spec, 11 | ) where 12 | 13 | import Prelude 14 | 15 | import Cardano.CoinSelection 16 | ( CoinMap (..) 17 | , CoinMapEntry (..) 18 | , CoinSelection (..) 19 | , CoinSelectionAlgorithm (..) 20 | , CoinSelectionError (..) 21 | , CoinSelectionLimit (..) 22 | , CoinSelectionParameters (..) 23 | , CoinSelectionResult (..) 24 | , InputLimitExceededError (..) 25 | , InputValueInsufficientError (..) 26 | , coinMapFromList 27 | , coinMapToList 28 | , coinMapValue 29 | ) 30 | import Cardano.CoinSelection.Algorithm.LargestFirst ( largestFirst ) 31 | import Cardano.CoinSelectionSpec 32 | ( CoinSelectionData (..) 33 | , CoinSelectionFixture (..) 34 | , CoinSelectionTestResult (..) 35 | , coinSelectionAlgorithmGeneralProperties 36 | , coinSelectionUnitTest 37 | ) 38 | import Cardano.Test.Utilities ( InputId, OutputId, excluding, unsafeCoin ) 39 | import Control.Monad ( unless ) 40 | import Control.Monad.Trans.Except ( runExceptT ) 41 | import Data.Either ( isRight ) 42 | import Data.Function ( (&) ) 43 | import Data.Functor.Identity ( Identity (runIdentity) ) 44 | import Test.Hspec ( Spec, describe, it, shouldBe, shouldSatisfy ) 45 | import Test.QuickCheck 46 | ( Property, checkCoverage, cover, property, withMaxSuccess, (.&&.), (==>) ) 47 | 48 | import qualified Data.List as L 49 | import qualified Data.Map.Strict as Map 50 | import qualified Data.Set as Set 51 | import qualified Internal.Coin as C 52 | 53 | spec :: Spec 54 | spec = do 55 | describe "Coin selection: largest-first algorithm: unit tests" $ do 56 | coinSelectionUnitTest 57 | largestFirst 58 | "Expect success: case #1" 59 | ( Right $ 60 | CoinSelectionTestResult 61 | { rsInputs = [17] 62 | , rsChange = [] 63 | , rsOutputs = [17] 64 | } 65 | ) 66 | ( CoinSelectionFixture 67 | { maxNumOfInputs = 100 68 | , utxoInputs = [10, 10, 17] 69 | , txOutputs = [17] 70 | } 71 | ) 72 | 73 | coinSelectionUnitTest 74 | largestFirst 75 | "Expect success: case #2" 76 | ( Right $ 77 | CoinSelectionTestResult 78 | { rsInputs = [17] 79 | , rsChange = [16] 80 | , rsOutputs = [1] 81 | } 82 | ) 83 | ( CoinSelectionFixture 84 | { maxNumOfInputs = 100 85 | , utxoInputs = [12, 10, 17] 86 | , txOutputs = [1] 87 | } 88 | ) 89 | 90 | coinSelectionUnitTest 91 | largestFirst 92 | "Expect success: case #3" 93 | ( Right $ 94 | CoinSelectionTestResult 95 | { rsInputs = [12, 17] 96 | , rsChange = [11] 97 | , rsOutputs = [18] 98 | } 99 | ) 100 | ( CoinSelectionFixture 101 | { maxNumOfInputs = 100 102 | , utxoInputs = [12, 10, 17] 103 | , txOutputs = [18] 104 | } 105 | ) 106 | 107 | coinSelectionUnitTest 108 | largestFirst 109 | "Expect success: case #4" 110 | ( Right $ 111 | CoinSelectionTestResult 112 | { rsInputs = [10, 12, 17] 113 | , rsChange = [9] 114 | , rsOutputs = [30] 115 | } 116 | ) 117 | ( CoinSelectionFixture 118 | { maxNumOfInputs = 100 119 | , utxoInputs = [12, 10, 17] 120 | , txOutputs = [30] 121 | } 122 | ) 123 | 124 | coinSelectionUnitTest 125 | largestFirst 126 | "Expect success: case #5" 127 | ( Right $ 128 | CoinSelectionTestResult 129 | { rsInputs = [6, 10] 130 | , rsChange = [4] 131 | , rsOutputs = [11, 1] 132 | } 133 | ) 134 | ( CoinSelectionFixture 135 | { maxNumOfInputs = 3 136 | , utxoInputs = [1, 2, 10, 6, 5] 137 | , txOutputs = [11, 1] 138 | } 139 | ) 140 | 141 | coinSelectionUnitTest 142 | largestFirst 143 | "Expect success: case #6" 144 | ( Right $ 145 | CoinSelectionTestResult 146 | { rsInputs = [12, 17, 20] 147 | , rsChange = [6] 148 | , rsOutputs = [1, 1, 1, 40] 149 | } 150 | ) 151 | ( CoinSelectionFixture 152 | { maxNumOfInputs = 100 153 | , utxoInputs = [12, 20, 17] 154 | , txOutputs = [40, 1, 1, 1] 155 | } 156 | ) 157 | 158 | coinSelectionUnitTest 159 | largestFirst 160 | "Expect success: case #7" 161 | ( Right $ 162 | CoinSelectionTestResult 163 | { rsInputs = [12, 17, 20] 164 | , rsChange = [8] 165 | , rsOutputs = [1, 40] 166 | } 167 | ) 168 | ( CoinSelectionFixture 169 | { maxNumOfInputs = 100 170 | , utxoInputs = [12, 20, 17] 171 | , txOutputs = [40, 1] 172 | } 173 | ) 174 | 175 | coinSelectionUnitTest 176 | largestFirst 177 | "Expect success: case #8" 178 | ( Right $ 179 | CoinSelectionTestResult 180 | { rsInputs = [10, 20, 20] 181 | , rsChange = [3] 182 | , rsOutputs = [6, 41] 183 | } 184 | ) 185 | ( CoinSelectionFixture 186 | { maxNumOfInputs = 100 187 | , utxoInputs = [20, 20, 10, 5] 188 | , txOutputs = [41, 6] 189 | } 190 | ) 191 | 192 | coinSelectionUnitTest 193 | largestFirst 194 | "Expect success: case #9" 195 | ( Right $ 196 | CoinSelectionTestResult 197 | { rsInputs = [6, 10] 198 | , rsChange = [4] 199 | , rsOutputs = [1, 11] 200 | } 201 | ) 202 | ( CoinSelectionFixture 203 | { maxNumOfInputs = 2 204 | , utxoInputs = [1, 2, 10, 6, 5] 205 | , txOutputs = [11, 1] 206 | } 207 | ) 208 | 209 | coinSelectionUnitTest 210 | largestFirst 211 | "Expect success: fewer inputs than outputs: case #1" 212 | ( Right $ 213 | CoinSelectionTestResult 214 | { rsInputs = [100] 215 | , rsOutputs = [1, 2, 3, 4] 216 | , rsChange = [90] 217 | } 218 | ) 219 | ( CoinSelectionFixture 220 | { maxNumOfInputs = 1000 221 | , utxoInputs = [100, 100] 222 | , txOutputs = [1, 2, 3, 4] 223 | } 224 | ) 225 | 226 | coinSelectionUnitTest 227 | largestFirst 228 | "Expect success: fewer inputs than outputs: case #2" 229 | ( Right $ 230 | CoinSelectionTestResult 231 | { rsInputs = [100] 232 | , rsOutputs = [1, 2, 3, 4] 233 | , rsChange = [90] 234 | } 235 | ) 236 | ( CoinSelectionFixture 237 | { maxNumOfInputs = 1000 238 | , utxoInputs = [100, 10] 239 | , txOutputs = [1, 2, 3, 4] 240 | } 241 | ) 242 | 243 | coinSelectionUnitTest 244 | largestFirst 245 | "Expect success: fewer inputs than outputs: case #3" 246 | ( Right $ 247 | CoinSelectionTestResult 248 | { rsInputs = [10] 249 | , rsOutputs = [1, 2, 3, 4] 250 | , rsChange = [] 251 | } 252 | ) 253 | ( CoinSelectionFixture 254 | { maxNumOfInputs = 1000 255 | , utxoInputs = [10, 10] 256 | , txOutputs = [1, 2, 3, 4] 257 | } 258 | ) 259 | 260 | coinSelectionUnitTest 261 | largestFirst 262 | "Expect success: fewer inputs than outputs: case #4" 263 | ( Right $ 264 | CoinSelectionTestResult 265 | { rsInputs = [100] 266 | , rsOutputs = replicate 100 1 267 | , rsChange = [] 268 | } 269 | ) 270 | ( CoinSelectionFixture 271 | { maxNumOfInputs = 1 272 | , utxoInputs = [100] 273 | , txOutputs = replicate 100 1 274 | } 275 | ) 276 | 277 | coinSelectionUnitTest 278 | largestFirst 279 | "UTxO balance not sufficient: case #1" 280 | ( Left $ 281 | InputValueInsufficient $ 282 | InputValueInsufficientError 283 | (unsafeCoin @Int 39) 284 | (unsafeCoin @Int 40) 285 | ) 286 | ( CoinSelectionFixture 287 | { maxNumOfInputs = 100 288 | , utxoInputs = [12, 10, 17] 289 | , txOutputs = [40] 290 | } 291 | ) 292 | 293 | coinSelectionUnitTest 294 | largestFirst 295 | "UTxO balance not sufficient: case #2" 296 | ( Left $ 297 | InputValueInsufficient $ 298 | InputValueInsufficientError 299 | (unsafeCoin @Int 39) 300 | (unsafeCoin @Int 43) 301 | ) 302 | ( CoinSelectionFixture 303 | { maxNumOfInputs = 100 304 | , utxoInputs = [12, 10, 17] 305 | , txOutputs = [40, 1, 1, 1] 306 | } 307 | ) 308 | 309 | coinSelectionUnitTest 310 | largestFirst 311 | "UTxO balance sufficient, but maximum input count exceeded" 312 | (Left $ InputLimitExceeded $ InputLimitExceededError 9) 313 | ( CoinSelectionFixture 314 | { maxNumOfInputs = 9 315 | , utxoInputs = replicate 100 1 316 | , txOutputs = replicate 100 1 317 | } 318 | ) 319 | 320 | describe "Coin selection: largest-first algorithm: properties" $ do 321 | it 322 | "forall (UTxO, NonEmpty TxOut), for all selected input, there's no \ 323 | \bigger input in the UTxO that is not already in the selected \ 324 | \inputs" 325 | (property $ propInputDecreasingOrder @InputId @OutputId) 326 | 327 | it 328 | "The algorithm selects just enough inputs and no more." 329 | ( property $ 330 | withMaxSuccess 10_000 $ 331 | propSelectionMinimal @InputId @OutputId 332 | ) 333 | 334 | it 335 | "The algorithm produces the correct set of change." 336 | ( checkCoverage $ 337 | property $ 338 | withMaxSuccess 10_000 $ 339 | propChangeCorrect @InputId @OutputId 340 | ) 341 | 342 | coinSelectionAlgorithmGeneralProperties @InputId @OutputId 343 | largestFirst 344 | "Largest-First" 345 | 346 | -------------------------------------------------------------------------------- 347 | -- Properties 348 | -------------------------------------------------------------------------------- 349 | 350 | propInputDecreasingOrder :: 351 | (Ord i) => 352 | CoinSelectionData i o -> 353 | Property 354 | propInputDecreasingOrder (CoinSelectionData utxo txOuts) = 355 | isRight selection 356 | ==> let Right (CoinSelectionResult s _) = selection 357 | in prop s 358 | where 359 | prop (CoinSelection inps _ _) = 360 | let 361 | utxo' = 362 | (Map.toList . unCoinMap) $ 363 | utxo 364 | `excluding` Set.fromList (entryKey <$> coinMapToList inps) 365 | in 366 | unless (L.null utxo') $ 367 | (L.minimum (entryValue <$> coinMapToList inps)) 368 | `shouldSatisfy` (>= (L.maximum (snd <$> utxo'))) 369 | selection = 370 | runIdentity $ 371 | runExceptT $ 372 | selectCoins largestFirst $ 373 | CoinSelectionParameters utxo txOuts selectionLimit 374 | selectionLimit = CoinSelectionLimit $ const 100 375 | 376 | -- Confirm that a selection is minimal by removing the smallest entry from the 377 | -- inputs and verifying that the reduced input total is no longer enough to pay 378 | -- for the total value of all outputs. 379 | propSelectionMinimal :: 380 | (Ord i) => CoinSelectionData i o -> Property 381 | propSelectionMinimal (CoinSelectionData inpsAvailable outsRequested) = 382 | isRight result 383 | ==> let Right (CoinSelectionResult selection _) = result 384 | in prop selection 385 | where 386 | prop (CoinSelection inputsSelected _ _) = 387 | ( coinMapValue inputsSelected 388 | `shouldSatisfy` (>= coinMapValue outsRequested) 389 | ) 390 | .&&. ( coinMapValue inputsReduced 391 | `shouldSatisfy` (< coinMapValue outsRequested) 392 | ) 393 | where 394 | -- The set of selected inputs with the smallest entry removed. 395 | inputsReduced = 396 | inputsSelected 397 | & coinMapToList 398 | & L.sortOn entryValue 399 | & L.drop 1 400 | & coinMapFromList 401 | result = 402 | runIdentity $ 403 | runExceptT $ 404 | selectCoins largestFirst $ 405 | CoinSelectionParameters inpsAvailable outsRequested $ 406 | CoinSelectionLimit $ 407 | const 1000 408 | 409 | -- Verify that the algorithm generates the correct set of change. 410 | propChangeCorrect :: 411 | (Ord i) => CoinSelectionData i o -> Property 412 | propChangeCorrect (CoinSelectionData inpsAvailable outsRequested) = 413 | isRight result 414 | ==> let Right (CoinSelectionResult selection _) = result 415 | in prop selection 416 | where 417 | prop (CoinSelection inpsSelected _ changeGenerated) = 418 | cover 419 | 8 420 | (amountSelected > amountRequired) 421 | "amountSelected > amountRequired" 422 | $ cover 423 | 1 424 | (amountSelected == amountRequired) 425 | "amountSelected = amountRequired" 426 | $ if amountSelected > amountRequired 427 | then 428 | changeGenerated 429 | `shouldBe` [amountSelected `C.distance` amountRequired] 430 | else changeGenerated `shouldSatisfy` null 431 | where 432 | amountSelected = coinMapValue inpsSelected 433 | amountRequired = coinMapValue outsRequested 434 | result = 435 | runIdentity $ 436 | runExceptT $ 437 | selectCoins largestFirst $ 438 | CoinSelectionParameters inpsAvailable outsRequested $ 439 | CoinSelectionLimit $ 440 | const 1000 441 | 442 | -------------------------------------------------------------------------------- 443 | -- Utilities 444 | -------------------------------------------------------------------------------- 445 | 446 | -- Returns true if (and only if) the given error value is one that can be 447 | -- thrown by the Largest-First algorithm. 448 | -- 449 | isValidLargestFirstError :: CoinSelectionError -> Bool 450 | isValidLargestFirstError = \case 451 | InputLimitExceeded _ -> True 452 | InputValueInsufficient _ -> True 453 | InputCountInsufficient _ -> False 454 | InputsExhausted _ -> False 455 | -------------------------------------------------------------------------------- /src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE NumericUnderscores #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | {-# OPTIONS_GHC -fno-warn-orphans #-} 10 | 11 | module Cardano.CoinSelection.Algorithm.MigrationSpec 12 | ( spec 13 | ) where 14 | 15 | import Prelude 16 | 17 | import Cardano.CoinSelection 18 | ( CoinMap (..) 19 | , CoinMapEntry (..) 20 | , CoinSelection (..) 21 | , coinMapToList 22 | , coinMapValue 23 | , sumChange 24 | , sumInputs 25 | ) 26 | import Cardano.CoinSelection.Algorithm.Migration 27 | ( BatchSize (..), idealBatchSize, selectCoins ) 28 | import Cardano.CoinSelection.Fee 29 | ( DustThreshold (..) 30 | , Fee (..) 31 | , FeeBalancingPolicy (..) 32 | , FeeEstimator (..) 33 | , FeeOptions (..) 34 | ) 35 | import Cardano.CoinSelection.FeeSpec ( FeeParameters, stableEstimator ) 36 | import Cardano.CoinSelectionSpec 37 | () 38 | import Cardano.Test.Utilities 39 | ( InputId 40 | , OutputId 41 | , genInputId 42 | , mkInputId 43 | , unsafeCoin 44 | , unsafeDustThreshold 45 | , unsafeFee 46 | ) 47 | import Data.Function ( (&) ) 48 | import Internal.Coin ( Coin, coinToIntegral ) 49 | import Numeric.Natural ( Natural ) 50 | import Test.Hspec ( Spec, SpecWith, describe, it, shouldSatisfy ) 51 | import Test.QuickCheck 52 | ( Arbitrary (..) 53 | , Gen 54 | , Property 55 | , arbitrarySizedIntegral 56 | , choose 57 | , conjoin 58 | , counterexample 59 | , frequency 60 | , label 61 | , property 62 | , vectorOf 63 | , withMaxSuccess 64 | , (===) 65 | ) 66 | import Test.QuickCheck.Monadic ( monadicIO, monitor, pick ) 67 | 68 | import qualified Data.Map as Map 69 | import qualified Data.Set as Set 70 | import qualified Internal.Coin as C 71 | 72 | spec :: Spec 73 | spec = do 74 | describe "idealBatchSize" $ do 75 | it "Eventually converge for decreasing functions" $ do 76 | property $ \coinselOpts -> do 77 | let batchSize = idealBatchSize coinselOpts 78 | label (show batchSize) True 79 | 80 | describe "accuracy of selectCoins" $ do 81 | let testAccuracy :: Double -> SpecWith () 82 | testAccuracy r = it title $ withMaxSuccess 1000 $ monadicIO $ do 83 | let dust = unsafeCoin @Int 100 84 | utxo <- pick (genUTxO r dust) 85 | batchSize <- pick genBatchSize 86 | feeOpts <- pick (genFeeOptions dust) 87 | let selections = selectCoins feeOpts batchSize utxo 88 | monitor $ label $ accuracy dust 89 | (coinToIntegral $ coinMapValue utxo) 90 | (sum $ coinToIntegral . sumInputs <$> selections) 91 | where 92 | title :: String 93 | title = "dust=" <> show (round (100 * r) :: Int) <> "%" 94 | 95 | accuracy :: Coin -> Natural -> Natural -> String 96 | accuracy dust sup real 97 | | a >= 1.0 = 98 | "PERFECT (== 100%)" 99 | | a > 0.99 || (sup - real) < coinToIntegral dust = 100 | "OKAY (> 99%)" 101 | | otherwise = 102 | "MEDIOCRE (<= 99%)" 103 | where 104 | a = double real / double sup 105 | double = fromRational @Double . fromIntegral 106 | 107 | mapM_ testAccuracy [ 0.01 , 0.05 , 0.10 , 0.25 , 0.50 ] 108 | 109 | describe "selectCoins properties" $ do 110 | it "No coin selection has outputs" $ 111 | property $ withMaxSuccess 10_000 $ prop_onlyChangeOutputs 112 | @(Wrapped InputId) @OutputId 113 | 114 | it "Every coin in the selection change > dust threshold" $ 115 | property $ withMaxSuccess 10_000 $ prop_allAboveThreshold 116 | @(Wrapped InputId) @OutputId 117 | 118 | it "Total input UTxO value >= sum of selection change coins" $ 119 | property $ withMaxSuccess 10_000 $ prop_inputsGreaterThanOutputs 120 | @(Wrapped InputId) @OutputId 121 | 122 | it "Every selection input is unique" $ 123 | property $ withMaxSuccess 10_000 $ prop_inputsAreUnique 124 | @(Wrapped InputId) @OutputId 125 | 126 | it "Every selection input is a member of the UTxO" $ 127 | property $ withMaxSuccess 10_000 $ prop_inputsStillInUTxO 128 | @(Wrapped InputId) @OutputId 129 | 130 | it "Every coin selection is well-balanced" $ 131 | property $ withMaxSuccess 10_000 $ prop_wellBalanced 132 | @(Wrapped InputId) @OutputId 133 | 134 | describe "selectCoins regressions" $ do 135 | it "regression #1" $ do 136 | let feeOpts = FeeOptions 137 | { dustThreshold = unsafeDustThreshold @Int 9 138 | , feeEstimator = FeeEstimator $ \s -> unsafeFee @Int 139 | $ fromIntegral 140 | $ 5 * (length (inputs s) + length (outputs s)) 141 | , feeBalancingPolicy = RequireBalancedFee 142 | } 143 | let batchSize = BatchSize 1 144 | let utxo = CoinMap $ Map.fromList 145 | [ ( mkInputId "|\243^\SUBg\242\231\&1\213\203" 146 | , unsafeCoin @Int 2 147 | ) 148 | ] 149 | property $ prop_inputsGreaterThanOutputs 150 | @InputId @OutputId feeOpts batchSize utxo 151 | 152 | -------------------------------------------------------------------------------- 153 | -- Properties 154 | -------------------------------------------------------------------------------- 155 | 156 | -- | No coin selection has outputs 157 | prop_onlyChangeOutputs 158 | :: forall i o . (Ord i, Ord o, Show o) 159 | => FeeOptions i o 160 | -> BatchSize 161 | -> CoinMap i 162 | -> Property 163 | prop_onlyChangeOutputs feeOpts batchSize utxo = do 164 | let allOutputs = 165 | coinMapToList . outputs =<< selectCoins feeOpts batchSize utxo 166 | property (allOutputs `shouldSatisfy` null) 167 | 168 | -- | Every coin in the selection change > dust threshold 169 | prop_allAboveThreshold 170 | :: forall i o . (Ord i, Ord o) 171 | => FeeOptions i o 172 | -> BatchSize 173 | -> CoinMap i 174 | -> Property 175 | prop_allAboveThreshold feeOpts batchSize utxo = do 176 | let allChange = change 177 | =<< selectCoins feeOpts batchSize utxo 178 | let undersizedCoins = 179 | filter (<= threshold) allChange 180 | property (undersizedCoins `shouldSatisfy` null) 181 | where 182 | threshold = unDustThreshold $ dustThreshold feeOpts 183 | 184 | -- | Total input UTxO value >= sum of selection change coins 185 | prop_inputsGreaterThanOutputs 186 | :: forall i o . (Ord i, Ord o, Show i, Show o) 187 | => FeeOptions i o 188 | -> BatchSize 189 | -> CoinMap i 190 | -> Property 191 | prop_inputsGreaterThanOutputs feeOpts batchSize utxo = do 192 | let selections = selectCoins feeOpts batchSize utxo 193 | let totalChange = mconcat (sumChange <$> selections) 194 | let balanceUTxO = coinMapValue utxo 195 | property (balanceUTxO >= totalChange) 196 | & counterexample ("Total change balance: " <> show totalChange) 197 | & counterexample ("Total UTxO balance: " <> show balanceUTxO) 198 | & counterexample ("Selections: " <> show selections) 199 | 200 | -- | Every selected input is unique, i.e. selected only once 201 | prop_inputsAreUnique 202 | :: forall i o . (Ord i, Ord o) 203 | => FeeOptions i o 204 | -> BatchSize 205 | -> CoinMap i 206 | -> Property 207 | prop_inputsAreUnique feeOpts batchSize utxo = do 208 | let selectionInputList = 209 | coinMapToList . inputs =<< selectCoins feeOpts batchSize utxo 210 | let selectionInputSet = 211 | Set.fromList selectionInputList 212 | Set.size selectionInputSet === length selectionInputSet 213 | 214 | -- | Every selection input is still a member of the UTxO" $ 215 | prop_inputsStillInUTxO 216 | :: forall i o . (Ord i, Ord o) 217 | => FeeOptions i o 218 | -> BatchSize 219 | -> CoinMap i 220 | -> Property 221 | prop_inputsStillInUTxO feeOpts batchSize utxo = do 222 | let selectionInputSet = Set.fromList $ 223 | coinMapToList . inputs =<< selectCoins feeOpts batchSize utxo 224 | let utxoSet = Set.fromList $ 225 | fmap (uncurry CoinMapEntry) $ Map.toList $ unCoinMap utxo 226 | property (selectionInputSet `Set.isSubsetOf` utxoSet) 227 | 228 | -- | Every coin selection is well-balanced (i.e. actual fees are exactly the 229 | -- expected fees) 230 | prop_wellBalanced 231 | :: forall i o . (Ord i, Ord o, Show i, Show o) 232 | => FeeParameters i o 233 | -> BatchSize 234 | -> CoinMap i 235 | -> Property 236 | prop_wellBalanced feeParams batchSize utxo = do 237 | let feeOpts = FeeOptions 238 | { dustThreshold = DustThreshold mempty 239 | , feeEstimator = stableEstimator feeParams 240 | , feeBalancingPolicy = RequireBalancedFee 241 | } 242 | let selections = selectCoins feeOpts batchSize utxo 243 | conjoin 244 | [ counterexample example (actualFee === expectedFee) 245 | | s <- selections 246 | , let actualFee 247 | = coinToIntegral (sumInputs s) 248 | - coinToIntegral (sumChange s) 249 | , let expectedFee 250 | = coinToIntegral @Integer 251 | $ unFee $ estimateFee (feeEstimator feeOpts) s 252 | , let example = unlines 253 | [ "Coin Selection: " <> show s 254 | , "Actual fee: " <> show actualFee 255 | , "Expected fee: " <> show expectedFee 256 | ] 257 | ] 258 | 259 | -------------------------------------------------------------------------------- 260 | -- Arbitrary Instances 261 | -------------------------------------------------------------------------------- 262 | 263 | -- A wrapper to avoid overlapping instances imported from other modules. 264 | newtype Wrapped a = Wrapped { unwrap :: a } 265 | deriving (Eq, Ord, Show) 266 | 267 | -- TODO: Move similar Arbitrary instances to a shared module for better reuse. 268 | instance Arbitrary (Wrapped InputId) where 269 | arbitrary = Wrapped <$> genInputId 8 270 | 271 | instance Arbitrary BatchSize where 272 | arbitrary = BatchSize <$> arbitrarySizedIntegral 273 | shrink (BatchSize s) = BatchSize <$> shrink s 274 | 275 | -------------------------------------------------------------------------------- 276 | -- Generators 277 | -------------------------------------------------------------------------------- 278 | 279 | genBatchSize :: Gen BatchSize 280 | genBatchSize = BatchSize <$> choose (50, 150) 281 | 282 | genFeeOptions :: Coin -> Gen (FeeOptions InputId OutputId) 283 | genFeeOptions dust = do 284 | pure $ FeeOptions 285 | { feeEstimator = FeeEstimator $ \s -> 286 | let x = fromIntegral @_ @Integer 287 | (length (inputs s) + length (outputs s)) 288 | in unsafeFee $ 289 | (C.coinToIntegral dust `div` 100) * x + C.coinToIntegral dust 290 | , dustThreshold = DustThreshold dust 291 | , feeBalancingPolicy = RequireBalancedFee 292 | } 293 | 294 | -- | Generate a given UTxO with a particular percentage of dust 295 | genUTxO :: Double -> Coin -> Gen (CoinMap InputId) 296 | genUTxO r dust = do 297 | n <- choose (10, 1000) 298 | inps <- vectorOf n (genInputId 8) 299 | coins <- vectorOf n genCoin 300 | pure $ CoinMap $ Map.fromList $ zip inps coins 301 | where 302 | genCoin :: Gen Coin 303 | genCoin = unsafeCoin @Int <$> frequency 304 | [ (round (100*r), choose (1, integralDust)) 305 | , (round (100*(1-r)), choose (integralDust, 1000 * integralDust)) 306 | ] 307 | where 308 | integralDust = C.coinToIntegral dust 309 | 310 | -------------------------------------------------------------------------------- 311 | -- Utility Functions 312 | -------------------------------------------------------------------------------- 313 | -------------------------------------------------------------------------------- /src/test/Cardano/CoinSelection/Algorithm/RandomImproveSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns #-} 7 | 8 | module Cardano.CoinSelection.Algorithm.RandomImproveSpec ( 9 | spec, 10 | ) where 11 | 12 | import Prelude 13 | 14 | import Cardano.CoinSelection 15 | ( CoinSelection (..) 16 | , CoinSelectionAlgorithm (..) 17 | , CoinSelectionError (..) 18 | , CoinSelectionLimit (..) 19 | , CoinSelectionParameters (..) 20 | , CoinSelectionResult (..) 21 | , InputCountInsufficientError (..) 22 | , InputLimitExceededError (..) 23 | , InputValueInsufficientError (..) 24 | , InputsExhaustedError (..) 25 | ) 26 | import Cardano.CoinSelection.Algorithm.LargestFirst ( largestFirst ) 27 | import Cardano.CoinSelection.Algorithm.LargestFirstSpec 28 | ( isValidLargestFirstError ) 29 | import Cardano.CoinSelection.Algorithm.RandomImprove ( randomImprove ) 30 | import Cardano.CoinSelectionSpec 31 | ( CoinSelectionData (..) 32 | , CoinSelectionFixture (..) 33 | , CoinSelectionTestResult (..) 34 | , coinSelectionAlgorithmGeneralProperties 35 | , coinSelectionUnitTest 36 | ) 37 | import Cardano.Test.Utilities ( InputId, OutputId, unsafeCoin ) 38 | import Control.Monad.Trans.Except ( runExceptT ) 39 | import Crypto.Random ( SystemDRG, getSystemDRG ) 40 | import Crypto.Random.Types ( withDRG ) 41 | import Data.Either ( isRight ) 42 | import Data.Functor.Identity ( Identity (..) ) 43 | import Test.Hspec ( Spec, before, describe, it, shouldBe, shouldSatisfy ) 44 | import Test.QuickCheck ( Property, counterexample, property, (==>) ) 45 | 46 | import qualified Data.List as L 47 | 48 | spec :: Spec 49 | spec = do 50 | describe "Coin selection : random algorithm unit tests" $ do 51 | let oneAda = 1_000_000 52 | 53 | coinSelectionUnitTest 54 | randomImprove 55 | "" 56 | ( Right $ 57 | CoinSelectionTestResult 58 | { rsInputs = [1, 1, 1, 1] 59 | , rsChange = [2] 60 | , rsOutputs = [2] 61 | } 62 | ) 63 | ( CoinSelectionFixture 64 | { maxNumOfInputs = 100 65 | , utxoInputs = [1, 1, 1, 1, 1, 1] 66 | , txOutputs = [2] 67 | } 68 | ) 69 | 70 | coinSelectionUnitTest 71 | randomImprove 72 | "" 73 | ( Right $ 74 | CoinSelectionTestResult 75 | { rsInputs = [1, 1, 1, 1, 1, 1] 76 | , rsChange = [2, 1] 77 | , rsOutputs = [2, 1] 78 | } 79 | ) 80 | ( CoinSelectionFixture 81 | { maxNumOfInputs = 100 82 | , utxoInputs = [1, 1, 1, 1, 1, 1] 83 | , txOutputs = [2, 1] 84 | } 85 | ) 86 | 87 | coinSelectionUnitTest 88 | randomImprove 89 | "" 90 | ( Right $ 91 | CoinSelectionTestResult 92 | { rsInputs = [1, 1, 1, 1, 1] 93 | , rsChange = [2] 94 | , rsOutputs = [2, 1] 95 | } 96 | ) 97 | ( CoinSelectionFixture 98 | { maxNumOfInputs = 100 99 | , utxoInputs = [1, 1, 1, 1, 1] 100 | , txOutputs = [2, 1] 101 | } 102 | ) 103 | 104 | coinSelectionUnitTest 105 | randomImprove 106 | "" 107 | ( Right $ 108 | CoinSelectionTestResult 109 | { rsInputs = [1, 1, 1, 1] 110 | , rsChange = [1] 111 | , rsOutputs = [2, 1] 112 | } 113 | ) 114 | ( CoinSelectionFixture 115 | { maxNumOfInputs = 100 116 | , utxoInputs = [1, 1, 1, 1] 117 | , txOutputs = [2, 1] 118 | } 119 | ) 120 | 121 | coinSelectionUnitTest 122 | randomImprove 123 | "" 124 | ( Right $ 125 | CoinSelectionTestResult 126 | { rsInputs = [5] 127 | , rsChange = [3] 128 | , rsOutputs = [2] 129 | } 130 | ) 131 | ( CoinSelectionFixture 132 | { maxNumOfInputs = 100 133 | , utxoInputs = [5, 5, 5] 134 | , txOutputs = [2] 135 | } 136 | ) 137 | 138 | coinSelectionUnitTest 139 | randomImprove 140 | "" 141 | ( Right $ 142 | CoinSelectionTestResult 143 | { rsInputs = [10, 10] 144 | , rsChange = [8, 8] 145 | , rsOutputs = [2, 2] 146 | } 147 | ) 148 | ( CoinSelectionFixture 149 | { maxNumOfInputs = 100 150 | , utxoInputs = [10, 10, 10] 151 | , txOutputs = [2, 2] 152 | } 153 | ) 154 | 155 | coinSelectionUnitTest 156 | randomImprove 157 | "cannot cover aim, but only min" 158 | ( Right $ 159 | CoinSelectionTestResult 160 | { rsInputs = [1, 1, 1, 1] 161 | , rsChange = [1] 162 | , rsOutputs = [3] 163 | } 164 | ) 165 | ( CoinSelectionFixture 166 | { maxNumOfInputs = 4 167 | , utxoInputs = [1, 1, 1, 1, 1, 1] 168 | , txOutputs = [3] 169 | } 170 | ) 171 | 172 | coinSelectionUnitTest 173 | randomImprove 174 | "REG CO-450: no fallback" 175 | ( Right $ 176 | CoinSelectionTestResult 177 | { rsInputs = [oneAda, oneAda, oneAda, oneAda] 178 | , rsChange = [oneAda, oneAda `div` 2] 179 | , rsOutputs = [2 * oneAda, oneAda `div` 2] 180 | } 181 | ) 182 | ( CoinSelectionFixture 183 | { maxNumOfInputs = 4 184 | , utxoInputs = [oneAda, oneAda, oneAda, oneAda] 185 | , txOutputs = [2 * oneAda, oneAda `div` 2] 186 | } 187 | ) 188 | 189 | coinSelectionUnitTest 190 | randomImprove 191 | "enough funds, proper fragmentation, inputs depleted" 192 | (Left (InputsExhausted InputsExhaustedError)) 193 | ( CoinSelectionFixture 194 | { maxNumOfInputs = 100 195 | , utxoInputs = [10, 10, 10, 10] 196 | , txOutputs = [38, 1] 197 | } 198 | ) 199 | 200 | coinSelectionUnitTest 201 | randomImprove 202 | "" 203 | (Left $ InputLimitExceeded $ InputLimitExceededError 2) 204 | ( CoinSelectionFixture 205 | { maxNumOfInputs = 2 206 | , utxoInputs = [1, 1, 1, 1, 1, 1] 207 | , txOutputs = [3] 208 | } 209 | ) 210 | 211 | coinSelectionUnitTest 212 | randomImprove 213 | "each output needs maxNumInputs" 225 | (Left $ InputLimitExceeded $ InputLimitExceededError 9) 226 | ( CoinSelectionFixture 227 | { maxNumOfInputs = 9 228 | , utxoInputs = replicate 100 1 229 | , txOutputs = replicate 10 10 230 | } 231 | ) 232 | 233 | coinSelectionUnitTest 234 | randomImprove 235 | "" 236 | ( Left $ 237 | InputValueInsufficient $ 238 | InputValueInsufficientError 239 | (unsafeCoin @Int 39) 240 | (unsafeCoin @Int 40) 241 | ) 242 | ( CoinSelectionFixture 243 | { maxNumOfInputs = 100 244 | , utxoInputs = [12, 10, 17] 245 | , txOutputs = [40] 246 | } 247 | ) 248 | 249 | coinSelectionUnitTest 250 | randomImprove 251 | "" 252 | ( Left $ 253 | InputValueInsufficient $ 254 | InputValueInsufficientError 255 | (unsafeCoin @Int 39) 256 | (unsafeCoin @Int 43) 257 | ) 258 | ( CoinSelectionFixture 259 | { maxNumOfInputs = 100 260 | , utxoInputs = [12, 10, 17] 261 | , txOutputs = [40, 1, 1, 1] 262 | } 263 | ) 264 | 265 | coinSelectionUnitTest 266 | randomImprove 267 | "" 268 | (Left $ InputCountInsufficient $ InputCountInsufficientError 3 4) 269 | ( CoinSelectionFixture 270 | { maxNumOfInputs = 100 271 | , utxoInputs = [12, 20, 17] 272 | , txOutputs = [40, 1, 1, 1] 273 | } 274 | ) 275 | 276 | before getSystemDRG $ 277 | describe "Coin selection properties : random algorithm" $ do 278 | it 279 | "forall (UTxO, NonEmpty TxOut), running algorithm gives not \ 280 | \less UTxO fragmentation than LargestFirst algorithm" 281 | (property . propFragmentation @InputId @OutputId) 282 | it 283 | "forall (UTxO, NonEmpty TxOut), running algorithm gives the \ 284 | \same errors as LargestFirst algorithm" 285 | (property . propErrors @InputId @OutputId) 286 | 287 | coinSelectionAlgorithmGeneralProperties @InputId @OutputId 288 | randomImprove 289 | "Random-Improve" 290 | 291 | -------------------------------------------------------------------------------- 292 | -- Properties 293 | -------------------------------------------------------------------------------- 294 | 295 | propFragmentation :: 296 | (Ord i, Ord o) => 297 | SystemDRG -> 298 | CoinSelectionData i o -> 299 | Property 300 | propFragmentation drg (CoinSelectionData utxo txOuts) = do 301 | isRight selection1 302 | && isRight selection2 303 | ==> let Right (CoinSelectionResult s1 _) = selection1 304 | in let Right (CoinSelectionResult s2 _) = selection2 305 | in prop (s1, s2) 306 | where 307 | prop (CoinSelection inps1 _ _, CoinSelection inps2 _ _) = 308 | L.length inps1 `shouldSatisfy` (>= L.length inps2) 309 | (selection1, _) = 310 | withDRG drg $ 311 | runExceptT $ 312 | selectCoins randomImprove params 313 | selection2 = 314 | runIdentity $ 315 | runExceptT $ 316 | selectCoins largestFirst params 317 | selectionLimit = CoinSelectionLimit $ const 100 318 | params = CoinSelectionParameters utxo txOuts selectionLimit 319 | 320 | propErrors :: 321 | (Ord i, Ord o, Show i, Show o) => 322 | SystemDRG -> 323 | CoinSelectionData i o -> 324 | Property 325 | propErrors drg (CoinSelectionData utxo txOuts) = 326 | case resultRandomImprove of 327 | Right _ -> 328 | -- Largest-First should always succeed if Random-Improve succeeds. 329 | counterexample "case: Success" $ 330 | property $ 331 | resultLargestFirst `shouldSatisfy` isRight 332 | Left (InputValueInsufficient _) -> 333 | -- Largest-First should fail in exactly the same way when the total 334 | -- value available is insufficient. 335 | counterexample "case: InputValueInsufficient" $ 336 | property $ 337 | resultLargestFirst `shouldBe` resultRandomImprove 338 | Left (InputCountInsufficient _) -> 339 | -- Largest-First can still succeed in this case, so just check for 340 | -- a valid result. 341 | counterexample "case: InputCountInsufficient" $ 342 | property $ 343 | resultLargestFirst `shouldSatisfy` isValidLargestFirstResult 344 | Left (InputsExhausted _) -> 345 | -- Largest-First can still succeed in this case, so just check for 346 | -- a valid result. 347 | counterexample "case: InputsExhausted" $ 348 | property $ 349 | resultLargestFirst `shouldSatisfy` isValidLargestFirstResult 350 | Left (InputLimitExceeded _) -> 351 | -- Largest-First can still succeed in this case, so just check for 352 | -- a valid result. 353 | counterexample "case: InputLimitExceeded" $ 354 | property $ 355 | resultLargestFirst `shouldSatisfy` isValidLargestFirstResult 356 | where 357 | isValidLargestFirstResult = \case 358 | Right _ -> 359 | -- We assume that this is a valid result, based on the assumption 360 | -- that test coverage for Largest-First is sufficient. 361 | True 362 | Left x -> 363 | isValidLargestFirstError x 364 | resultRandomImprove = 365 | fst $ 366 | withDRG drg $ 367 | runExceptT $ 368 | selectCoins randomImprove params 369 | resultLargestFirst = 370 | runIdentity $ 371 | runExceptT $ 372 | selectCoins largestFirst params 373 | selectionLimit = CoinSelectionLimit $ const 1 374 | params = CoinSelectionParameters utxo txOuts selectionLimit 375 | -------------------------------------------------------------------------------- /src/test/Cardano/CoinSelection/TypesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | 9 | module Cardano.CoinSelection.TypesSpec 10 | ( spec 11 | ) where 12 | 13 | import Prelude 14 | 15 | import Cardano.CoinSelection ( CoinMap (..), coinMapValue ) 16 | import Cardano.Test.Utilities 17 | ( InputId 18 | , excluding 19 | , isSubsetOf 20 | , mkInputId 21 | , restrictedBy 22 | , restrictedTo 23 | , unsafeCoin 24 | ) 25 | import Data.Set ( Set, (\\) ) 26 | import Internal.Coin ( Coin ) 27 | import Test.Hspec ( Spec, describe, it ) 28 | import Test.QuickCheck 29 | ( Arbitrary (..) 30 | , Property 31 | , checkCoverage 32 | , choose 33 | , cover 34 | , property 35 | , vectorOf 36 | , (===) 37 | ) 38 | 39 | import qualified Data.ByteString as BS 40 | import qualified Data.Map.Strict as Map 41 | import qualified Data.Set as Set 42 | import qualified Internal.Coin as C 43 | 44 | spec :: Spec 45 | spec = do 46 | 47 | describe "Lemma 2.1 - Properties of UTxO operations" $ do 48 | it "2.1.1) ins⊲ u ⊆ u" 49 | (checkCoverage $ prop_2_1_1 @InputId) 50 | it "2.1.2) ins⋪ u ⊆ u" 51 | (checkCoverage $ prop_2_1_2 @InputId) 52 | it "2.1.3) u ⊳ outs ⊆ u" 53 | (checkCoverage $ prop_2_1_3 @InputId) 54 | it "2.1.4) ins⊲ (u ⋃ v) = (ins⊲ u) ⋃ (ins⊲ v)" 55 | (checkCoverage $ prop_2_1_4 @InputId) 56 | it "2.1.5) ins⋪ (u ⋃ v) = (ins⋪ u) ⋃ (ins⋪ v)" 57 | (checkCoverage $ prop_2_1_5 @InputId) 58 | it "2.1.6) (dom u ⋂ ins) ⊲ u = ins⊲ u" 59 | (checkCoverage $ prop_2_1_6 @InputId) 60 | it "2.1.7) (dom u ⋂ ins) ⋪ u = ins⋪ u" 61 | (checkCoverage $ prop_2_1_7 @InputId) 62 | it "2.1.8) (dom u ⋃ ins) ⋪ (u ⋃ v) = (ins ⋃ dom u) ⋪ v" 63 | (checkCoverage $ prop_2_1_8 @InputId) 64 | it "2.1.9) ins⋪ u = (dom u \\ ins)⊲ u" 65 | (checkCoverage $ prop_2_1_9 @InputId) 66 | 67 | describe "Lemma 2.6 - Properties of balance" $ do 68 | it "2.6.1) dom u ⋂ dom v ==> balance (u ⋃ v) = balance u + balance v" 69 | (checkCoverage $ prop_2_6_1 @InputId) 70 | it "2.6.2) balance (ins⋪ u) = balance u - balance (ins⊲ u)" 71 | (checkCoverage $ prop_2_6_2 @InputId) 72 | 73 | -------------------------------------------------------------------------------- 74 | -- Wallet Specification - Lemma 2.1 - Properties of UTxO operations 75 | -------------------------------------------------------------------------------- 76 | 77 | prop_2_1_1 :: Ord u => (Set u, CoinMap u) -> Property 78 | prop_2_1_1 (ins, u) = 79 | cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) 80 | where 81 | cond = not $ Set.null $ dom u `Set.intersection` ins 82 | prop = (u `restrictedBy` ins) `isSubsetOf` u 83 | 84 | prop_2_1_2 :: Ord u => (Set u, CoinMap u) -> Property 85 | prop_2_1_2 (ins, u) = 86 | cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) 87 | where 88 | cond = not $ Set.null $ dom u `Set.intersection` ins 89 | prop = (u `excluding` ins) `isSubsetOf` u 90 | 91 | prop_2_1_3 :: Ord u => (Set Coin, CoinMap u) -> Property 92 | prop_2_1_3 (outs, u) = 93 | cover 50 cond "u ⋂ outs ≠ ∅" (property prop) 94 | where 95 | cond = not $ Set.null $ 96 | Set.fromList (Map.elems (unCoinMap u)) `Set.intersection` outs 97 | prop = (u `restrictedTo` outs) `isSubsetOf` u 98 | 99 | prop_2_1_4 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property 100 | prop_2_1_4 (ins, u, v) = 101 | cover 50 cond "(dom u ⋃ dom v) ⋂ ins ≠ ∅" (property prop) 102 | where 103 | cond = not $ Set.null $ Set.union (dom u) (dom v) `Set.intersection` ins 104 | prop = 105 | ((u <> v) `restrictedBy` ins) 106 | === 107 | (u `restrictedBy` ins) <> (v `restrictedBy` ins) 108 | 109 | prop_2_1_5 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property 110 | prop_2_1_5 (ins, u, v) = 111 | cover 50 cond "(dom u ⋃ dom v) ⋂ ins ≠ ∅" (property prop) 112 | where 113 | cond = not $ Set.null $ Set.union (dom u) (dom v) `Set.intersection` ins 114 | prop = 115 | ((u <> v) `excluding` ins) 116 | === 117 | (u `excluding` ins) <> (v `excluding` ins) 118 | 119 | prop_2_1_6 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property 120 | prop_2_1_6 (ins, u) = 121 | cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) 122 | where 123 | cond = not $ Set.null $ dom u `Set.intersection` ins 124 | prop = 125 | (u `restrictedBy` (dom u `Set.intersection` ins)) 126 | === 127 | (u `restrictedBy` ins) 128 | 129 | prop_2_1_7 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property 130 | prop_2_1_7 (ins, u) = 131 | cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) 132 | where 133 | cond = not $ Set.null $ dom u `Set.intersection` ins 134 | prop = 135 | (u `excluding` (dom u `Set.intersection` ins)) 136 | === 137 | (u `excluding` ins) 138 | 139 | prop_2_1_8 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property 140 | prop_2_1_8 (ins, u, v) = 141 | cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) 142 | where 143 | cond = not $ Set.null $ dom u `Set.intersection` ins 144 | prop = 145 | ((u <> v) `excluding` (dom u <> ins)) 146 | === 147 | v `excluding` (ins <> dom u) 148 | 149 | prop_2_1_9 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property 150 | prop_2_1_9 (ins, u) = 151 | cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) 152 | where 153 | cond = not $ Set.null $ dom u `Set.intersection` ins 154 | prop = (u `excluding` ins) === u `restrictedBy` (dom u \\ ins) 155 | 156 | -------------------------------------------------------------------------------- 157 | -- Wallet Specification - Lemma 2.6 - Properties of Balance 158 | -------------------------------------------------------------------------------- 159 | 160 | prop_2_6_1 :: Ord u => (CoinMap u, CoinMap u) -> Property 161 | prop_2_6_1 (u, v) = 162 | cover 50 cond "u ≠ ∅ , v ≠ ∅" (property prop) 163 | where 164 | -- NOTE: 165 | -- A precondition (u ⋂ v = ∅ ) is hard to satisfy because our generators 166 | -- are built in order to not be 'too entropic'. So, we better just create 167 | -- a v' that has no overlap with u. 168 | v' = v `excluding` dom u 169 | cond = not (u `isSubsetOf` mempty || v' `isSubsetOf` mempty) 170 | prop = coinMapValue (u <> v') 171 | === coinMapValue u `C.add` coinMapValue v' 172 | 173 | prop_2_6_2 :: Ord u => (Set u, CoinMap u) -> Property 174 | prop_2_6_2 (ins, u) = 175 | cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) 176 | where 177 | cond = not $ Set.null $ dom u `Set.intersection` ins 178 | prop = 179 | Just (coinMapValue (u `excluding` ins)) 180 | === 181 | coinMapValue u `C.sub` 182 | coinMapValue (u `restrictedBy` ins) 183 | 184 | -------------------------------------------------------------------------------- 185 | -- UTxO Utilities 186 | -------------------------------------------------------------------------------- 187 | 188 | -- | Extracts the domain of a UTxO: the set of references to unspent transaction 189 | -- ouputs. 190 | dom :: CoinMap u -> Set u 191 | dom (CoinMap utxo) = Map.keysSet utxo 192 | 193 | -------------------------------------------------------------------------------- 194 | -- Arbitrary Instances 195 | -- 196 | -- Arbitrary instances define here aren't necessarily reflecting on real-life 197 | -- scenario, but they help test the property above by constructing data 198 | -- structures that don't have much entropy and therefore, allow us to even test 199 | -- something when checking for intersections and set restrictions! 200 | -------------------------------------------------------------------------------- 201 | 202 | instance Arbitrary Coin where 203 | -- No Shrinking 204 | arbitrary = unsafeCoin @Int <$> choose (0, 3) 205 | 206 | instance (Arbitrary u, Ord u) => Arbitrary (CoinMap u) where 207 | shrink (CoinMap utxo) = CoinMap <$> shrink utxo 208 | arbitrary = do 209 | n <- choose (0, 10) 210 | utxo <- zip 211 | <$> vectorOf n arbitrary 212 | <*> vectorOf n arbitrary 213 | return $ CoinMap $ Map.fromList utxo 214 | 215 | instance Arbitrary InputId where 216 | arbitrary = mkInputId . BS.singleton <$> choose (0, 7) 217 | -------------------------------------------------------------------------------- /src/test/Cardano/CoinSelectionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE NumericUnderscores #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns #-} 12 | 13 | module Cardano.CoinSelectionSpec ( 14 | spec, 15 | 16 | -- * Export used to test various coin selection implementations 17 | CoinSelectionFixture (..), 18 | CoinSelectionTestResult (..), 19 | CoinSelectionData (..), 20 | coinSelectionUnitTest, 21 | coinSelectionAlgorithmGeneralProperties, 22 | ) where 23 | 24 | -- \| This module contains shared functionality for coin selection tests. 25 | -- 26 | -- Coin selection algorithms share a common interface, and therefore it makes 27 | -- sense for them to also share arbitrary instances and tests. 28 | 29 | import Prelude 30 | 31 | import Cardano.CoinSelection 32 | ( CoinMap (..) 33 | , CoinMapEntry (..) 34 | , CoinSelection (..) 35 | , CoinSelectionAlgorithm (..) 36 | , CoinSelectionError (..) 37 | , CoinSelectionLimit (..) 38 | , CoinSelectionParameters (..) 39 | , CoinSelectionResult (..) 40 | , coinMapFromList 41 | , coinMapToList 42 | , coinMapValue 43 | , sumChange 44 | , sumInputs 45 | , sumOutputs 46 | ) 47 | import Cardano.Test.Utilities 48 | ( InputId, OutputId, ShowFmt (..), genInputId, genOutputId, unsafeCoin ) 49 | import Control.Arrow ( (&&&) ) 50 | import Control.Monad ( replicateM ) 51 | import Control.Monad.Trans.Except ( runExceptT ) 52 | import Data.Either ( isRight ) 53 | import Data.Function ( (&) ) 54 | import Data.List.NonEmpty ( NonEmpty (..) ) 55 | import Data.Maybe ( catMaybes ) 56 | import Data.Set ( Set ) 57 | import Data.Word ( Word16 ) 58 | import Fmt ( Buildable (..), blockListF, nameF ) 59 | import Internal.Coin ( Coin, coinToIntegral ) 60 | import Test.Hspec 61 | ( Expectation, Spec, SpecWith, describe, it, shouldBe, shouldSatisfy ) 62 | import Test.QuickCheck 63 | ( Arbitrary (..) 64 | , Confidence (..) 65 | , Gen 66 | , Property 67 | , checkCoverage 68 | , checkCoverageWith 69 | , choose 70 | , cover 71 | , elements 72 | , generate 73 | , genericShrink 74 | , oneof 75 | , property 76 | , vectorOf 77 | , withMaxSuccess 78 | , (.&&.) 79 | , (==>) 80 | ) 81 | import Test.QuickCheck.Monadic ( monadicIO ) 82 | import Test.Vector.Shuffle ( shuffle ) 83 | 84 | import qualified Data.Foldable as F 85 | import qualified Data.List as L 86 | import qualified Data.List.NonEmpty as NE 87 | import qualified Data.Map.Strict as Map 88 | import qualified Data.Set as Set 89 | import qualified Internal.Coin as C 90 | import qualified Test.QuickCheck.Monadic as QC 91 | 92 | spec :: Spec 93 | spec = do 94 | describe "CoinMap properties" $ do 95 | it "CoinMap coverage is adequate" $ 96 | checkCoverage $ 97 | prop_CoinMap_coverage @Int 98 | it "CoinMapEntry coverage is adequate" $ 99 | checkCoverage $ 100 | prop_CoinMapEntry_coverage @Int 101 | it "coinMapFromList preserves total value for each unique key" $ 102 | checkCoverage $ 103 | prop_coinMapFromList_preservesTotalValueForEachUniqueKey @Int 104 | it "coinMapFromList preserves total value" $ 105 | checkCoverage $ 106 | prop_coinMapFromList_preservesTotalValue @Int 107 | it "coinMapToList preserves total value" $ 108 | checkCoverage $ 109 | prop_coinMapToList_preservesTotalValue @Int 110 | it "coinMapFromList . coinMapToList = id" $ 111 | checkCoverage $ 112 | prop_coinMapToList_coinMapFromList @Int 113 | it "coinMapToList . coinMapFromList = id (when no keys duplicated)" $ 114 | checkCoverage $ 115 | prop_coinMapFromList_coinMapToList @Int 116 | it "coinMapToList order deterministic" $ 117 | checkCoverageWith lowerConfidence $ 118 | prop_coinMapToList_orderDeterministic @Int 119 | 120 | describe "CoinSelection properties" $ do 121 | it "monoidal append preserves keys" $ 122 | checkCoverage $ 123 | prop_coinSelection_mappendPreservesKeys @Int @Int 124 | it "monoidal append preserves value" $ 125 | checkCoverage $ 126 | prop_coinSelection_mappendPreservesTotalValue @Int @Int 127 | 128 | describe "CoinSelectionData properties" $ do 129 | it "CoinSelectionData coverage is adequate" $ 130 | checkCoverage $ 131 | withMaxSuccess 10_000 $ 132 | prop_CoinSelectionData_coverage @Int @Int 133 | where 134 | lowerConfidence :: Confidence 135 | lowerConfidence = Confidence (10 ^ (6 :: Integer)) 0.75 136 | 137 | -- A collection of general properties that should apply to all algorithms 138 | -- that implement the 'CoinSelectionAlgorithm' interface. 139 | -- 140 | coinSelectionAlgorithmGeneralProperties :: 141 | (Arbitrary i, Arbitrary o, Ord i, Ord o, Show i, Show o) => 142 | CoinSelectionAlgorithm i o IO -> 143 | String -> 144 | Spec 145 | coinSelectionAlgorithmGeneralProperties algorithm algorithmName = 146 | describe ("General properties for " <> algorithmName) $ do 147 | it "value inputsAvailable ≥ value outputsRequested" $ 148 | check prop_algorithm_inputsAvailable_outputsRequested 149 | it "outputsSelected = outputsRequested" $ 150 | check prop_algorithm_outputsSelected_outputsRequested 151 | it "inputsSelected ⊆ inputsAvailable" $ 152 | check prop_algorithm_inputsAvailable_inputsSelected 153 | it "inputsRemaining ⊆ inputsAvailable" $ 154 | check prop_algorithm_inputsAvailable_inputsRemaining 155 | it "inputsSelected ⋂ inputsRemaining = ∅" $ 156 | check prop_algorithm_inputsSelected_inputsRemaining 157 | it "inputsSelected ⋃ inputsRemaining = inputsAvailable" $ 158 | check prop_algorithm_inputsSelected_inputsRemaining_inputsAvailable 159 | it "value inputsSelected = value outputsSelected + value change" $ 160 | check prop_algorithm_inputsSelected_outputsSelected_change 161 | where 162 | check = property . prop_algorithm algorithm 163 | 164 | -------------------------------------------------------------------------------- 165 | -- Coin Map Properties 166 | -------------------------------------------------------------------------------- 167 | 168 | prop_CoinMap_coverage :: 169 | CoinMap u -> 170 | Property 171 | prop_CoinMap_coverage m = 172 | property 173 | $ cover 174 | 10 175 | (null m) 176 | "coin map is empty" 177 | $ cover 178 | 10 179 | (length m == 1) 180 | "coin map has one entry" 181 | $ cover 182 | 10 183 | (length m >= 2) 184 | "coin map has multiple entries" 185 | $ cover 186 | 10 187 | (1 == length (Set.fromList $ entryValue <$> coinMapToList m)) 188 | "coin map has one unique value" 189 | $ cover 190 | 10 191 | (1 < length (Set.fromList $ entryValue <$> coinMapToList m)) 192 | "coin map has several unique values" 193 | True 194 | 195 | prop_CoinMapEntry_coverage :: forall u. (Ord u) => [CoinMapEntry u] -> Property 196 | prop_CoinMapEntry_coverage entries = 197 | property 198 | $ cover 199 | 2 200 | (null entries) 201 | "coin map entry list is empty" 202 | $ cover 203 | 2 204 | (length entries == 1) 205 | "coin map entry list has one entry" 206 | $ cover 207 | 2 208 | (length entries == 2) 209 | "coin map entry list has two entries" 210 | $ cover 211 | 2 212 | (length entries >= 3) 213 | "coin map entry list has multiple entries" 214 | $ cover 215 | 2 216 | (not (null entries) && length uniqueKeys == 1) 217 | "coin map entry list has one unique key" 218 | $ cover 219 | 2 220 | (not (null entries) && length uniqueKeys == 2) 221 | "coin map entry list has two unique keys" 222 | $ cover 223 | 2 224 | (not (null entries) && length uniqueKeys >= 3) 225 | "coin map entry list has multiple unique keys" 226 | $ cover 227 | 2 228 | (not (null entries) && null duplicateKeys) 229 | "coin map entry list has no duplicate keys" 230 | $ cover 231 | 2 232 | (not (null entries) && length duplicateKeys == 1) 233 | "coin map entry list has one duplicate key" 234 | $ cover 235 | 2 236 | (not (null entries) && length duplicateKeys == 2) 237 | "coin map entry list has two duplicate keys" 238 | $ cover 239 | 2 240 | (not (null entries) && length duplicateKeys >= 3) 241 | "coin map entry list has multiple duplicate keys" 242 | True 243 | where 244 | uniqueKeys :: Set u 245 | uniqueKeys = 246 | entries 247 | & fmap entryKey 248 | & Set.fromList 249 | duplicateKeys :: Set u 250 | duplicateKeys = 251 | entries 252 | & fmap (entryKey &&& const (1 :: Int)) 253 | & Map.fromListWith (+) 254 | & Map.filter (> 1) 255 | & Map.keysSet 256 | 257 | prop_coinMapFromList_preservesTotalValueForEachUniqueKey :: 258 | (Ord u, Show u) => 259 | [CoinMapEntry u] -> 260 | Property 261 | prop_coinMapFromList_preservesTotalValueForEachUniqueKey entries = 262 | property $ 263 | mkEntryMap entries 264 | `shouldBe` mkEntryMap (coinMapToList (coinMapFromList entries)) 265 | where 266 | mkEntryMap = 267 | Map.fromListWith C.add 268 | . fmap (entryKey &&& entryValue) 269 | 270 | prop_coinMapFromList_preservesTotalValue :: 271 | (Ord u) => 272 | [CoinMapEntry u] -> 273 | Property 274 | prop_coinMapFromList_preservesTotalValue entries = 275 | property $ 276 | mconcat (entryValue <$> entries) 277 | `shouldBe` coinMapValue (coinMapFromList entries) 278 | 279 | prop_coinMapToList_preservesTotalValue :: 280 | CoinMap u -> 281 | Property 282 | prop_coinMapToList_preservesTotalValue m = 283 | property $ 284 | mconcat (entryValue <$> coinMapToList m) 285 | `shouldBe` coinMapValue m 286 | 287 | prop_coinMapToList_coinMapFromList :: 288 | (Ord u, Show u) => 289 | CoinMap u -> 290 | Property 291 | prop_coinMapToList_coinMapFromList m = 292 | property $ 293 | coinMapFromList (coinMapToList m) 294 | `shouldBe` m 295 | 296 | prop_coinMapFromList_coinMapToList :: 297 | (Ord u, Show u) => 298 | [CoinMapEntry u] -> 299 | Property 300 | prop_coinMapFromList_coinMapToList entries 301 | | duplicateKeyCount == 0 = 302 | property $ x `shouldBe` y 303 | | otherwise = 304 | property $ length x > length y 305 | where 306 | x = L.sort entries 307 | y = L.sort $ coinMapToList $ coinMapFromList entries 308 | 309 | duplicateKeyCount :: Int 310 | duplicateKeyCount = 311 | entries 312 | & fmap (entryKey &&& const (1 :: Int)) 313 | & Map.fromListWith (+) 314 | & Map.filter (> 1) 315 | & Map.keysSet 316 | & length 317 | 318 | prop_coinMapToList_orderDeterministic :: 319 | (Ord u) => CoinMap u -> Property 320 | prop_coinMapToList_orderDeterministic u = monadicIO $ QC.run $ do 321 | let list0 = coinMapToList u 322 | list1 <- shuffle list0 323 | return $ 324 | cover 10 (list0 /= list1) "shuffled" $ 325 | list0 == coinMapToList (coinMapFromList list1) 326 | 327 | -------------------------------------------------------------------------------- 328 | -- Coin Selection Properties 329 | -------------------------------------------------------------------------------- 330 | 331 | prop_coinSelection_mappendPreservesKeys :: 332 | (Ord i, Ord o, Show i, Show o) => 333 | CoinSelection i o -> 334 | CoinSelection i o -> 335 | Property 336 | prop_coinSelection_mappendPreservesKeys s1 s2 = property $ do 337 | Map.keysSet (unCoinMap $ inputs $ s1 <> s2) 338 | `shouldBe` Map.keysSet (unCoinMap $ inputs s1) 339 | `Set.union` Map.keysSet (unCoinMap $ inputs s2) 340 | Map.keysSet (unCoinMap $ outputs $ s1 <> s2) 341 | `shouldBe` Map.keysSet (unCoinMap $ outputs s1) 342 | `Set.union` Map.keysSet (unCoinMap $ outputs s2) 343 | 344 | prop_coinSelection_mappendPreservesTotalValue :: 345 | (Ord i, Ord o) => 346 | CoinSelection i o -> 347 | CoinSelection i o -> 348 | Property 349 | prop_coinSelection_mappendPreservesTotalValue s1 s2 = property $ do 350 | sumInputs s1 <> sumInputs s2 `shouldBe` sumInputs (s1 <> s2) 351 | sumOutputs s1 <> sumOutputs s2 `shouldBe` sumOutputs (s1 <> s2) 352 | sumChange s1 <> sumChange s2 `shouldBe` sumChange (s1 <> s2) 353 | change s1 <> change s2 `shouldBe` change (s1 <> s2) 354 | 355 | prop_CoinSelectionData_coverage :: 356 | CoinSelectionData i o -> 357 | Property 358 | prop_CoinSelectionData_coverage (CoinSelectionData inps outs) = 359 | property 360 | $ cover 361 | 90 362 | (amountAvailable >= amountRequested) 363 | "amountAvailable ≥ amountRequested" 364 | $ (amountAvailable `shouldSatisfy` (> C.zero)) 365 | .&&. (amountRequested `shouldSatisfy` (> C.zero)) 366 | where 367 | amountAvailable = coinMapValue inps 368 | amountRequested = coinMapValue outs 369 | 370 | -------------------------------------------------------------------------------- 371 | -- Coin Selection Algorithm Properties 372 | -------------------------------------------------------------------------------- 373 | 374 | prop_algorithm_inputsAvailable_outputsRequested :: 375 | CoinSelectionData i o -> 376 | CoinSelectionResult i o -> 377 | Expectation 378 | prop_algorithm_inputsAvailable_outputsRequested = 379 | \(CoinSelectionData inputsAvailable outputsRequested) -> 380 | const $ 381 | coinMapValue inputsAvailable 382 | `shouldSatisfy` (>= coinMapValue outputsRequested) 383 | 384 | prop_algorithm_outputsSelected_outputsRequested :: 385 | (Ord o, Show o) => 386 | CoinSelectionData i o -> 387 | CoinSelectionResult i o -> 388 | Expectation 389 | prop_algorithm_outputsSelected_outputsRequested = 390 | \(CoinSelectionData _ outputsRequested) -> 391 | \(CoinSelectionResult (CoinSelection _ outputsSelected _) _) -> 392 | outputsSelected `shouldBe` outputsRequested 393 | 394 | prop_algorithm_inputsAvailable_inputsSelected :: 395 | (Ord i, Show i) => 396 | CoinSelectionData i o -> 397 | CoinSelectionResult i o -> 398 | Expectation 399 | prop_algorithm_inputsAvailable_inputsSelected = 400 | \(CoinSelectionData inputsAvailable _) -> 401 | \(CoinSelectionResult (CoinSelection inputsSelected _ _) _) -> 402 | inputsSelected `shouldSatisfy` (`isSubmapOf` inputsAvailable) 403 | 404 | prop_algorithm_inputsAvailable_inputsRemaining :: 405 | (Ord i, Show i) => 406 | CoinSelectionData i o -> 407 | CoinSelectionResult i o -> 408 | Expectation 409 | prop_algorithm_inputsAvailable_inputsRemaining = 410 | \(CoinSelectionData inputsAvailable _) -> 411 | \(CoinSelectionResult _ inputsRemaining) -> 412 | inputsRemaining `shouldSatisfy` (`isSubmapOf` inputsAvailable) 413 | 414 | prop_algorithm_inputsSelected_inputsRemaining :: 415 | (Ord i, Show i) => 416 | CoinSelectionData i o -> 417 | CoinSelectionResult i o -> 418 | Expectation 419 | prop_algorithm_inputsSelected_inputsRemaining = 420 | \(CoinSelectionData _ _) -> 421 | \(CoinSelectionResult (CoinSelection selected _ _) remaining) -> 422 | (selected `intersection` remaining) `shouldBe` mempty 423 | 424 | prop_algorithm_inputsSelected_inputsRemaining_inputsAvailable :: 425 | (Ord i, Show i) => 426 | CoinSelectionData i o -> 427 | CoinSelectionResult i o -> 428 | Expectation 429 | prop_algorithm_inputsSelected_inputsRemaining_inputsAvailable = 430 | \(CoinSelectionData available _) -> 431 | \(CoinSelectionResult (CoinSelection selected _ _) remaining) -> 432 | (selected `union` remaining) `shouldBe` available 433 | 434 | prop_algorithm_inputsSelected_outputsSelected_change :: 435 | CoinSelectionData i o -> 436 | CoinSelectionResult i o -> 437 | Expectation 438 | prop_algorithm_inputsSelected_outputsSelected_change = const $ 439 | \(CoinSelectionResult (CoinSelection{inputs, outputs, change}) _) -> 440 | coinMapValue inputs 441 | `shouldBe` (coinMapValue outputs `C.add` mconcat change) 442 | 443 | prop_algorithm :: 444 | CoinSelectionAlgorithm i o IO -> 445 | (CoinSelectionData i o -> CoinSelectionResult i o -> Expectation) -> 446 | (CoinSelectionData i o) -> 447 | Property 448 | prop_algorithm algorithm verifyExpectation params = 449 | withMaxSuccess 1_000 $ monadicIO $ QC.run $ do 450 | mResult <- generateResult 451 | pure $ 452 | isRight mResult 453 | ==> let Right result = mResult 454 | in verifyExpectation params result 455 | where 456 | CoinSelectionData{csdInputsAvailable, csdOutputsRequested} = params 457 | generateResult = 458 | runExceptT $ 459 | selectCoins algorithm $ 460 | CoinSelectionParameters csdInputsAvailable csdOutputsRequested $ 461 | CoinSelectionLimit $ 462 | const $ 463 | fromIntegral $ 464 | F.length csdInputsAvailable 465 | 466 | isSubmapOf :: (Ord k) => CoinMap k -> CoinMap k -> Bool 467 | isSubmapOf (CoinMap a) (CoinMap b) = a `Map.isSubmapOf` b 468 | 469 | intersection :: (Ord k) => CoinMap k -> CoinMap k -> CoinMap k 470 | intersection (CoinMap a) (CoinMap b) = CoinMap $ a `Map.intersection` b 471 | 472 | union :: (Ord k) => CoinMap k -> CoinMap k -> CoinMap k 473 | union = (<>) 474 | 475 | -------------------------------------------------------------------------------- 476 | -- Coin Selection - Unit Tests 477 | -------------------------------------------------------------------------------- 478 | 479 | -- | Data for coin selection properties. 480 | data CoinSelectionData i o = CoinSelectionData 481 | { csdInputsAvailable :: 482 | CoinMap i 483 | , csdOutputsRequested :: 484 | CoinMap o 485 | } 486 | deriving (Show) 487 | 488 | instance (Buildable i, Buildable o) => Buildable (CoinSelectionData i o) where 489 | build (CoinSelectionData inps outs) = 490 | mempty 491 | <> nameF "inps" (blockListF $ coinMapToList inps) 492 | <> nameF "outs" (blockListF $ coinMapToList outs) 493 | 494 | -- | A fixture for testing the coin selection 495 | data CoinSelectionFixture i o = CoinSelectionFixture 496 | { maxNumOfInputs :: Word16 497 | -- ^ Maximum number of inputs that can be selected 498 | , utxoInputs :: [Integer] 499 | -- ^ Value (in Lovelace) & number of available coins in the UTxO 500 | , txOutputs :: [Integer] 501 | -- ^ Value (in Lovelace) & number of requested outputs 502 | } 503 | 504 | -- | Testing-friendly format for 'CoinSelection' results of unit tests. 505 | data CoinSelectionTestResult = CoinSelectionTestResult 506 | { rsInputs :: [Integer] 507 | , rsChange :: [Integer] 508 | , rsOutputs :: [Integer] 509 | } 510 | deriving (Eq, Show) 511 | 512 | sortCoinSelectionTestResult :: 513 | CoinSelectionTestResult -> CoinSelectionTestResult 514 | sortCoinSelectionTestResult (CoinSelectionTestResult is cs os) = 515 | CoinSelectionTestResult (L.sort is) (L.sort cs) (L.sort os) 516 | 517 | {- | Generate a 'UTxO' and 'TxOut' matching the given 'Fixture', and perform 518 | the given coin selection on it. 519 | -} 520 | coinSelectionUnitTest :: 521 | CoinSelectionAlgorithm InputId OutputId IO -> 522 | String -> 523 | Either CoinSelectionError CoinSelectionTestResult -> 524 | CoinSelectionFixture InputId OutputId -> 525 | SpecWith () 526 | coinSelectionUnitTest alg lbl expected (CoinSelectionFixture n utxoF outsF) = 527 | it title $ do 528 | (utxo, txOuts) <- setup 529 | result <- runExceptT $ do 530 | CoinSelectionResult (CoinSelection inps outs chngs) _ <- 531 | selectCoins alg $ 532 | CoinSelectionParameters utxo txOuts selectionLimit 533 | return $ 534 | CoinSelectionTestResult 535 | { rsInputs = coinToIntegral . entryValue <$> coinMapToList inps 536 | , rsChange = coinToIntegral <$> chngs 537 | , rsOutputs = coinToIntegral . entryValue <$> coinMapToList outs 538 | } 539 | fmap sortCoinSelectionTestResult result 540 | `shouldBe` fmap sortCoinSelectionTestResult expected 541 | where 542 | selectionLimit = CoinSelectionLimit $ const n 543 | 544 | title :: String 545 | title = 546 | mempty 547 | <> if null lbl 548 | then "" 549 | else 550 | lbl 551 | <> ":\n\t" 552 | <> "max=" 553 | <> show n 554 | <> ", UTxO=" 555 | <> show utxoF 556 | <> ", Output=" 557 | <> show outsF 558 | <> " --> " 559 | <> show (rsInputs <$> expected) 560 | 561 | setup :: IO (CoinMap InputId, CoinMap OutputId) 562 | setup = do 563 | utxo <- generate (genUTxO utxoF) 564 | outs <- generate (genOutputs outsF) 565 | pure (utxo, outs) 566 | 567 | -------------------------------------------------------------------------------- 568 | -- Arbitrary Instances 569 | -------------------------------------------------------------------------------- 570 | 571 | instance Arbitrary InputId where 572 | arbitrary = genInputId 8 573 | 574 | instance Arbitrary OutputId where 575 | arbitrary = genOutputId 8 576 | 577 | deriving instance (Arbitrary a) => Arbitrary (ShowFmt a) 578 | 579 | instance 580 | (Arbitrary i, Arbitrary o, Ord i, Ord o) => 581 | Arbitrary (CoinSelection i o) 582 | where 583 | arbitrary = 584 | CoinSelection 585 | <$> arbitrary 586 | <*> arbitrary 587 | <*> arbitrary 588 | shrink = genericShrink 589 | 590 | instance Arbitrary (CoinSelectionLimit) where 591 | arbitrary = do 592 | -- NOTE Functions have to be decreasing functions 593 | fn <- 594 | elements 595 | [ (maxBound -) 596 | , \x -> 597 | if x > maxBound `div` 2 598 | then maxBound 599 | else maxBound - (2 * x) 600 | , const 42 601 | ] 602 | pure $ CoinSelectionLimit fn 603 | 604 | instance Show (CoinSelectionLimit) where 605 | show _ = "CoinSelectionLimit" 606 | 607 | instance (Arbitrary a) => Arbitrary (NonEmpty a) where 608 | shrink xs = catMaybes (NE.nonEmpty <$> shrink (NE.toList xs)) 609 | arbitrary = do 610 | n <- choose (1, 10) 611 | NE.fromList <$> vectorOf n arbitrary 612 | 613 | instance 614 | (Arbitrary i, Arbitrary o, Ord i, Ord o) => 615 | Arbitrary (CoinSelectionData i o) 616 | where 617 | shrink (CoinSelectionData inps outs) = 618 | uncurry CoinSelectionData 619 | <$> zip 620 | (shrink inps) 621 | (coinMapFromList <$> filter (not . null) (shrink (coinMapToList outs))) 622 | arbitrary = 623 | CoinSelectionData <$> genInps <*> genOuts 624 | where 625 | -- Incorporate a bias towards being able to pay for all outputs. 626 | genInps = genCoinMap 256 627 | genOuts = genCoinMap 4 628 | 629 | genCoinMap :: forall k. (Arbitrary k, Ord k) => Int -> Gen (CoinMap k) 630 | genCoinMap maxEntryCount = do 631 | count <- choose (1, maxEntryCount) 632 | coinMapFromList <$> replicateM count genCoinMapEntry 633 | 634 | genCoinMapEntry :: forall k. (Arbitrary k) => Gen (CoinMapEntry k) 635 | genCoinMapEntry = CoinMapEntry <$> arbitrary <*> genCoin 636 | 637 | -- Generate coins with a reasonably high chance of size collisions. 638 | genCoin :: Gen Coin 639 | genCoin = unsafeCoin @Int <$> choose (1, 16) 640 | 641 | instance Arbitrary Coin where 642 | -- No Shrinking 643 | arbitrary = unsafeCoin @Int <$> choose (1, 100_000) 644 | 645 | instance (Arbitrary a) => Arbitrary (CoinMapEntry a) where 646 | -- No Shrinking 647 | arbitrary = 648 | CoinMapEntry 649 | <$> arbitrary 650 | <*> arbitrary 651 | 652 | instance (Arbitrary a, Ord a) => Arbitrary (CoinMap a) where 653 | shrink (CoinMap m) = CoinMap <$> shrink m 654 | arbitrary = do 655 | n <- 656 | oneof 657 | [ pure 0 658 | , pure 1 659 | , choose (2, 100) 660 | ] 661 | entries <- 662 | zip 663 | <$> vectorOf n arbitrary 664 | <*> vectorOf n arbitrary 665 | return $ CoinMap $ Map.fromList entries 666 | 667 | genUTxO :: [Integer] -> Gen (CoinMap InputId) 668 | genUTxO coins = do 669 | let n = length coins 670 | inps <- vectorOf n arbitrary 671 | return $ CoinMap $ Map.fromList $ zip inps (unsafeCoin <$> coins) 672 | 673 | genOutputs :: [Integer] -> Gen (CoinMap OutputId) 674 | genOutputs coins = do 675 | let n = length coins 676 | outs <- vectorOf n arbitrary 677 | return $ coinMapFromList $ zipWith CoinMapEntry outs (map unsafeCoin coins) 678 | -------------------------------------------------------------------------------- /src/test/Cardano/Test/Utilities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | 12 | {-# OPTIONS_GHC -fno-warn-orphans #-} 13 | 14 | -- | Utility functions, types, and type class instances used purely for testing. 15 | -- 16 | -- Copyright: © 2018-2024 Intersect MBO 17 | -- License: Apache-2.0 18 | -- 19 | module Cardano.Test.Utilities 20 | ( 21 | -- * Input Identifiers 22 | InputId 23 | , mkInputId 24 | , genInputId 25 | 26 | -- * Output Identifiers 27 | , OutputId 28 | , mkOutputId 29 | , genOutputId 30 | 31 | -- * Formatting 32 | , ShowFmt (..) 33 | 34 | -- * UTxO Operations 35 | , excluding 36 | , isSubsetOf 37 | , restrictedBy 38 | , restrictedTo 39 | 40 | -- * Unsafe Operations 41 | , unsafeCoin 42 | , unsafeDustThreshold 43 | , unsafeFee 44 | , unsafeFromHex 45 | 46 | ) where 47 | 48 | import Prelude 49 | 50 | import Cardano.CoinSelection 51 | ( CoinMap (..), CoinMapEntry (..), CoinSelection (..), coinMapToList ) 52 | import Cardano.CoinSelection.Fee ( DustThreshold (..), Fee (..) ) 53 | import Control.DeepSeq ( NFData (..) ) 54 | import Data.ByteArray.Encoding ( Base (Base16), convertFromBase, convertToBase ) 55 | import Data.ByteString ( ByteString ) 56 | import Data.Maybe ( fromMaybe ) 57 | import Data.Proxy ( Proxy (..) ) 58 | import Data.Set ( Set ) 59 | import Fmt ( Buildable (..), blockListF, fmt, listF, nameF ) 60 | import GHC.Generics ( Generic ) 61 | import GHC.Stack ( HasCallStack ) 62 | import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) 63 | import Internal.Coin ( Coin, coinFromIntegral ) 64 | import Numeric.Natural ( Natural ) 65 | import Test.QuickCheck ( Gen, arbitraryBoundedIntegral, vectorOf ) 66 | 67 | import qualified Data.ByteString as BS 68 | import qualified Data.Map.Strict as Map 69 | import qualified Data.Set as Set 70 | import qualified Data.Text as T 71 | import qualified Data.Text.Encoding as T 72 | import qualified Internal.Coin as C 73 | 74 | -------------------------------------------------------------------------------- 75 | -- Unique Identifiers 76 | -------------------------------------------------------------------------------- 77 | 78 | newtype UniqueId (tag :: Symbol) = UniqueId { unUniqueId :: ByteString } 79 | deriving stock (Eq, Generic, Ord) 80 | 81 | instance NFData (UniqueId tag) 82 | 83 | -- Generate a unique identifier of a given length in bytes. 84 | genUniqueId :: Int -> Gen (UniqueId tag) 85 | genUniqueId n = UniqueId . BS.pack <$> vectorOf n arbitraryBoundedIntegral 86 | 87 | instance forall tag . KnownSymbol tag => Show (UniqueId tag) where 88 | show 89 | = ((<>) (symbolVal (Proxy :: Proxy tag))) 90 | . ((<>) " ") 91 | . T.unpack 92 | . T.decodeUtf8 93 | . convertToBase Base16 94 | . unUniqueId 95 | 96 | instance KnownSymbol tag => Buildable (UniqueId tag) where 97 | build = build . show 98 | 99 | -------------------------------------------------------------------------------- 100 | -- Input Identifiers 101 | -------------------------------------------------------------------------------- 102 | 103 | type InputId = UniqueId "InputId" 104 | 105 | mkInputId :: ByteString -> InputId 106 | mkInputId = UniqueId 107 | 108 | genInputId :: Int -> Gen InputId 109 | genInputId = genUniqueId 110 | 111 | -------------------------------------------------------------------------------- 112 | -- Output Identifiers 113 | -------------------------------------------------------------------------------- 114 | 115 | type OutputId = UniqueId "OutputId" 116 | 117 | genOutputId :: Int -> Gen OutputId 118 | genOutputId = genUniqueId 119 | 120 | mkOutputId :: ByteString -> OutputId 121 | mkOutputId = UniqueId 122 | 123 | -------------------------------------------------------------------------------- 124 | -- Unsafe Operations 125 | -------------------------------------------------------------------------------- 126 | 127 | unsafeCoin :: (Integral i, Show i) => i -> Coin 128 | unsafeCoin i = fromMaybe die $ coinFromIntegral i 129 | where 130 | die = error $ mconcat 131 | [ "Test suite attempted to create a coin with negative value: " 132 | , show i 133 | ] 134 | 135 | unsafeDustThreshold :: (Integral i, Show i) => i -> DustThreshold 136 | unsafeDustThreshold i = DustThreshold $ fromMaybe die $ coinFromIntegral i 137 | where 138 | die = error $ mconcat 139 | [ "Test suite attempted to create a dust theshold with negative value: " 140 | , show i 141 | ] 142 | 143 | unsafeFee :: (Integral i, Show i) => i -> Fee 144 | unsafeFee i = Fee $ fromMaybe die $ coinFromIntegral i 145 | where 146 | die = error $ mconcat 147 | [ "Test suite attempted to create a fee with negative value: " 148 | , show i 149 | ] 150 | 151 | -- | Decode an hex-encoded 'ByteString' into raw bytes, or fail. 152 | unsafeFromHex :: HasCallStack => ByteString -> ByteString 153 | unsafeFromHex = 154 | either (error . show) id . convertFromBase @ByteString @ByteString Base16 155 | 156 | -------------------------------------------------------------------------------- 157 | -- Formatting 158 | -------------------------------------------------------------------------------- 159 | 160 | -- | A polymorphic wrapper type with a custom 'Show' instance to display data 161 | -- through 'Buildable' instances. 162 | newtype ShowFmt a = ShowFmt { unShowFmt :: a } 163 | deriving (Generic, Eq, Ord) 164 | 165 | instance NFData a => NFData (ShowFmt a) 166 | 167 | instance Buildable a => Show (ShowFmt a) where 168 | show (ShowFmt a) = fmt (build a) 169 | 170 | -------------------------------------------------------------------------------- 171 | -- UTxO Operations 172 | -------------------------------------------------------------------------------- 173 | 174 | -- | ins⋪ u 175 | excluding :: Ord u => CoinMap u -> Set u -> CoinMap u 176 | excluding (CoinMap utxo) = 177 | CoinMap . Map.withoutKeys utxo 178 | 179 | -- | a ⊆ b 180 | isSubsetOf :: Ord u => CoinMap u -> CoinMap u -> Bool 181 | isSubsetOf (CoinMap a) (CoinMap b) = 182 | a `Map.isSubmapOf` b 183 | 184 | -- | ins⊲ u 185 | restrictedBy :: Ord u => CoinMap u -> Set u -> CoinMap u 186 | restrictedBy (CoinMap utxo) = 187 | CoinMap . Map.restrictKeys utxo 188 | 189 | -- | u ⊳ outs 190 | restrictedTo :: CoinMap u -> Set Coin -> CoinMap u 191 | restrictedTo (CoinMap utxo) outs = 192 | CoinMap $ Map.filter (`Set.member` outs) utxo 193 | 194 | -------------------------------------------------------------------------------- 195 | -- Buildable Instances 196 | -------------------------------------------------------------------------------- 197 | 198 | instance Buildable Coin where 199 | build = build . fromIntegral @Natural @Integer . C.coinToIntegral 200 | 201 | instance Buildable a => Buildable (CoinMapEntry a) where 202 | build a = mempty 203 | <> build (entryKey a) 204 | <> ":" 205 | <> build (entryValue a) 206 | 207 | instance (Buildable i, Buildable o) => Buildable (CoinSelection i o) where 208 | build s = mempty 209 | <> nameF "inputs" 210 | (blockListF $ coinMapToList $ inputs s) 211 | <> nameF "outputs" 212 | (blockListF $ coinMapToList $ outputs s) 213 | <> nameF "change" 214 | (listF $ change s) 215 | -------------------------------------------------------------------------------- /src/test/Internal/CoinSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Internal.CoinSpec 5 | ( spec 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Data.Maybe ( catMaybes, fromMaybe ) 11 | import Internal.Coin ( Coin ) 12 | import Test.Hspec ( Spec, describe, it, shouldBe, shouldSatisfy ) 13 | import Test.QuickCheck 14 | ( Arbitrary (..) 15 | , NonNegative (..) 16 | , Property 17 | , checkCoverage 18 | , cover 19 | , oneof 20 | , property 21 | ) 22 | 23 | import qualified Internal.Coin as C 24 | 25 | spec :: Spec 26 | spec = do 27 | 28 | describe "Coin properties" $ do 29 | it "Only construction of non-negative values is possible." $ 30 | checkCoverage prop_construction 31 | it "Coverage of generated values is acceptable." $ 32 | checkCoverage prop_generation 33 | it "Addition" $ 34 | checkCoverage prop_add 35 | it "Multiplication" $ 36 | checkCoverage prop_mul 37 | it "Subtraction" $ 38 | checkCoverage prop_sub 39 | it "Division" $ 40 | checkCoverage prop_div 41 | it "Modulus" $ 42 | checkCoverage prop_mod 43 | it "Distance" $ 44 | checkCoverage prop_distance 45 | 46 | prop_construction 47 | :: Integer 48 | -> Property 49 | prop_construction i = property 50 | $ cover 10 (i < 0) 51 | "input is negative" 52 | $ cover 10 (i > 0) 53 | "input is positive" 54 | $ cover 2 (i == 0) 55 | "input is zero" 56 | $ if i < 0 57 | then C.coinFromIntegral i `shouldBe` Nothing 58 | else (C.coinToIntegral <$> C.coinFromIntegral i) `shouldBe` Just i 59 | 60 | prop_generation 61 | :: Coin 62 | -> Property 63 | prop_generation n = property 64 | $ cover 2 (n == C.zero) 65 | "value is zero" 66 | $ cover 2 (n == C.one) 67 | "value is one" 68 | $ cover 10 (n > C.one) 69 | "value is more than one" 70 | True 71 | 72 | prop_add :: Coin -> Coin -> Property 73 | prop_add x y = property $ 74 | C.coinToIntegral @Integer (x `C.add` y) 75 | `shouldBe` 76 | (C.coinToIntegral x + C.coinToIntegral y) 77 | 78 | prop_mul :: Coin -> Integer -> Property 79 | prop_mul x y = property 80 | $ cover 2 (y == 0) 81 | "scaling factor is zero" 82 | $ cover 8 (y < 0) 83 | "scaling factor is negative" 84 | $ cover 8 (y > 0) 85 | "scaling factor is positive" 86 | $ case (x `C.mul` y) of 87 | Nothing -> 88 | y `shouldSatisfy` (< 0) 89 | Just r -> 90 | (C.coinToIntegral x * y) `shouldBe` C.coinToIntegral @Integer r 91 | 92 | prop_sub :: Coin -> Coin -> Property 93 | prop_sub x y = property 94 | $ cover 4 (x == y) 95 | "values are equal" 96 | $ cover 8 (x < y) 97 | "x < y" 98 | $ cover 8 (x > y) 99 | "x > y" 100 | $ case x `C.sub` y of 101 | Nothing -> 102 | x `shouldSatisfy` (< y) 103 | Just r -> 104 | C.coinToIntegral x - C.coinToIntegral y 105 | `shouldBe` C.coinToIntegral @Integer r 106 | 107 | prop_div :: Coin -> Integer -> Property 108 | prop_div x y = property 109 | $ cover 2 (y == 0) 110 | "denominator is zero" 111 | $ cover 8 (y < 0) 112 | "denominator is negative" 113 | $ cover 8 (y > 0) 114 | "denominator is positive" 115 | $ case (x `C.div` y) of 116 | Nothing -> 117 | y `shouldSatisfy` (<= 0) 118 | Just r -> 119 | (C.coinToIntegral x `div` y) 120 | `shouldBe` C.coinToIntegral @Integer r 121 | 122 | prop_mod :: Coin -> Integer -> Property 123 | prop_mod x y = property 124 | $ cover 2 (y == 0) 125 | "denominator is zero" 126 | $ cover 8 (y < 0) 127 | "denominator is negative" 128 | $ cover 8 (y > 0) 129 | "denominator is positive" 130 | $ case (x `C.mod` y) of 131 | Nothing -> 132 | y `shouldSatisfy` (<= 0) 133 | Just r -> 134 | (C.coinToIntegral x `mod` y) 135 | `shouldBe` C.coinToIntegral @Integer r 136 | 137 | prop_distance :: Coin -> Coin -> Property 138 | prop_distance x y = property 139 | $ cover 4 (x == y) 140 | "values are equal" 141 | $ cover 8 (x < y) 142 | "x < y" 143 | $ cover 8 (x > y) 144 | "x > y" 145 | $ C.coinToIntegral @Integer (x `C.distance` y) 146 | `shouldBe` 147 | abs (C.coinToIntegral x - C.coinToIntegral y) 148 | 149 | instance Arbitrary Coin where 150 | arbitrary = oneof 151 | [ pure C.zero 152 | , pure C.one 153 | , somethingElse 154 | ] 155 | where 156 | somethingElse = 157 | fromMaybe C.zero 158 | . C.coinFromIntegral @Integer 159 | . getNonNegative <$> arbitrary 160 | shrink n = catMaybes 161 | $ C.coinFromIntegral @Integer <$> shrink (C.coinToIntegral @Integer n) 162 | -------------------------------------------------------------------------------- /src/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /src/test/Test/Vector/Shuffle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Test.Vector.Shuffle 5 | ( -- * Simple 6 | shuffle 7 | , shuffleNonEmpty 8 | 9 | -- * Advanced 10 | , mkSeed 11 | , shuffleWith 12 | , shuffleNonEmptyWith 13 | ) where 14 | 15 | import Prelude 16 | 17 | import Control.Monad ( forM_ ) 18 | import Control.Monad.Trans.Class ( lift ) 19 | import Control.Monad.Trans.State.Strict ( evalStateT, state ) 20 | import Crypto.Hash ( hash ) 21 | import Crypto.Hash.Algorithms ( MD5 ) 22 | import Data.List.NonEmpty ( NonEmpty (..) ) 23 | import Data.Maybe ( fromMaybe ) 24 | import Data.Text ( Text ) 25 | import Data.Vector.Mutable ( IOVector ) 26 | import Data.Word ( Word8 ) 27 | import System.Random ( RandomGen, StdGen, mkStdGen, newStdGen, randomR ) 28 | 29 | import qualified Data.ByteArray as BA 30 | import qualified Data.ByteString as BS 31 | import qualified Data.List.NonEmpty as NE 32 | import qualified Data.Text.Encoding as T 33 | import qualified Data.Vector as V 34 | import qualified Data.Vector.Mutable as MV 35 | 36 | -- | Generate a random generator seed from a text string 37 | mkSeed :: Text -> StdGen 38 | mkSeed = mkStdGen . toInt . quickHash . T.encodeUtf16LE 39 | where 40 | quickHash = BA.convert . hash @_ @MD5 41 | toInt = snd . BS.foldl' exponentiation (0,0) 42 | where 43 | exponentiation :: (Int, Int) -> Word8 -> (Int, Int) 44 | exponentiation (e, n) i = (e+1, n + fromIntegral i*2^e) 45 | 46 | -- | Shuffles a list of elements. 47 | -- 48 | -- >>> shuffle (outputs coinSel) 49 | -- [...] 50 | shuffle :: [a] -> IO [a] 51 | shuffle xs = newStdGen >>= flip shuffleWith xs 52 | 53 | -- | Like 'shuffle', but from a given seed. 'shuffle' will use a randomly 54 | -- generate seed using 'newStdGen' from @System.Random@. 55 | -- 56 | -- __Properties:__ 57 | -- 58 | -- - @shuffleWith g es == shuffleWith g es@ 59 | -- - @∃Δ> 1. g ≠g', length es > Δ⇒ shuffleWith g es ≠shuffleWith g' es@ 60 | shuffleWith :: RandomGen g => g -> [a] -> IO [a] 61 | shuffleWith seed = modifyInPlace $ \v -> flip evalStateT seed $ do 62 | let (lo, hi) = (0, MV.length v - 1) 63 | forM_ [lo .. hi] $ \i -> do 64 | j <- fromInteger <$> state (randomR (fromIntegral lo, fromIntegral hi)) 65 | lift $ swapElems v i j 66 | where 67 | swapElems :: IOVector a -> Int -> Int -> IO () 68 | swapElems v i j = do 69 | x <- MV.read v i 70 | y <- MV.read v j 71 | MV.write v i y 72 | MV.write v j x 73 | 74 | modifyInPlace :: forall a. (IOVector a -> IO ()) -> [a] -> IO [a] 75 | modifyInPlace f xs = do 76 | v' <- V.thaw $ V.fromList xs 77 | f v' 78 | V.toList <$> V.freeze v' 79 | 80 | -- | Shuffles a /non-empty/ list of elements. 81 | -- 82 | -- See 'shuffle'. 83 | -- 84 | shuffleNonEmpty :: NonEmpty a -> IO (NonEmpty a) 85 | shuffleNonEmpty xs = newStdGen >>= flip shuffleNonEmptyWith xs 86 | 87 | -- | Shuffles a /non-empty/ list of elements with the given random generator. 88 | -- 89 | -- See 'shuffleWith'. 90 | -- 91 | shuffleNonEmptyWith :: RandomGen g => g -> NonEmpty a -> IO (NonEmpty a) 92 | shuffleNonEmptyWith g = 93 | fmap (fromMaybe raiseError . NE.nonEmpty) . shuffleWith g . NE.toList 94 | where 95 | raiseError = error "shuffleNonEmptyWith encountered an empty list." 96 | -------------------------------------------------------------------------------- /src/test/Test/Vector/ShuffleSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Test.Vector.ShuffleSpec 6 | ( spec 7 | ) where 8 | 9 | import Prelude 10 | 11 | import Data.List.NonEmpty ( NonEmpty (..) ) 12 | import Test.Hspec ( Spec, describe, it ) 13 | import Test.QuickCheck 14 | ( Arbitrary (..) 15 | , Confidence (..) 16 | , NonEmptyList (..) 17 | , Positive (..) 18 | , PrintableString (..) 19 | , Property 20 | , Testable 21 | , arbitrary 22 | , checkCoverageWith 23 | , cover 24 | , genericShrink 25 | , label 26 | , vectorOf 27 | , (==>) 28 | ) 29 | import Test.QuickCheck.Monadic ( assert, monadicIO, monitor, pick, run ) 30 | import Test.Vector.Shuffle ( mkSeed, shuffle, shuffleNonEmpty, shuffleWith ) 31 | 32 | import qualified Data.List as L 33 | import qualified Data.List.NonEmpty as NE 34 | import qualified Data.Text as T 35 | 36 | spec :: Spec 37 | spec = do 38 | describe "shuffle" $ do 39 | it "every list can be shuffled, ultimately" $ 40 | check prop_shuffleCanShuffle 41 | it "shuffle is non-deterministic" $ 42 | check prop_shuffleNotDeterministic 43 | it "sort (shuffle xs) == sort xs" $ 44 | check prop_shufflePreserveElements 45 | 46 | describe "shuffleNonEmpty" $ do 47 | it "every non-empty list can be shuffled, ultimately" $ 48 | check prop_shuffleNonEmptyCanShuffle 49 | it "shuffleNonEmpty is non-deterministic" $ 50 | check prop_shuffleNonEmptyNotDeterministic 51 | it "sort (shuffleNonEmpty xs) == sort xs" $ 52 | check prop_shuffleNonEmptyPreserveElements 53 | 54 | describe "shuffleWith / mkSeed" $ do 55 | it "shuffling with the same seed is deterministic" $ 56 | check prop_shuffleWithDeterministic 57 | it "different seed means different shuffles" $ 58 | check prop_shuffleDifferentSeed 59 | 60 | where 61 | check :: forall p. Testable p => p -> Property 62 | check = checkCoverageWith lowerConfidence 63 | 64 | lowerConfidence :: Confidence 65 | lowerConfidence = Confidence (10^(6 :: Integer)) 0.75 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Properties 69 | -------------------------------------------------------------------------------- 70 | 71 | prop_shuffleCanShuffle 72 | :: NonEmptyList Int 73 | -> Property 74 | prop_shuffleCanShuffle (NonEmpty xs) = monadicIO $ run $ do 75 | xs' <- shuffle xs 76 | return $ cover 90 (xs /= xs') "shuffled" () 77 | 78 | prop_shuffleNonEmptyCanShuffle 79 | :: NonEmpty Int 80 | -> Property 81 | prop_shuffleNonEmptyCanShuffle xs = monadicIO $ run $ do 82 | xs' <- shuffleNonEmpty xs 83 | return $ cover 90 (xs /= xs') "shuffled" () 84 | 85 | prop_shuffleNotDeterministic 86 | :: NonEmptyList Int 87 | -> Property 88 | prop_shuffleNotDeterministic (NonEmpty xs) = monadicIO $ run $ do 89 | xs1 <- shuffle xs 90 | xs2 <- shuffle xs 91 | return $ cover 90 (xs1 /= xs2) "not deterministic" () 92 | 93 | prop_shuffleNonEmptyNotDeterministic 94 | :: NonEmpty Int 95 | -> Property 96 | prop_shuffleNonEmptyNotDeterministic xs = monadicIO $ run $ do 97 | xs1 <- shuffleNonEmpty xs 98 | xs2 <- shuffleNonEmpty xs 99 | return $ cover 90 (xs1 /= xs2) "not deterministic" () 100 | 101 | prop_shufflePreserveElements 102 | :: [Int] 103 | -> Property 104 | prop_shufflePreserveElements xs = monadicIO $ run $ do 105 | xs' <- shuffle xs 106 | return $ cover 90 (not $ null xs) "non-empty" (L.sort xs == L.sort xs') 107 | 108 | prop_shuffleNonEmptyPreserveElements 109 | :: NonEmpty Int 110 | -> Property 111 | prop_shuffleNonEmptyPreserveElements xs = monadicIO $ run $ do 112 | xs' <- shuffleNonEmpty xs 113 | return $ cover 90 (not $ null xs) "non-empty" (NE.sort xs == NE.sort xs') 114 | 115 | -- ∀(g :: RandomGen). 116 | -- ∀(es :: [a]). 117 | -- 118 | -- shuffleWith g es == shuffleWith g es 119 | prop_shuffleWithDeterministic 120 | :: PrintableString 121 | -> NonEmptyList Int 122 | -> Property 123 | prop_shuffleWithDeterministic (PrintableString seed) (NonEmpty xs) = 124 | monadicIO $ do 125 | ys0 <- run $ shuffleWith (mkSeed $ T.pack seed) xs 126 | ys1 <- run $ shuffleWith (mkSeed $ T.pack seed) xs 127 | monitor $ cover 90 (length xs > 1) "non singleton" 128 | assert (ys0 == ys1) 129 | 130 | -- ∀(x0 : Text, x1 : Text). g0 = mkSeed x0, g1 = mkSeed x1 131 | -- ∃(Δ: Int). 132 | -- ∀(es :: [a]). 133 | -- 134 | -- g0 ≠g1, length es > Δ⇒ shuffleWith g0 es ≠shuffleWith g1 es 135 | prop_shuffleDifferentSeed 136 | :: (PrintableString, PrintableString) 137 | -> Positive Int 138 | -> Property 139 | prop_shuffleDifferentSeed (x0, x1) (Positive len) = do 140 | x0 /= x1 ==> monadicIO $ do 141 | let g0 = mkSeed $ T.pack $ getPrintableString x0 142 | let g1 = mkSeed $ T.pack $ getPrintableString x1 143 | es <- pick $ vectorOf len (arbitrary @Int) 144 | ys0 <- run $ shuffleWith g0 es 145 | ys1 <- run $ shuffleWith g1 es 146 | monitor $ label (prettyLen es) 147 | monitor $ cover 90 (ys0 /= ys1) "different" 148 | where 149 | prettyLen :: [a] -> String 150 | prettyLen xs = case length xs of 151 | n | n <= 1 -> "singleton" 152 | n | n <= 10 -> "small list" 153 | _ -> "big list" 154 | 155 | instance Arbitrary a => Arbitrary (NonEmpty a) where 156 | arbitrary = (:|) <$> arbitrary <*> arbitrary 157 | shrink = genericShrink 158 | --------------------------------------------------------------------------------