From 8fb472f60dabb12e940f0d224599fe8a9bc0aafc Mon Sep 17 00:00:00 2001 From: JP Rupp Date: Fri, 28 Jul 2023 19:48:43 +0100 Subject: [PATCH] Backwards-incompatible modernisation of package - Shorten all field names ignoring duplicates using DuplicateRecordFields extension. - Use OverloadedRecordDot language extension and syntax. - Use explicit context object from secp256k1-haskell library. - Unify serialization into custom Marhsal and MarshalJSON classes. - Use bytestring builders for all JSON toEncoding implementations. - Use ormolu for formatting. - Simplify module organisation. - Strongly break backwards compatibility. --- CHANGELOG.md | 261 +- README.md | 3 +- ...rfc6979DERabc.json => rfc6979DERcash.json} | 0 data/{rfc6979abc.json => rfc6979cash.json} | 0 haskoin-core.cabal | 34 +- hie.yaml | 6 + package.yaml | 6 +- scripts/format | 4 +- src/Haskoin.hs | 36 +- src/Haskoin/Address.hs | 452 ++-- src/Haskoin/Address/Base58.hs | 125 +- src/Haskoin/Address/Bech32.hs | 199 +- src/Haskoin/Address/CashAddr.hs | 270 +- src/Haskoin/Block.hs | 26 +- src/Haskoin/Block/Common.hs | 573 ++--- src/Haskoin/Block/Headers.hs | 1286 +++++----- src/Haskoin/Block/Merkle.hs | 331 ++- src/Haskoin/Constants.hs | 615 ----- src/Haskoin/Crypto.hs | 28 +- src/Haskoin/Crypto/Hash.hs | 290 +-- src/Haskoin/Crypto/Keys.hs | 20 + src/Haskoin/Crypto/Keys/Common.hs | 185 ++ src/Haskoin/Crypto/Keys/Extended.hs | 1057 ++++++++ src/Haskoin/Crypto/Keys/Extended/Internal.hs | 88 + src/Haskoin/Crypto/Keys/Mnemonic.hs | 2233 +++++++++++++++++ src/Haskoin/Crypto/Signature.hs | 125 +- src/Haskoin/Data.hs | 93 - src/Haskoin/Keys.hs | 20 - src/Haskoin/Keys/Common.hs | 190 -- src/Haskoin/Keys/Extended.hs | 1084 -------- src/Haskoin/Keys/Extended/Internal.hs | 83 - src/Haskoin/Keys/Mnemonic.hs | 2233 ----------------- src/Haskoin/Network.hs | 32 +- src/Haskoin/Network/Bloom.hs | 399 +-- src/Haskoin/Network/Common.hs | 1005 ++++---- src/Haskoin/Network/Constants.hs | 582 +++++ src/Haskoin/Network/Data.hs | 89 + src/Haskoin/Network/Message.hs | 306 +-- src/Haskoin/Script.hs | 30 +- src/Haskoin/Script/Common.hs | 1031 ++++---- src/Haskoin/Script/SigHash.hs | 404 +-- src/Haskoin/Script/Standard.hs | 472 ++-- src/Haskoin/Transaction.hs | 26 +- src/Haskoin/Transaction/Builder.hs | 831 +++--- src/Haskoin/Transaction/Builder/Sign.hs | 513 ++-- src/Haskoin/Transaction/Common.hs | 515 ++-- src/Haskoin/Transaction/Genesis.hs | 56 +- src/Haskoin/Transaction/Partial.hs | 1451 +++++------ src/Haskoin/Transaction/Segwit.hs | 261 +- src/Haskoin/Transaction/Taproot.hs | 439 ++-- src/Haskoin/Util.hs | 379 +-- src/Haskoin/Util/Arbitrary.hs | 26 +- src/Haskoin/Util/Arbitrary/Address.hs | 51 +- src/Haskoin/Util/Arbitrary/Block.hs | 87 +- src/Haskoin/Util/Arbitrary/Crypto.hs | 23 +- src/Haskoin/Util/Arbitrary/Keys.hs | 94 +- src/Haskoin/Util/Arbitrary/Message.hs | 77 +- src/Haskoin/Util/Arbitrary/Network.hs | 180 +- src/Haskoin/Util/Arbitrary/Script.hs | 635 +++-- src/Haskoin/Util/Arbitrary/Transaction.hs | 410 +-- src/Haskoin/Util/Arbitrary/Util.hs | 165 +- src/Haskoin/Util/Helpers.hs | 426 ++++ src/Haskoin/Util/Marshal.hs | 44 + stack.yaml | 4 +- stack.yaml.lock | 16 +- test/Haskoin/Address/Bech32Spec.hs | 398 ++- test/Haskoin/Address/CashAddrSpec.hs | 610 +++-- test/Haskoin/AddressSpec.hs | 265 +- test/Haskoin/BlockSpec.hs | 645 +++-- test/Haskoin/Crypto/HashSpec.hs | 667 +++-- test/Haskoin/Crypto/Keys/ExtendedSpec.hs | 608 +++++ test/Haskoin/Crypto/Keys/MnemonicSpec.hs | 500 ++++ test/Haskoin/Crypto/KeysSpec.hs | 261 ++ test/Haskoin/Crypto/SignatureSpec.hs | 693 ++--- test/Haskoin/Keys/ExtendedSpec.hs | 621 ----- test/Haskoin/Keys/MnemonicSpec.hs | 498 ---- test/Haskoin/KeysSpec.hs | 266 -- test/Haskoin/NetworkSpec.hs | 230 +- test/Haskoin/ScriptSpec.hs | 727 +++--- test/Haskoin/Transaction/PartialSpec.hs | 905 +++---- test/Haskoin/Transaction/TaprootSpec.hs | 250 +- test/Haskoin/TransactionSpec.hs | 534 ++-- test/Haskoin/UtilSpec.hs | 58 +- 83 files changed, 15974 insertions(+), 15777 deletions(-) rename data/{rfc6979DERabc.json => rfc6979DERcash.json} (100%) rename data/{rfc6979abc.json => rfc6979cash.json} (100%) create mode 100644 hie.yaml delete mode 100644 src/Haskoin/Constants.hs create mode 100644 src/Haskoin/Crypto/Keys.hs create mode 100644 src/Haskoin/Crypto/Keys/Common.hs create mode 100644 src/Haskoin/Crypto/Keys/Extended.hs create mode 100644 src/Haskoin/Crypto/Keys/Extended/Internal.hs create mode 100644 src/Haskoin/Crypto/Keys/Mnemonic.hs delete mode 100644 src/Haskoin/Data.hs delete mode 100644 src/Haskoin/Keys.hs delete mode 100644 src/Haskoin/Keys/Common.hs delete mode 100644 src/Haskoin/Keys/Extended.hs delete mode 100644 src/Haskoin/Keys/Extended/Internal.hs delete mode 100644 src/Haskoin/Keys/Mnemonic.hs create mode 100644 src/Haskoin/Network/Constants.hs create mode 100644 src/Haskoin/Network/Data.hs create mode 100644 src/Haskoin/Util/Helpers.hs create mode 100644 src/Haskoin/Util/Marshal.hs create mode 100644 test/Haskoin/Crypto/Keys/ExtendedSpec.hs create mode 100644 test/Haskoin/Crypto/Keys/MnemonicSpec.hs create mode 100644 test/Haskoin/Crypto/KeysSpec.hs delete mode 100644 test/Haskoin/Keys/ExtendedSpec.hs delete mode 100644 test/Haskoin/Keys/MnemonicSpec.hs delete mode 100644 test/Haskoin/KeysSpec.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 41245b30..e744352b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,289 +1,420 @@ # Changelog + All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). -## 0.21.2 +## [1.0.0] + ### Changed + +- Shorten all field names allow duplicates, using DuplicateRecordFields extension. +- Use OverloadedRecordDot language extension and syntax. +- Use explicit context object from secp256k1-haskell library. +- Unify serialization into custom Marhsal and MarshalJSON classes. +- Use ormolu for formatting. +- Simplify module organisation. +- Strongly break backwards compatibility. + +## [0.22.0] - 2023-06-28 + +### Changed + +- Upgrade to lastest secp256k1 and base16 packages. + +## [0.21.2] - 2022-04-13 + +### Changed + - Serialisation test now works for both strict and lazy bytestrings. -## 0.21.1 +## [0.21.1] - 2021-12-13 + ### Changed + - Make Base58 faster. -## 0.21.0 +## [0.21.0] - 2022-11-23 + ### Added + - BCH Testnet4 support. ### Changed -- Use a newtype for Fingerprint, which uses an 8 digit hex string for various - instances. This fixes inconsistent (de)serialization across the package. + +- Fix inconsistent serialization/deserialization issues. ### Fixed + - Makes `finalScriptWitness` field encoding conform to bitcoin core. - Fixes bug in `finalizeTransaction` ### Added + - Signing support for PSBTs - Helper function for merging PSBTs - More PSBT tests - Partial support for taproot -## 0.20.5 +## [0.20.5] - 2021-09-13 + ### Added + - Support Bech32m address format for Taproot. -## 0.20.4 +## [0.20.4] - 2021-06-08 + ### Fixed + - Add missing case for witness version. -## 0.20.3 +## [0.20.3] - 2021-05-17 + ### Fixed + - Allow unknown inv types. -## 0.20.2 +## [0.20.2] - 2021-05-17 + ### Fixed + - Allow unknown messages of zero length. -## 0.20.1 +## [0.20.1] - 2021-05-14 + ### Fixed + - Correct case where binary search returned the wrong element. -## 0.20.0 +## [0.20.0] - 2021-02-22 + ### Chaged + - Use bytes instead of binary or cereal. -## 0.19.0 +## [0.19.0] - 2021-01-25 + ### Added + - Hashable instances for extended keys. ### Changed + - Mnemonic passphrases now `Text` instead of `ByteString`. ### Fixed + - Tests now pass for witness addresses. -## 0.18.0 +## [0.18.0] - 2020-12-10 + ### Added + - Support SegWit addresses with version other than 0. -## 0.17.6 +## [0.17.6] - 2020-12-07 + ### Added + - Serialize instances for `XPubKey` and `XPrvKey`. -## 0.17.5 +## [0.17.5] - 2020-12-03 + ### Fixed + - Handle special case in block header binary search function. -## 0.17.4 +## [0.17.4] - 2020-12-03 + ### Fixed + - Bounds check too restrictive in block header binary search function. -## 0.17.3 +## [0.17.3] - 2020-11-17 + ### Changed + - Reduce minimum version of text package dependency. -## 0.17.2 +## [0.17.2] - 2020-11-17 + ### Changed + - Update lists of seeds for all networks. -## 0.17.1 -### Changed -- Use the C-preprocessor to handle versions of `base16-bytestring` including 1.0 - (with a breaking API change) +## [0.17.1] - 2020-11-02 + +### Changed + +- Use the C-preprocessor to handle versions of `base16-bytestring` + +## [0.17.0] - 2020-10-21 -## 0.17.0 ### Added + - Support for Bitcoin Cash November 2020 hard fork. - Functions to find block headers matching arbitrary sorted attributes. ### Removed + - GenesisNode constructor for BlockNode type. -## 0.15.0 +## [0.15.0] - 2020-07-23 + ### Added + - Add more test vectors ### Changed + - stringToAddr renamed to textToAddr - Move ScriptOutput to Standard.hs - Move WIF encoding/decoding to Keys.hs -- (breaking) rename `OP_NOP2` and `OP_NOP3` to `OP_CHECKLOCKTIMEVERIFY` and - `OP_CHECKSEQUENCEVERIFY` resp. +- (breaking) rename `OP_NOP2` and `OP_NOP3` to `OP_CHECKLOCKTIMEVERIFY` and `OP_CHECKSEQUENCEVERIFY` resp. - Update to latest secp256k1 bindings. -## 0.14.1 +## [0.14.1] - 2020-06-14 + ### Fixed + - Correct some Bitcoin Cash Testnet3 seeds. - Add helpers for writing Data.Serialize and Data.Aeson identity tests -## 0.14.0 +## [0.14.0] - 2020-06-14 + ### Changed + - Expose all modules for tests. - Tests depend on library instead of having access to its source code. - Use MIT license. - Update seeds. - Bump secp256k1-haskell dependency. -## 0.13.6 +## [0.13.6] - 2020-06-05 + ### Changed + - Expose the Arbitrary test instances under Haskoin.Util.Arbitrary -## 0.13.5 +## [0.13.5] - 2020-05-16 + ### Changed + - Provide meaningful JSON instances for most types. -## 0.13.4 +## [0.13.4] - 2020-05-14 + ### Added + - Support for Bitcoin Cash May 2020 hard fork. -## 0.13.3 +## [0.13.3] - 2020-05-08 + ### Changed + - Improve code and documentation organisation. -## 0.13.2 +## [0.13.2] - 2020-05-08 + ### Changed + - Move all packages from Network.Haskoin namespace to Haskoin namespace. - Expose all top-level modules directly. -## 0.13.1 +## [0.13.1] - 2020-05-06 + ### Changed + - Faster JSON serialization. -## 0.13.0 +## [0.13.0] - 2020-05-06 + ### Changed + - Consolidate all modules in Haskoin module. ### Removed + - Deprecate Network.Haskoin namespace. - Hide QuickCheck generators in test suite. -## 0.12.0 -### Added -- Support for signing segwit transactions. +## [0.12.0] - 2020-04-10 -## 0.11.0 ### Added + +- Support for signing segwit transactions. - High-level representation of segwit v0 data and auxilliary functions. ### Changed + - Adds handling of segwit signing parameters to transaction signing code. -## 0.10.1 +## [0.10.1] - 2020-02-08 + ### Added + - Lower bound versions for some dependencies. -## 0.10.0 +## [0.10.0] - 2020-01-15 + ### Added + - DeepSeq instances for all data types. ### Changed + - There is no `SockAddr` inside `NetworkAddress` anymore. -## 0.9.8 +## [0.9.8] - 2020-01-01 + ### Added + - Ord instance for `DerivPathI` -## 0.9.7 +## [0.9.7] - 2019-12-04 + ### Added + - JSON encoding/decoding for blocks. ### Fixed + - Fix lowercase HRP test for Bech32. -## 0.9.6 +## [0.9.6] - 2019-10-29 + ### Added + - `bloomRelevantUpdate` implementation for Bloom filters (thanks to @IlyasRidhuan). ### Fixed + - Fix for Bech32 encoding (thanks to @pavel-main). -## 0.9.5 +## [0.9.5] - 2019-10-23 + ### Added + - Expose functions added in 0.9.4. -## 0.9.4 +## [0.9.4] - 2019-10-23 + ### Added + - Support for (P2SH-)P2WPKH addresses derived from extended keys. ### Changed + - Change names of backwards-compatible P2SH-P2WPKH functions from 0.9.3. -## 0.9.3 +## [0.9.3] - 2019-10-22 + ### Added + - Some support for P2WPKH-over-P2SH addresses. -## 0.9.2 +## [0.9.2] - 2019-10-09 + ### Removed + - Disable unnecessary `-O2` optimisation added in previous version. ### Added + - Allow decoding unknown P2P messages. -## 0.9.1 +## [0.9.1] - 2019-10-02 + ### Added + - Add a function to produce a structured signature over a transaction. - Enable `-O2` optimisations. -## 0.9.0 +## [0.9.0] - 2019-04-12 + ### Changed + - Address conversion to string now defined for all inputs. -## 0.8.4 -### Added -- Add reward computation to block functions. -- Add PSBT [BIP-174](https://github.com/bitcoin/bips/blob/master/bip-0174.mediawiki) types and functions +## [0.8.4] - 2018-12-05 -## 0.8.3 ### Added + +- Add reward computation to block functions. +- Add PSBT BIP-174 types and functions. + +## [0.8.3] - 2018-12-04 + +### Added + - Add reward halving interval parameter to network constants. -## 0.8.2 +## [0.8.2] - 2018-11-06 + ### Added + - Recognize `OP_CHECKDATASIG` and `OP_CHECKDATASIGVERIFY` opcodes. -## 0.8.1 +## [0.8.1] - 2018-10-13 + ### Added + - Add instances of `Hashable` and `Generic` where possible. -## 0.8.0 +## [0.8.0] - 2018-10-13 + ### Removed + - Remove `deepseq` dependency. - Remove network constant reference from address and extended keys. -## 0.7.0 +## [0.7.0] - 2018-10-13 + ### Added + - Add `Serialize` instance for network constants. - Add `Serialize` instance for addresses that includes network constants. ### Changed + - Move functions related to addresses from `Script` to `Address` module. -## 0.6.1 +## [0.6.1] - 2018-10-09 + ### Added + - Compatibility with latest GHC and base. ### Changed + - Update minimum base to 4.9. -## 0.6.0 +## [0.6.0] - 2018-10-08 + ### Changed + - Force initialization of addresses through smart constructor. - Assume addresses are always valid when instantiated in code. - Allow to provide unwrapped private keys to transaction signing functions. -## 0.5.2 +## [0.5.2] - 2018-09-10 + ### Changed + - Make dependencies more specific. -## 0.5.1 +## [0.5.1] - 2018-09-10 + ### Changed + - Remove some unneeded dependencies from `stack.yaml`. - Change `secp256k1` dependency to `secp256k1-haskell`. -## 0.5.0 +## [0.5.0] - 2018-09-09 + ### Added + - Support for Bitcoin Cash network block sychronization. - Support for Bitcoin Cash signatures. - Initial work on SegWit support. @@ -299,6 +430,7 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0. - Support for CashAddr addresses. ### Changed + - Use of hpack `package.yaml` file to auto-generate Cabal file. - Removal of dependency version limits, relying on `stack.yaml` instead. - Tests moved to `hspec`. @@ -309,6 +441,7 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0. - Target LTS Haskell 12.9. ### Removed + - Removed `.stylish-haskell.yaml` files. - Removed old `haskoin-node` and `haskoin-wallet` packages from main repository. - Removed support for non-strict signatures and related tests. diff --git a/README.md b/README.md index ef873d66..7ed8340e 100644 --- a/README.md +++ b/README.md @@ -17,4 +17,5 @@ Haskoin Core is a library of Bitcoin and Bitcoin Cash functions written in Haske ## Contributing -Please use `ormolu` (or `fourmolu`) to format code prior to submission. See `scripts/pre-commit.sh` for an example pre-commit hook. +All code is formatted with [Ormolu](https://github.com/tweag/ormolu). +Convenience formatting script available at [scripts/format](scripts/format) diff --git a/data/rfc6979DERabc.json b/data/rfc6979DERcash.json similarity index 100% rename from data/rfc6979DERabc.json rename to data/rfc6979DERcash.json diff --git a/data/rfc6979abc.json b/data/rfc6979cash.json similarity index 100% rename from data/rfc6979abc.json rename to data/rfc6979cash.json diff --git a/haskoin-core.cabal b/haskoin-core.cabal index 4cb605ee..0cef7467 100644 --- a/haskoin-core.cabal +++ b/haskoin-core.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack name: haskoin-core -version: 0.22.0 +version: 1.0.0 synopsis: Bitcoin & Bitcoin Cash library for Haskell description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -25,9 +25,9 @@ extra-source-files: data/forkid_sighash.json data/key_io_invalid.json data/key_io_valid.json - data/rfc6979abc.json + data/rfc6979cash.json data/rfc6979core.json - data/rfc6979DERabc.json + data/rfc6979DERcash.json data/rfc6979DERcore.json data/script_tests.json data/sig_nonstrict.json @@ -51,18 +51,18 @@ library Haskoin.Block.Common Haskoin.Block.Headers Haskoin.Block.Merkle - Haskoin.Constants Haskoin.Crypto Haskoin.Crypto.Hash + Haskoin.Crypto.Keys + Haskoin.Crypto.Keys.Common + Haskoin.Crypto.Keys.Extended + Haskoin.Crypto.Keys.Mnemonic Haskoin.Crypto.Signature - Haskoin.Data - Haskoin.Keys - Haskoin.Keys.Common - Haskoin.Keys.Extended - Haskoin.Keys.Mnemonic Haskoin.Network Haskoin.Network.Bloom Haskoin.Network.Common + Haskoin.Network.Constants + Haskoin.Network.Data Haskoin.Network.Message Haskoin.Script Haskoin.Script.Common @@ -87,8 +87,10 @@ library Haskoin.Util.Arbitrary.Script Haskoin.Util.Arbitrary.Transaction Haskoin.Util.Arbitrary.Util + Haskoin.Util.Helpers + Haskoin.Util.Marshal other-modules: - Haskoin.Keys.Extended.Internal + Haskoin.Crypto.Keys.Extended.Internal hs-source-dirs: src build-depends: @@ -114,7 +116,7 @@ library , network >=3.1.1.1 , safe >=0.3.18 , scientific >=0.3.6.2 - , secp256k1-haskell >=0.7.0 + , secp256k1-haskell >=1.0.0 , split >=0.2.3.3 , string-conversions >=0.4.0.1 , text >=1.2.3.0 @@ -133,10 +135,10 @@ test-suite spec Haskoin.AddressSpec Haskoin.BlockSpec Haskoin.Crypto.HashSpec + Haskoin.Crypto.Keys.ExtendedSpec + Haskoin.Crypto.Keys.MnemonicSpec + Haskoin.Crypto.KeysSpec Haskoin.Crypto.SignatureSpec - Haskoin.Keys.ExtendedSpec - Haskoin.Keys.MnemonicSpec - Haskoin.KeysSpec Haskoin.NetworkSpec Haskoin.ScriptSpec Haskoin.Transaction.PartialSpec @@ -174,7 +176,7 @@ test-suite spec , network >=3.1.1.1 , safe >=0.3.18 , scientific >=0.3.6.2 - , secp256k1-haskell >=0.7.0 + , secp256k1-haskell >=1.0.0 , split >=0.2.3.3 , string-conversions >=0.4.0.1 , text >=1.2.3.0 diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 00000000..2d8ed362 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./src" + component: haskoin-core:lib + - path: "./test" + component: haskoin-core:test:spec \ No newline at end of file diff --git a/package.yaml b/package.yaml index 01ea5152..3a794544 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: haskoin-core -version: 0.22.0 +version: 1.0.0 synopsis: Bitcoin & Bitcoin Cash library for Haskell description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -41,7 +41,7 @@ dependencies: - split >= 0.2.3.3 - safe >= 0.3.18 - scientific >= 0.3.6.2 - - secp256k1-haskell >= 0.7.0 + - secp256k1-haskell >= 1.0.0 - string-conversions >= 0.4.0.1 - text >= 1.2.3.0 - time >= 1.9.3 @@ -51,7 +51,7 @@ dependencies: library: source-dirs: src other-modules: - Haskoin.Keys.Extended.Internal + Haskoin.Crypto.Keys.Extended.Internal when: - condition: false other-modules: Paths_haskoin_core diff --git a/scripts/format b/scripts/format index 012974fb..a6afafe3 100755 --- a/scripts/format +++ b/scripts/format @@ -1,4 +1,4 @@ #!/usr/bin/env bash -find src -type f -name "*.hs" | xargs fourmolu -i -find test -type f -name "*.hs" | xargs fourmolu -i +find src -type f -name "*.hs" | xargs ormolu -i +find test -type f -name "*.hs" | xargs ormolu -i diff --git a/src/Haskoin.hs b/src/Haskoin.hs index 6feb41b3..965e2513 100644 --- a/src/Haskoin.hs +++ b/src/Haskoin.hs @@ -1,34 +1,28 @@ -{- | -Module : Haskoin -Description : Bitcoin (BTC/BCH) Libraries for Haskell -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module exports almost all of Haskoin Core, excluding only a few highly -specialized address and block-related functions. --} -module Haskoin ( - module Data, - module Constants, - module Address, +-- | +-- Module : Haskoin +-- Description : Bitcoin (BTC/BCH) Libraries for Haskell +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- This module exports almost all of Haskoin Core, excluding only a few highly +-- specialized address and block-related functions. +module Haskoin + ( module Address, module Block, module Transaction, module Script, - module Keys, module Crypto, module Network, module Util, -) where + ) +where import Haskoin.Address as Address import Haskoin.Block as Block -import Haskoin.Constants as Constants import Haskoin.Crypto as Crypto -import Haskoin.Data as Data -import Haskoin.Keys as Keys import Haskoin.Network as Network import Haskoin.Script as Script import Haskoin.Transaction as Transaction diff --git a/src/Haskoin/Address.hs b/src/Haskoin/Address.hs index c0ee8ed8..8cfb7f6a 100644 --- a/src/Haskoin/Address.hs +++ b/src/Haskoin/Address.hs @@ -1,22 +1,26 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Address -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Base58, CashAddr, Bech32 address and WIF private key serialization support. --} -module Haskoin.Address ( - -- * Addresses +-- | +-- Module : Haskoin.Address +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Base58, CashAddr, Bech32 address and WIF private key serialization support. +module Haskoin.Address + ( -- * Addresses Address (..), isPubKeyAddress, isScriptAddress, @@ -28,9 +32,6 @@ module Haskoin.Address ( bech32ToAddr, cashToAddr, base58ToAddr, - addrToJSON, - addrToEncoding, - addrFromJSON, pubKeyAddr, pubKeyWitnessAddr, pubKeyCompatWitnessAddr, @@ -51,248 +52,241 @@ module Haskoin.Address ( module Haskoin.Address.Base58, module Haskoin.Address.Bech32, module Haskoin.Address.CashAddr, -) where + ) +where -import Control.Applicative +import Control.Applicative (Alternative ((<|>))) import Control.Arrow (second) -import Control.DeepSeq -import Control.Monad -import Data.Aeson as A -import Data.Aeson.Encoding as A -import Data.Aeson.Types +import Control.DeepSeq (NFData) +import Control.Monad ((<=<)) +import Crypto.Secp256k1 +import Data.Aeson (ToJSON (toJSON), Value, withText) +import Data.Aeson.Encoding (Encoding, null_, text) +import Data.Aeson.Types (Encoding, Parser, ToJSON (toJSON), Value, withText) import Data.Binary (Binary (..)) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Hashable -import Data.Maybe +import Data.ByteString qualified as B +import Data.Bytes.Get (MonadGet (getByteString, getWord64be, getWord8), runGetS) +import Data.Bytes.Put (MonadPut (putByteString, putWord64be, putWord8), runPutS) +import Data.Bytes.Serial (Serial (..)) +import Data.Hashable (Hashable) +import Data.Maybe (isNothing) import Data.Serialize (Serialize (..)) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Word (Word8) import GHC.Generics (Generic) import Haskoin.Address.Base58 import Haskoin.Address.Bech32 import Haskoin.Address.CashAddr -import Haskoin.Crypto -import Haskoin.Data -import Haskoin.Keys.Common -import Haskoin.Script +import Haskoin.Crypto.Hash +import Haskoin.Crypto.Keys.Common +import Haskoin.Network.Data +import Haskoin.Script.Common +import Haskoin.Script.Standard import Haskoin.Util -- | Address format for Bitcoin and Bitcoin Cash. data Address - = -- | pay to public key hash (regular) - PubKeyAddress - { -- | RIPEMD160 hash of public key's SHA256 hash - getAddrHash160 :: !Hash160 - } - | -- | pay to script hash - ScriptAddress - { -- | RIPEMD160 hash of script's SHA256 hash - getAddrHash160 :: !Hash160 - } - | -- | pay to witness public key hash - WitnessPubKeyAddress - { -- | RIPEMD160 hash of public key's SHA256 hash - getAddrHash160 :: !Hash160 - } - | -- | pay to witness script hash - WitnessScriptAddress - { -- | HASH256 hash of script - getAddrHash256 :: !Hash256 - } - | -- | other witness address - WitnessAddress - { getAddrVersion :: !Word8 - , getAddrData :: !ByteString - } - deriving - (Eq, Ord, Generic, Show, Read, Hashable, NFData) + = -- | pay to public key hash (regular) + PubKeyAddress + { -- | RIPEMD160 hash of public key's SHA256 hash + hash160 :: !Hash160 + } + | -- | pay to script hash + ScriptAddress + { -- | RIPEMD160 hash of script's SHA256 hash + hash160 :: !Hash160 + } + | -- | pay to witness public key hash + WitnessPubKeyAddress + { -- | RIPEMD160 hash of public key's SHA256 hash + hash160 :: !Hash160 + } + | -- | pay to witness script hash + WitnessScriptAddress + { -- | HASH256 hash of script + hash256 :: !Hash256 + } + | -- | other witness address + WitnessAddress + { version :: !Word8, + bytes :: !ByteString + } + deriving + (Eq, Ord, Generic, Show, Read, Hashable, NFData) instance Serial Address where - serialize (PubKeyAddress k) = do - putWord8 0x00 - serialize k - serialize (ScriptAddress s) = do - putWord8 0x01 - serialize s - serialize (WitnessPubKeyAddress h) = do - putWord8 0x02 - serialize h - serialize (WitnessScriptAddress s) = do - putWord8 0x03 - serialize s - serialize (WitnessAddress v d) = do - putWord8 0x04 - putWord8 v - putWord64be (fromIntegral (B.length d)) - putByteString d + serialize (PubKeyAddress k) = do + putWord8 0x00 + serialize k + serialize (ScriptAddress s) = do + putWord8 0x01 + serialize s + serialize (WitnessPubKeyAddress h) = do + putWord8 0x02 + serialize h + serialize (WitnessScriptAddress s) = do + putWord8 0x03 + serialize s + serialize (WitnessAddress v d) = do + putWord8 0x04 + putWord8 v + putWord64be (fromIntegral (B.length d)) + putByteString d - deserialize = - getWord8 >>= \case - 0x00 -> PubKeyAddress <$> deserialize - 0x01 -> ScriptAddress <$> deserialize - 0x02 -> WitnessPubKeyAddress <$> deserialize - 0x03 -> WitnessScriptAddress <$> deserialize - 0x04 -> - WitnessAddress <$> getWord8 - <*> (getByteString . fromIntegral =<< getWord64be) - b -> - fail . T.unpack $ - "Could not decode address type byte: " - <> encodeHex (B.singleton b) + deserialize = + getWord8 >>= \case + 0x00 -> PubKeyAddress <$> deserialize + 0x01 -> ScriptAddress <$> deserialize + 0x02 -> WitnessPubKeyAddress <$> deserialize + 0x03 -> WitnessScriptAddress <$> deserialize + 0x04 -> + WitnessAddress + <$> getWord8 + <*> (getByteString . fromIntegral =<< getWord64be) + b -> + fail . T.unpack $ + "Could not decode address type byte: " + <> encodeHex (B.singleton b) instance Serialize Address where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary Address where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | 'Address' pays to a public key hash. isPubKeyAddress :: Address -> Bool -isPubKeyAddress PubKeyAddress{} = True +isPubKeyAddress PubKeyAddress {} = True isPubKeyAddress _ = False -- | 'Address' pays to a script hash. isScriptAddress :: Address -> Bool -isScriptAddress ScriptAddress{} = True +isScriptAddress ScriptAddress {} = True isScriptAddress _ = False -{- | 'Address' pays to a witness public key hash. Only valid for SegWit - networks. --} +-- | 'Address' pays to a witness public key hash. Only valid for SegWit +-- networks. isWitnessPubKeyAddress :: Address -> Bool -isWitnessPubKeyAddress WitnessPubKeyAddress{} = True +isWitnessPubKeyAddress WitnessPubKeyAddress {} = True isWitnessPubKeyAddress _ = False isWitnessScriptAddress :: Address -> Bool -isWitnessScriptAddress WitnessScriptAddress{} = True +isWitnessScriptAddress WitnessScriptAddress {} = True isWitnessScriptAddress _ = False isWitnessAddress :: Address -> Bool -isWitnessAddress WitnessAddress{} = True +isWitnessAddress WitnessAddress {} = True isWitnessAddress _ = False -addrToJSON :: Network -> Address -> Value -addrToJSON net a = toJSON (addrToText net a) - -addrToEncoding :: Network -> Address -> Encoding -addrToEncoding net = maybe null_ text . addrToText net - -{- | JSON parsing for Bitcoin addresses. Works with 'Base58', 'CashAddr' and - 'Bech32'. --} -addrFromJSON :: Network -> Value -> Parser Address -addrFromJSON net = +instance MarshalJSON Network Address where + marshalValue net a = toJSON (addrToText net a) + marshalEncoding net = maybe null_ text . addrToText net + unmarshalValue net = withText "address" $ \t -> - case textToAddr net t of - Nothing -> fail "could not decode address" - Just x -> return x + case textToAddr net t of + Nothing -> fail "could not decode address" + Just x -> return x -{- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or - 'CashAddr' depending on network. --} +-- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or +-- 'CashAddr' depending on network. addrToText :: Network -> Address -> Maybe Text -addrToText net a@PubKeyAddress{getAddrHash160 = h} - | isNothing (getCashAddrPrefix net) = - Just . encodeBase58Check . runPutS $ base58put net a - | otherwise = cashAddrEncode net 0 (runPutS $ serialize h) -addrToText net a@ScriptAddress{getAddrHash160 = h} - | isNothing (getCashAddrPrefix net) = - Just . encodeBase58Check . runPutS $ base58put net a - | otherwise = - cashAddrEncode net 1 (runPutS $ serialize h) -addrToText net WitnessPubKeyAddress{getAddrHash160 = h} = do - hrp <- getBech32Prefix net - segwitEncode hrp 0 (B.unpack (runPutS $ serialize h)) -addrToText net WitnessScriptAddress{getAddrHash256 = h} = do - hrp <- getBech32Prefix net - segwitEncode hrp 0 (B.unpack (runPutS $ serialize h)) -addrToText net WitnessAddress{getAddrVersion = v, getAddrData = d} = do - hrp <- getBech32Prefix net - segwitEncode hrp v (B.unpack d) +addrToText net a@PubKeyAddress {hash160 = h} + | isNothing net.cashAddrPrefix = + Just . encodeBase58Check . runPutS $ base58put net a + | otherwise = cashAddrEncode net 0 (runPutS $ serialize h) +addrToText net a@ScriptAddress {hash160 = h} + | isNothing net.cashAddrPrefix = + Just . encodeBase58Check . runPutS $ base58put net a + | otherwise = + cashAddrEncode net 1 (runPutS $ serialize h) +addrToText net WitnessPubKeyAddress {hash160 = h} = do + hrp <- net.bech32Prefix + segwitEncode hrp 0 (B.unpack (runPutS $ serialize h)) +addrToText net WitnessScriptAddress {hash256 = h} = do + hrp <- net.bech32Prefix + segwitEncode hrp 0 (B.unpack (runPutS $ serialize h)) +addrToText net WitnessAddress {version = v, bytes = d} = do + hrp <- net.bech32Prefix + segwitEncode hrp v (B.unpack d) -- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network. textToAddr :: Network -> Text -> Maybe Address textToAddr net txt = - cashToAddr net txt <|> bech32ToAddr net txt <|> base58ToAddr net txt + cashToAddr net txt <|> bech32ToAddr net txt <|> base58ToAddr net txt cashToAddr :: Network -> Text -> Maybe Address cashToAddr net txt = do - (ver, bs) <- cashAddrDecode net txt - case ver of - 0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs) - 1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs) - _ -> Nothing + (ver, bs) <- cashAddrDecode net txt + case ver of + 0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs) + 1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs) + _ -> Nothing bech32ToAddr :: Network -> Text -> Maybe Address bech32ToAddr net txt = do - hrp <- getBech32Prefix net - (ver, bs) <- second B.pack <$> segwitDecode hrp txt - case ver of - 0 -> case B.length bs of - 20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs) - 32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs) - _ -> Nothing - _ -> Just $ WitnessAddress ver bs + hrp <- net.bech32Prefix + (ver, bs) <- second B.pack <$> segwitDecode hrp txt + case ver of + 0 -> case B.length bs of + 20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs) + 32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs) + _ -> Nothing + _ -> Just $ WitnessAddress ver bs base58ToAddr :: Network -> Text -> Maybe Address base58ToAddr net txt = - eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt + eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt -base58get :: MonadGet m => Network -> m Address +base58get :: (MonadGet m) => Network -> m Address base58get net = do - pfx <- getWord8 - addr <- deserialize - f pfx addr + pfx <- getWord8 + addr <- deserialize + f pfx addr where f x a - | x == getAddrPrefix net = return $ PubKeyAddress a - | x == getScriptPrefix net = return $ ScriptAddress a - | otherwise = fail "Does not recognize address prefix" + | x == net.addrPrefix = return $ PubKeyAddress a + | x == net.scriptPrefix = return $ ScriptAddress a + | otherwise = fail "Does not recognize address prefix" -base58put :: MonadPut m => Network -> Address -> m () +base58put :: (MonadPut m) => Network -> Address -> m () base58put net (PubKeyAddress h) = do - putWord8 (getAddrPrefix net) - serialize h + putWord8 net.addrPrefix + serialize h base58put net (ScriptAddress h) = do - putWord8 (getScriptPrefix net) - serialize h + putWord8 net.scriptPrefix + serialize h base58put _ _ = error "Cannot serialize this address as Base58" -- | Obtain a standard pay-to-public-key-hash address from a public key. -pubKeyAddr :: PubKeyI -> Address -pubKeyAddr = PubKeyAddress . addressHash . runPutS . serialize +pubKeyAddr :: Ctx -> PublicKey -> Address +pubKeyAddr ctx = PubKeyAddress . addressHash . marshal ctx -- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'. p2pkhAddr :: Hash160 -> Address p2pkhAddr = PubKeyAddress -{- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a - public key. --} -pubKeyWitnessAddr :: PubKeyI -> Address -pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . runPutS . serialize +-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a +-- public key. +pubKeyWitnessAddr :: Ctx -> PublicKey -> Address +pubKeyWitnessAddr ctx = + WitnessPubKeyAddress . addressHash . marshal ctx -- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key. -pubKeyCompatWitnessAddr :: PubKeyI -> Address -pubKeyCompatWitnessAddr = - p2shAddr - . addressHash - . encodeOutputBS - . PayWitnessPKHash - . addressHash - . runPutS - . serialize +pubKeyCompatWitnessAddr :: Ctx -> PublicKey -> Address +pubKeyCompatWitnessAddr ctx = + p2shAddr + . addressHash + . marshal ctx + . PayWitnessPKHash + . addressHash + . marshal ctx -{- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a - 'Hash160'. --} +-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a +-- 'Hash160'. p2wpkhAddr :: Hash160 -> Address p2wpkhAddr = WitnessPubKeyAddress @@ -305,66 +299,68 @@ p2wshAddr :: Hash256 -> Address p2wshAddr = WitnessScriptAddress -- | Compute a standard pay-to-script-hash (P2SH) address for an output script. -payToScriptAddress :: ScriptOutput -> Address -payToScriptAddress = p2shAddr . addressHash . encodeOutputBS +payToScriptAddress :: Ctx -> ScriptOutput -> Address +payToScriptAddress ctx = p2shAddr . addressHash . marshal ctx -{- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output - script. --} -payToWitnessScriptAddress :: ScriptOutput -> Address -payToWitnessScriptAddress = p2wshAddr . sha256 . encodeOutputBS +-- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output +-- script. +payToWitnessScriptAddress :: Ctx -> ScriptOutput -> Address +payToWitnessScriptAddress ctx = p2wshAddr . sha256 . marshal ctx -- | Compute a backwards-compatible SegWit P2SH-P2WSH address. -payToNestedScriptAddress :: ScriptOutput -> Address -payToNestedScriptAddress = - p2shAddr . addressHash . encodeOutputBS . toP2WSH . encodeOutput +payToNestedScriptAddress :: Ctx -> ScriptOutput -> Address +payToNestedScriptAddress ctx = + p2shAddr . addressHash . marshal ctx . toP2WSH . encodeOutput ctx -{- | Encode an output script from an address. Will fail if using a - pay-to-witness address on a non-SegWit network. --} +-- | Encode an output script from an address. Will fail if using a +-- pay-to-witness address on a non-SegWit network. addressToOutput :: Address -> ScriptOutput addressToOutput = - \case - PubKeyAddress h -> PayPKHash h - ScriptAddress h -> PayScriptHash h - WitnessPubKeyAddress h -> PayWitnessPKHash h - WitnessScriptAddress h -> PayWitnessScriptHash h - WitnessAddress v d -> PayWitness v d + \case + PubKeyAddress h -> PayPKHash h + ScriptAddress h -> PayScriptHash h + WitnessPubKeyAddress h -> PayWitnessPKHash h + WitnessScriptAddress h -> PayWitnessScriptHash h + WitnessAddress v d -> PayWitness v d -- | Get output script AST for an 'Address'. -addressToScript :: Address -> Script -addressToScript = encodeOutput . addressToOutput +addressToScript :: Ctx -> Address -> Script +addressToScript ctx = encodeOutput ctx . addressToOutput -- | Encode address as output script in 'ByteString' form. -addressToScriptBS :: Address -> ByteString -addressToScriptBS = runPutS . serialize . addressToScript +addressToScriptBS :: Ctx -> Address -> ByteString +addressToScriptBS ctx = runPutS . serialize . addressToScript ctx -- | Decode an output script into an 'Address' if it has such representation. -scriptToAddress :: Script -> Either String Address -scriptToAddress = - maybeToEither "Could not decode address" . outputAddress <=< decodeOutput +scriptToAddress :: Ctx -> Script -> Either String Address +scriptToAddress ctx = + maybeToEither e . outputAddress ctx <=< decodeOutput ctx + where + e = "Could not decode address" -- | Decode a serialized script into an 'Address'. -scriptToAddressBS :: ByteString -> Either String Address -scriptToAddressBS = - maybeToEither "Could not decode address" . outputAddress <=< decodeOutputBS +scriptToAddressBS :: Ctx -> ByteString -> Either String Address +scriptToAddressBS ctx = + maybeToEither e . outputAddress ctx <=< unmarshal ctx + where + e = "Could not decode address" -- | Get the 'Address' of a 'ScriptOutput'. -outputAddress :: ScriptOutput -> Maybe Address -outputAddress = - \case - PayPKHash h -> Just $ PubKeyAddress h - PayScriptHash h -> Just $ ScriptAddress h - PayPK k -> Just $ pubKeyAddr k - PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h - PayWitnessScriptHash h -> Just $ WitnessScriptAddress h - PayWitness v d -> Just $ WitnessAddress v d - _ -> Nothing +outputAddress :: Ctx -> ScriptOutput -> Maybe Address +outputAddress ctx = + \case + PayPKHash h -> Just $ PubKeyAddress h + PayScriptHash h -> Just $ ScriptAddress h + PayPK k -> Just $ pubKeyAddr ctx k + PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h + PayWitnessScriptHash h -> Just $ WitnessScriptAddress h + PayWitness v d -> Just $ WitnessAddress v d + _ -> Nothing -- | Infer the 'Address' of a 'ScriptInput'. -inputAddress :: ScriptInput -> Maybe Address -inputAddress = - \case - (RegularInput (SpendPKHash _ key)) -> Just $ pubKeyAddr key - (ScriptHashInput _ rdm) -> Just $ payToScriptAddress rdm - _ -> Nothing +inputAddress :: Ctx -> ScriptInput -> Maybe Address +inputAddress ctx = + \case + (RegularInput (SpendPKHash _ key)) -> Just $ pubKeyAddr ctx key + (ScriptHashInput _ rdm) -> Just $ payToScriptAddress ctx rdm + _ -> Nothing diff --git a/src/Haskoin/Address/Base58.hs b/src/Haskoin/Address/Base58.hs index 951aa128..7cda8779 100644 --- a/src/Haskoin/Address/Base58.hs +++ b/src/Haskoin/Address/Base58.hs @@ -1,41 +1,43 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Address.Base58 -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit -(BTC) and CashAddr for Bitcoin Cash (BCH). --} -module Haskoin.Address.Base58 ( - -- * Base58 +-- | +-- Module : Haskoin.Address.Base58 +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit +-- (BTC) and CashAddr for Bitcoin Cash (BCH). +module Haskoin.Address.Base58 + ( -- * Base58 Base58, encodeBase58, decodeBase58, encodeBase58Check, decodeBase58Check, -) where + ) +where -import Control.Monad -import Data.Array +import Control.Monad (guard) +import Data.Array (Array, assocs, listArray, (!), (//)) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Char +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as C +import Data.Bytes.Get () +import Data.Bytes.Put (runPutS) +import Data.Bytes.Serial (Serial (serialize)) +import Data.Char (chr, ord) import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.String.Conversions (cs) import Data.Text (Text) -import qualified Data.Text as T -import Data.Word -import Haskoin.Crypto.Hash -import Haskoin.Util +import Data.Text qualified as T +import Data.Word (Word8) +import Haskoin.Crypto.Hash (checkSum32) +import Haskoin.Util.Helpers (bsToInteger, integerToBS) import Numeric (readInt, showIntAtBase) -- | 'Base58' classic Bitcoin address format. @@ -46,16 +48,19 @@ b58Data :: ByteString b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" b58Array :: Array Int Word8 -b58Array = listArray (0, 57) (BS.unpack b58Data) +b58Array = listArray (0, 57) (B.unpack b58Data) b58InvArray :: Array Word8 (Maybe Int) -b58InvArray = listArray (minBound, maxBound) (repeat Nothing) // map swap (assocs b58Array) +b58InvArray = + listArray + (minBound, maxBound) + (repeat Nothing) + // map swap (assocs b58Array) where swap (i, c) = (c, Just i) -{- | Convert a number less than or equal to provided integer into a 'Base58' - character. --} +-- | Convert a number less than or equal to provided integer into a 'Base58' +-- character. b58 :: Int -> Word8 b58 = (b58Array !) @@ -63,62 +68,58 @@ b58 = (b58Array !) b58' :: Word8 -> Maybe Int b58' = (b58InvArray !) -{- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes - will not be part of the resulting string. --} +-- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes +-- will not be part of the resulting string. encodeBase58I :: Integer -> Base58 encodeBase58I i = cs $ showIntAtBase 58 (chr . fromIntegral . b58) i "" -- | Decode a 'Base58' string into an arbitrary-length 'Integer'. decodeBase58I :: Base58 -> Maybe Integer decodeBase58I s = - case go of - Just (r, []) -> Just r - _ -> Nothing + case go of + Just (r, []) -> Just r + _ -> Nothing where p = isJust . b58' . fromIntegral . ord f = fromMaybe e . b58' . fromIntegral . ord go = listToMaybe $ readInt 58 p f (cs s) e = error "Could not decode base58" -{- | Encode an arbitrary 'ByteString' into a its 'Base58' representation, - preserving leading zeroes. --} +-- | Encode an arbitrary 'ByteString' into a its 'Base58' representation, +-- preserving leading zeroes. encodeBase58 :: ByteString -> Base58 encodeBase58 bs = - l <> r + l <> r where - (z, b) = BS.span (== 0) bs - l = cs $ BS.replicate (BS.length z) (b58 0) -- preserve leading 0's + (z, b) = B.span (== 0) bs + l = cs $ B.replicate (B.length z) (b58 0) -- preserve leading 0's r - | BS.null b = T.empty - | otherwise = encodeBase58I $ bsToInteger b + | B.null b = T.empty + | otherwise = encodeBase58I $ bsToInteger b -- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'. decodeBase58 :: Base58 -> Maybe ByteString decodeBase58 t = - BS.append prefix <$> r + B.append prefix <$> r where - (z, b) = BS.span (== b58 0) (cs t) - prefix = BS.replicate (BS.length z) 0 -- preserve leading 1's + (z, b) = B.span (== b58 0) (cs t) + prefix = B.replicate (B.length z) 0 -- preserve leading 1's r - | BS.null b = Just BS.empty - | otherwise = integerToBS <$> decodeBase58I (cs b) + | B.null b = Just B.empty + | otherwise = integerToBS <$> decodeBase58I (cs b) -{- | Computes a checksum for the input 'ByteString' and encodes the input and - the checksum as 'Base58'. --} +-- | Computes a checksum for the input 'ByteString' and encodes the input and +-- the checksum as 'Base58'. encodeBase58Check :: ByteString -> Base58 encodeBase58Check bs = - encodeBase58 $ BS.append bs $ runPutS $ serialize $ checkSum32 bs + (encodeBase58 . B.append bs . runPutS . serialize . checkSum32) bs -{- | Decode a 'Base58'-encoded string that contains a checksum. This function - returns 'Nothing' if the input string contains invalid 'Base58' characters or - if the checksum fails. --} +-- | Decode a 'Base58'-encoded string that contains a checksum. This function +-- returns 'Nothing' if the input string contains invalid 'Base58' characters or +-- if the checksum fails. decodeBase58Check :: Base58 -> Maybe ByteString decodeBase58Check bs = do - rs <- decodeBase58 bs - let (res, chk) = BS.splitAt (BS.length rs - 4) rs - guard $ chk == runPutS (serialize (checkSum32 res)) - return res + rs <- decodeBase58 bs + let (res, chk) = B.splitAt (B.length rs - 4) rs + guard $ chk == (runPutS . serialize . checkSum32) res + return res diff --git a/src/Haskoin/Address/Bech32.hs b/src/Haskoin/Address/Bech32.hs index 021da7f5..8e1174d7 100644 --- a/src/Haskoin/Address/Bech32.hs +++ b/src/Haskoin/Address/Bech32.hs @@ -1,19 +1,20 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Address.Base58 -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Support for Bitcoin SegWit (BTC) Bech32 addresses. This module is a modified -version of Marko Bencun's reference implementation. --} -module Haskoin.Address.Bech32 ( - -- * Bech32 +-- | +-- Module : Haskoin.Address.Base58 +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Support for Bitcoin SegWit (BTC) Bech32 addresses. This module is a modified +-- version of Marko Bencun's reference implementation. +module Haskoin.Address.Bech32 + ( -- * Bech32 HRP, Bech32, Bech32Encoding (..), @@ -28,38 +29,39 @@ module Haskoin.Address.Bech32 ( Word5 (..), word5, fromWord5, -) where + ) +where import Control.Monad (guard) -import Data.Array ( - Array, +import Data.Array + ( Array, assocs, bounds, listArray, (!), (//), - ) -import Data.Bits ( - Bits, + ) +import Data.Bits + ( Bits, testBit, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.), - ) -import qualified Data.ByteString as B + ) +import Data.ByteString qualified as B import Data.Char (toUpper) import Data.Foldable (foldl') import Data.Functor.Identity (Identity, runIdentity) import Data.Ix (Ix (..)) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E +import Data.Text qualified as T +import Data.Text.Encoding qualified as E import Data.Word (Word8) data Bech32Encoding = Bech32 | Bech32m - deriving (Eq, Show, Ord, Enum) + deriving (Eq, Show, Ord, Enum) -- | Bech32 human-readable string. type Bech32 = Text @@ -70,28 +72,28 @@ type HRP = Text -- | Data part of 'Bech32' address. type Data = [Word8] -(.>>.), (.<<.) :: Bits a => a -> Int -> a +(.>>.), (.<<.) :: (Bits a) => a -> Int -> a (.>>.) = unsafeShiftR (.<<.) = unsafeShiftL -- | Five-bit word for Bech32. newtype Word5 - = UnsafeWord5 Word8 - deriving (Eq, Ord) + = UnsafeWord5 Word8 + deriving (Eq, Ord) instance Ix Word5 where - range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n) - index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i - inRange (m, n) i = m <= i && i <= n + range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n) + index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i + inRange (m, n) i = m <= i && i <= n -- | Convert an integer number into a five-bit word. -word5 :: Integral a => a -> Word5 +word5 :: (Integral a) => a -> Word5 word5 x = UnsafeWord5 (fromIntegral x .&. 31) {-# INLINE word5 #-} {-# SPECIALIZE INLINE word5 :: Word8 -> Word5 #-} -- | Convert a five-bit word into a number. -fromWord5 :: Num a => Word5 -> a +fromWord5 :: (Num a) => Word5 -> a fromWord5 (UnsafeWord5 x) = fromIntegral x {-# INLINE fromWord5 #-} {-# SPECIALIZE INLINE fromWord5 :: Word5 -> Word8 #-} @@ -99,13 +101,13 @@ fromWord5 (UnsafeWord5 x) = fromIntegral x -- | 'Bech32' character map as array of five-bit integers to character. charset :: Array Word5 Char charset = - listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l" + listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l" -- | Convert a character to its five-bit value from 'Bech32' 'charset'. charsetMap :: Char -> Maybe Word5 charsetMap c - | inRange (bounds inv) upperC = inv ! upperC - | otherwise = Nothing + | inRange (bounds inv) upperC = inv ! upperC + | otherwise = Nothing where upperC = toUpper c inv = listArray ('0', 'Z') (repeat Nothing) // map swap (assocs charset) @@ -116,19 +118,18 @@ bech32Polymod :: [Word5] -> Word bech32Polymod values = foldl' go 1 values .&. 0x3fffffff where go chk value = - foldl' xor chk' [g | (g, i) <- zip generator [25 ..], testBit chk i] + foldl' xor chk' [g | (g, i) <- zip generator [25 ..], testBit chk i] where generator = [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3] chk' = chk .<<. 5 `xor` fromWord5 value -{- | Convert human-readable part of 'Bech32' string into a list of five-bit - words. --} +-- | Convert human-readable part of 'Bech32' string into a list of five-bit +-- words. bech32HRPExpand :: HRP -> [Word5] bech32HRPExpand hrp = - map (UnsafeWord5 . (.>>. 5)) hrpBytes - ++ [UnsafeWord5 0] - ++ map word5 hrpBytes + map (UnsafeWord5 . (.>>. 5)) hrpBytes + ++ [UnsafeWord5 0] + ++ map word5 hrpBytes where hrpBytes = B.unpack $ E.encodeUtf8 hrp @@ -147,49 +148,47 @@ bech32CreateChecksum enc hrp dat = [word5 (polymod .>>. i) | i <- [25, 20 .. 0]] -- | Verify Bech32 checksum for a human-readable part and string of five-bit words. bech32VerifyChecksum :: HRP -> [Word5] -> Maybe Bech32Encoding bech32VerifyChecksum hrp dat = - let poly = bech32Polymod (bech32HRPExpand hrp ++ dat) - in if - | poly == bech32Const Bech32 -> Just Bech32 - | poly == bech32Const Bech32m -> Just Bech32m - | otherwise -> Nothing + let poly = bech32Polymod (bech32HRPExpand hrp ++ dat) + in if + | poly == bech32Const Bech32 -> Just Bech32 + | poly == bech32Const Bech32m -> Just Bech32m + | otherwise -> Nothing -- | Maximum length of a Bech32 result. maxBech32Length :: Int maxBech32Length = 90 -{- | Encode string of five-bit words into 'Bech32' using a provided - human-readable part. Can fail if 'HRP' is invalid or result would be longer - than 90 characters. --} +-- | Encode string of five-bit words into 'Bech32' using a provided +-- human-readable part. Can fail if 'HRP' is invalid or result would be longer +-- than 90 characters. bech32Encode :: Bech32Encoding -> HRP -> [Word5] -> Maybe Bech32 bech32Encode enc hrp dat = do - guard $ checkHRP hrp - let dat' = dat ++ bech32CreateChecksum enc (T.toLower hrp) dat - rest = map (charset !) dat' - result = T.concat [T.toLower hrp, T.pack "1", T.pack rest] - guard $ T.length result <= maxBech32Length - return result + guard $ checkHRP hrp + let dat' = dat ++ bech32CreateChecksum enc (T.toLower hrp) dat + rest = map (charset !) dat' + result = T.concat [T.toLower hrp, T.pack "1", T.pack rest] + guard $ T.length result <= maxBech32Length + return result -- | Check that human-readable part is valid for a 'Bech32' string. checkHRP :: HRP -> Bool checkHRP hrp = - not (T.null hrp) - && T.all (\char -> char >= '\x21' && char <= '\x7e') hrp + not (T.null hrp) + && T.all (\char -> char >= '\x21' && char <= '\x7e') hrp -{- | Decode human-readable 'Bech32' string into a human-readable part and a - string of five-bit words. --} +-- | Decode human-readable 'Bech32' string into a human-readable part and a +-- string of five-bit words. bech32Decode :: Bech32 -> Maybe (Bech32Encoding, HRP, [Word5]) bech32Decode bech32 = do - guard $ T.length bech32 <= maxBech32Length - guard $ T.toUpper bech32 == bech32 || lowerBech32 == bech32 - let (hrp, dat) = T.breakOnEnd "1" lowerBech32 - guard $ T.length dat >= 6 - hrp' <- T.stripSuffix "1" hrp - guard $ checkHRP hrp' - dat' <- mapM charsetMap $ T.unpack dat - enc <- bech32VerifyChecksum hrp' dat' - return (enc, hrp', take (T.length dat - 6) dat') + guard $ T.length bech32 <= maxBech32Length + guard $ T.toUpper bech32 == bech32 || lowerBech32 == bech32 + let (hrp, dat) = T.breakOnEnd "1" lowerBech32 + guard $ T.length dat >= 6 + hrp' <- T.stripSuffix "1" hrp + guard $ checkHRP hrp' + dat' <- mapM charsetMap $ T.unpack dat + enc <- bech32VerifyChecksum hrp' dat' + return (enc, hrp', take (T.length dat - 6) dat') where lowerBech32 = T.toLower bech32 @@ -202,67 +201,65 @@ yesPadding _ _ padValue result = return $ [padValue] : result noPadding :: Pad Maybe noPadding frombits bits padValue result = do - guard $ bits < frombits && padValue == 0 - return result + guard $ bits < frombits && padValue == 0 + return result {-# INLINE noPadding #-} -{- | Big endian conversion of a bytestring from base \(2^{frombits}\) to base - \(2^{tobits}\). {frombits} and {twobits} must be positive and - \(2^{frombits}\) and \(2^{tobits}\) must be smaller than the size of Word. - Every value in 'dat' must be strictly smaller than \(2^{frombits}\). --} -convertBits :: Functor f => [Word] -> Int -> Int -> Pad f -> f [Word] +-- | Big endian conversion of a bytestring from base \(2^{frombits}\) to base +-- \(2^{tobits}\). {frombits} and {twobits} must be positive and +-- \(2^{frombits}\) and \(2^{tobits}\) must be smaller than the size of Word. +-- Every value in 'dat' must be strictly smaller than \(2^{frombits}\). +convertBits :: (Functor f) => [Word] -> Int -> Int -> Pad f -> f [Word] convertBits dat frombits tobits pad = concat . reverse <$> go dat 0 0 [] where go [] acc bits result = - let padValue = (acc .<<. (tobits - bits)) .&. maxv - in pad frombits bits padValue result + let padValue = (acc .<<. (tobits - bits)) .&. maxv + in pad frombits bits padValue result go (value : dat') acc bits result = - go dat' acc' (bits' `rem` tobits) (result' : result) + go dat' acc' (bits' `rem` tobits) (result' : result) where acc' = (acc .<<. frombits) .|. fromIntegral value bits' = bits + frombits result' = - [ (acc' .>>. b) .&. maxv + [ (acc' .>>. b) .&. maxv | b <- [bits' - tobits, bits' - 2 * tobits .. 0] - ] + ] maxv = (1 .<<. tobits) - 1 {-# INLINE convertBits #-} -- | Convert from eight-bit to five-bit word string, adding padding as required. toBase32 :: [Word8] -> [Word5] toBase32 dat = - map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding + map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding -- | Convert from five-bit word string to eight-bit word string, ignoring padding. toBase256 :: [Word5] -> Maybe [Word8] toBase256 dat = - map fromIntegral <$> convertBits (map fromWord5 dat) 5 8 noPadding + map fromIntegral <$> convertBits (map fromWord5 dat) 5 8 noPadding -- | Check if witness version and program are valid. segwitCheck :: Bech32Encoding -> Word8 -> Data -> Bool segwitCheck enc witver witprog = - witver <= 16 - && if witver == 0 - then enc == Bech32 && (length witprog == 20 || length witprog == 32) - else enc == Bech32m && (length witprog >= 2 && length witprog <= 40) + witver <= 16 + && if witver == 0 + then enc == Bech32 && (length witprog == 20 || length witprog == 32) + else enc == Bech32m && (length witprog >= 2 && length witprog <= 40) -- | Decode SegWit 'Bech32' address from a string and expected human-readable part. segwitDecode :: HRP -> Bech32 -> Maybe (Word8, Data) segwitDecode hrp addr = do - (enc, hrp', dat) <- bech32Decode addr - guard $ (hrp == hrp') && not (null dat) - let (UnsafeWord5 witver : datBase32) = dat - decoded <- toBase256 datBase32 - guard $ segwitCheck enc witver decoded - return (witver, decoded) + (enc, hrp', dat) <- bech32Decode addr + guard $ (hrp == hrp') && not (null dat) + let (UnsafeWord5 witver : datBase32) = dat + decoded <- toBase256 datBase32 + guard $ segwitCheck enc witver decoded + return (witver, decoded) -{- | Encode 'Data' as a SegWit 'Bech32' address. Needs human-readable part and - witness program version. --} +-- | Encode 'Data' as a SegWit 'Bech32' address. Needs human-readable part and +-- witness program version. segwitEncode :: HRP -> Word8 -> Data -> Maybe Text segwitEncode hrp witver witprog = do - guard $ segwitCheck enc witver witprog - bech32Encode enc hrp $ UnsafeWord5 witver : toBase32 witprog + guard $ segwitCheck enc witver witprog + bech32Encode enc hrp $ UnsafeWord5 witver : toBase32 witprog where enc = if witver == 0 then Bech32 else Bech32m diff --git a/src/Haskoin/Address/CashAddr.hs b/src/Haskoin/Address/CashAddr.hs index 4b01ba5e..f2c2b5ac 100644 --- a/src/Haskoin/Address/CashAddr.hs +++ b/src/Haskoin/Address/CashAddr.hs @@ -1,17 +1,20 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Address.CashAddr -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Support for Bitcoin Cash (BCH) CashAddr format. --} -module Haskoin.Address.CashAddr ( - -- * CashAddr +-- | +-- Module : Haskoin.Address.CashAddr +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Support for Bitcoin Cash (BCH) CashAddr format. +module Haskoin.Address.CashAddr + ( -- * CashAddr CashPrefix, CashVersion, CashAddr, @@ -22,26 +25,35 @@ module Haskoin.Address.CashAddr ( cash32encodeType, cash32decode, cash32encode, -) where + ) +where -import Control.Monad +import Control.Monad (guard) import Data.Bits + ( Bits + ( shiftL, + shiftR, + testBit, + xor, + (.&.), + (.|.) + ), + ) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import Data.Char -import Data.List +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as C +import Data.Char (ord, toLower, toUpper) +import Data.List (elemIndex, foldl') import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Word -import Haskoin.Data -import Haskoin.Util +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Word (Word64, Word8) +import Haskoin.Network.Data (Network (cashAddrPrefix)) +import Haskoin.Util.Helpers (convertBits) -{- | 'CashAddr' prefix, usually shown before the colon in addresses, but sometimes - omitted. It is used in the checksum calculation to avoid parsing an address - from the wrong network. --} +-- | 'CashAddr' prefix, usually shown before the colon in addresses, but sometimes +-- omitted. It is used in the checksum calculation to avoid parsing an address +-- from the wrong network. type CashPrefix = Text -- | 'CashAddr' version, until new address schemes appear it will be zero. @@ -50,9 +62,8 @@ type CashVersion = Word8 -- | High level 'CashAddr' human-reabale string, with explicit or implicit prefix. type CashAddr = Text -{- | Low level 'Cash32' is the human-readable low-level encoding used by 'CashAddr'. It - need not encode a valid address but any binary data. --} +-- | Low level 'Cash32' is the human-readable low-level encoding used by 'CashAddr'. +-- It need not encode a valid address but any binary data. type Cash32 = Text -- | Symbols for encoding 'Cash32' data in human-readable strings. @@ -63,156 +74,147 @@ charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l" base32char :: Char -> Maybe Word8 base32char = fmap fromIntegral . (`elemIndex` charset) -{- | High-Level: decode 'CashAddr' string if it is valid for the - provided 'Network'. Prefix may be omitted from the string. --} +-- | High-Level: decode 'CashAddr' string if it is valid for the +-- provided 'Network'. Prefix may be omitted from the string. cashAddrDecode :: Network -> CashAddr -> Maybe (CashVersion, ByteString) cashAddrDecode net ca = do - epfx <- getCashAddrPrefix net - let (cpfx, cdat) = T.breakOnEnd ":" (T.toLower ca) - guard (T.null cpfx || T.init cpfx == epfx) - (dpfx, ver, bs) <- cash32decodeType (epfx <> ":" <> cdat) - guard (dpfx == epfx) - return (ver, bs) + epfx <- net.cashAddrPrefix + let (cpfx, cdat) = T.breakOnEnd ":" (T.toLower ca) + guard (T.null cpfx || T.init cpfx == epfx) + (dpfx, ver, bs) <- cash32decodeType (epfx <> ":" <> cdat) + guard (dpfx == epfx) + return (ver, bs) -{- | High-Level: encode 'CashAddr' string for the provided network and hash. - Fails if the 'CashVersion' or length of hash 'ByteString' is invalid. --} +-- | High-Level: encode 'CashAddr' string for the provided network and hash. +-- Fails if the 'CashVersion' or length of hash 'ByteString' is invalid. cashAddrEncode :: Network -> CashVersion -> ByteString -> Maybe CashAddr cashAddrEncode net cv bs = do - pfx <- getCashAddrPrefix net - cash32encodeType pfx cv bs + pfx <- net.cashAddrPrefix + cash32encodeType pfx cv bs -{- | Mid-Level: decode 'CashAddr' string containing arbitrary prefix, plus a - version byte before the 'ByteString' that encodes type and length. --} +-- | Mid-Level: decode 'CashAddr' string containing arbitrary prefix, plus a +-- version byte before the 'ByteString' that encodes type and length. cash32decodeType :: Cash32 -> Maybe (CashPrefix, CashVersion, ByteString) cash32decodeType ca' = do - guard (T.toUpper ca' == ca' || ca == ca') - (dpfx, bs) <- cash32decode ca - guard (not (B.null bs)) - let vb = B.head bs - pay = B.tail bs - (ver, len) <- decodeVersionByte vb - guard (B.length pay == len) - return (dpfx, ver, pay) + guard (T.toUpper ca' == ca' || ca == ca') + (dpfx, bs) <- cash32decode ca + guard (not (B.null bs)) + let vb = B.head bs + pay = B.tail bs + (ver, len) <- decodeVersionByte vb + guard (B.length pay == len) + return (dpfx, ver, pay) where ca = T.toLower ca' -{- | Mid-Level: encode 'CashAddr' string containing arbitrary prefix and - 'CashVersion'. Length must be among those allowed by the standard. --} +-- | Mid-Level: encode 'CashAddr' string containing arbitrary prefix and +-- 'CashVersion'. Length must be among those allowed by the standard. cash32encodeType :: CashPrefix -> CashVersion -> ByteString -> Maybe Cash32 cash32encodeType pfx cv bs = do - let len = B.length bs - vb <- encodeVersionByte cv len - let pl = vb `B.cons` bs - return (cash32encode pfx pl) + let len = B.length bs + vb <- encodeVersionByte cv len + let pl = vb `B.cons` bs + return (cash32encode pfx pl) -{- | Low-Level: decode 'Cash32' string. 'CashPrefix' must be part of the string. - No version or hash length validation is performed. --} +-- | Low-Level: decode 'Cash32' string. 'CashPrefix' must be part of the string. +-- No version or hash length validation is performed. cash32decode :: Cash32 -> Maybe (CashPrefix, ByteString) cash32decode text = do - let bs = C.map toLower bs' - guard (C.map toUpper bs' == bs' || bs == bs') - let (pfx', dat) = C.breakEnd (== ':') bs - pfx <- - if B.null pfx' || pfx' == C.singleton ':' - then Nothing - else Just (B.init pfx') - b32 <- B.pack <$> mapM base32char (C.unpack dat) - let px = B.map (.&. 0x1f) pfx - pd = px <> B.singleton 0 <> b32 - cs = cash32Polymod pd - bb = B.take (B.length b32 - 8) b32 - guard (verifyCash32Polymod cs) - let out = toBase256 bb - return (E.decodeUtf8 pfx, out) + let bs = C.map toLower bs' + guard (C.map toUpper bs' == bs' || bs == bs') + let (pfx', dat) = C.breakEnd (== ':') bs + pfx <- + if B.null pfx' || pfx' == C.singleton ':' + then Nothing + else Just (B.init pfx') + b32 <- B.pack <$> mapM base32char (C.unpack dat) + let px = B.map (.&. 0x1f) pfx + pd = px <> B.singleton 0 <> b32 + cs = cash32Polymod pd + bb = B.take (B.length b32 - 8) b32 + guard (verifyCash32Polymod cs) + let out = toBase256 bb + return (decodeUtf8 pfx, out) where - bs' = E.encodeUtf8 text + bs' = encodeUtf8 text -{- | Low-Level: encode 'Cash32' string for 'CashPrefix' provided. Can encode - arbitrary data. No prefix or length validation is performed. --} +-- | Low-Level: encode 'Cash32' string for 'CashPrefix' provided. Can encode +-- arbitrary data. No prefix or length validation is performed. cash32encode :: CashPrefix -> ByteString -> Cash32 cash32encode pfx bs = - let b32 = toBase32 bs - px = B.map (.&. 0x1f) (E.encodeUtf8 pfx) - pd = px <> B.singleton 0 <> b32 <> B.replicate 8 0 - cs = cash32Polymod pd - c32 = B.map f (b32 <> cs) - f = fromIntegral . ord . (charset !!) . fromIntegral - in pfx <> ":" <> E.decodeUtf8 c32 + let b32 = toBase32 bs + px = B.map (.&. 0x1f) (encodeUtf8 pfx) + pd = px <> B.singleton 0 <> b32 <> B.replicate 8 0 + cs = cash32Polymod pd + c32 = B.map f (b32 <> cs) + f = fromIntegral . ord . (charset !!) . fromIntegral + in pfx <> ":" <> decodeUtf8 c32 -{- | Convert base of 'ByteString' from eight bits per byte to five bits per - byte, adding padding as necessary. --} +-- | Convert base of 'ByteString' from eight bits per byte to five bits per +-- byte, adding padding as necessary. toBase32 :: ByteString -> ByteString toBase32 = - B.pack - . map fromIntegral - . fst - . convertBits True 8 5 - . map fromIntegral - . B.unpack + B.pack + . map fromIntegral + . fst + . convertBits True 8 5 + . map fromIntegral + . B.unpack -{- | Convert base of 'ByteString' from five to eight bits per byte. Ignore - padding to be symmetric with respect to 'toBase32' function. --} +-- | Convert base of 'ByteString' from five to eight bits per byte. Ignore +-- padding to be symmetric with respect to 'toBase32' function. toBase256 :: ByteString -> ByteString toBase256 = - B.pack - . map fromIntegral - . fst - . convertBits False 5 8 - . map fromIntegral - . B.unpack + B.pack + . map fromIntegral + . fst + . convertBits False 5 8 + . map fromIntegral + . B.unpack -- | Obtain 'CashVersion' and payload length from 'CashAddr' version byte. decodeVersionByte :: Word8 -> Maybe (CashVersion, Int) decodeVersionByte vb = do - guard (vb .&. 0x80 == 0) - return (ver, len) + guard (vb .&. 0x80 == 0) + return (ver, len) where ver = vb `shiftR` 3 len = ls !! fromIntegral (vb .&. 0x07) ls = [20, 24, 28, 32, 40, 48, 56, 64] -{- | Encode 'CashVersion' and length into version byte. Fail if version is - larger than five bits, or length incorrect, since that is invalid. --} +-- | Encode 'CashVersion' and length into version byte. Fail if version is +-- larger than five bits, or length incorrect, since that is invalid. encodeVersionByte :: CashVersion -> Int -> Maybe Word8 encodeVersionByte ver len = do - guard (ver == ver .&. 0x0f) - l <- case len of - 20 -> Just 0 - 24 -> Just 1 - 28 -> Just 2 - 32 -> Just 3 - 40 -> Just 4 - 48 -> Just 5 - 56 -> Just 6 - 64 -> Just 7 - _ -> Nothing - return ((ver `shiftL` 3) .|. l) + guard (ver == ver .&. 0x0f) + l <- case len of + 20 -> Just 0 + 24 -> Just 1 + 28 -> Just 2 + 32 -> Just 3 + 40 -> Just 4 + 48 -> Just 5 + 56 -> Just 6 + 64 -> Just 7 + _ -> Nothing + return ((ver `shiftL` 3) .|. l) -- | Calculate or validate checksum from base32 'ByteString' (excluding prefix). cash32Polymod :: ByteString -> ByteString cash32Polymod v = - B.pack - [fromIntegral (polymod `shiftR` (5 * (7 - i))) .&. 0x1f | i <- [0 .. 7]] + B.pack + [fromIntegral (polymod `shiftR` (5 * (7 - i))) .&. 0x1f | i <- [0 .. 7]] where polymod = B.foldl' outer (1 :: Word64) v `xor` 1 outer c d = - let c0 = (fromIntegral (c `shiftR` 35) :: Word8) - c' = ((c .&. 0x07ffffffff) `shiftL` 5) `xor` fromIntegral d - in foldl' (inner c0) c' (zip [0 ..] generator) + let c0 = (fromIntegral (c `shiftR` 35) :: Word8) + c' = ((c .&. 0x07ffffffff) `shiftL` 5) `xor` fromIntegral d + in foldl' (inner c0) c' (zip [0 ..] generator) generator = - [0x98f2bc8e61, 0x79b76d99e2, 0xf33e5fb3c4, 0xae2eabe2a8, 0x1e4f43e470] + [0x98f2bc8e61, 0x79b76d99e2, 0xf33e5fb3c4, 0xae2eabe2a8, 0x1e4f43e470] inner c0 c (b, g) - | c0 `testBit` b = c `xor` g - | otherwise = c + | c0 `testBit` b = c `xor` g + | otherwise = c -- | Validate that polymod 'ByteString' (eight bytes) is equal to zero. verifyCash32Polymod :: ByteString -> Bool diff --git a/src/Haskoin/Block.hs b/src/Haskoin/Block.hs index cce67912..1779a1e0 100644 --- a/src/Haskoin/Block.hs +++ b/src/Haskoin/Block.hs @@ -1,18 +1,18 @@ -{- | -Module : Haskoin.Block -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Most functions relating to blocks are exported by this module. --} -module Haskoin.Block ( - module Haskoin.Block.Common, +-- | +-- Module : Haskoin.Block +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Most functions relating to blocks are exported by this module. +module Haskoin.Block + ( module Haskoin.Block.Common, module Haskoin.Block.Headers, module Haskoin.Block.Merkle, -) where + ) +where import Haskoin.Block.Common import Haskoin.Block.Headers diff --git a/src/Haskoin/Block/Common.hs b/src/Haskoin/Block/Common.hs index 6c7d56cc..854714b8 100644 --- a/src/Haskoin/Block/Common.hs +++ b/src/Haskoin/Block/Common.hs @@ -1,19 +1,21 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Block.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common data types and functions to handle blocks from the block chain. --} -module Haskoin.Block.Common ( - -- * Blocks +-- | +-- Module : Haskoin.Block.Common +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Common data types and functions to handle blocks from the block chain. +module Haskoin.Block.Common + ( -- * Blocks Block (..), BlockHeight, Timestamp, @@ -29,53 +31,34 @@ module Haskoin.Block.Common ( Headers (..), decodeCompact, encodeCompact, -) where + ) +where import Control.DeepSeq -import Control.Monad (forM_, liftM2, mzero, replicateM, (<=<)) -import Data.Aeson ( - FromJSON (..), - ToJSON (..), - Value (..), - object, - toJSON, - withObject, - withText, - (.:), - (.=), - ) -import Data.Aeson.Encoding (pairs, unsafeToEncoding) +import Control.Monad +import Data.Aeson +import Data.Aeson.Encoding import Data.Binary (Binary (..)) -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import qualified Data.ByteString as B +import Data.Bits +import Data.ByteString qualified as B import Data.ByteString.Builder (char7) -import qualified Data.ByteString.Lazy as BL -import Data.Bytes.Get ( - MonadGet, - getWord32le, - runGetL, - runGetS, - ) -import Data.Bytes.Put ( - MonadPut, - putWord32le, - runPutL, - runPutS, - ) -import Data.Bytes.Serial (Serial (..)) -import Data.Hashable (Hashable) -import Data.Maybe (fromMaybe) +import Data.ByteString.Lazy qualified as L +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Hashable +import Data.Maybe import Data.Serialize (Serialize (..)) -import Data.String (IsString, fromString) -import Data.String.Conversions (cs) +import Data.String +import Data.String.Conversions import Data.Text (Text) -import Data.Word (Word32) -import GHC.Generics (Generic) +import Data.Word +import GHC.Generics import Haskoin.Crypto.Hash import Haskoin.Network.Common import Haskoin.Transaction.Common -import Haskoin.Util -import qualified Text.Read as R +import Haskoin.Util.Helpers +import Text.Read qualified as R -- | Height of a block in the block chain, starting at 0 for Genesis. type BlockHeight = Word32 @@ -85,311 +68,312 @@ type Timestamp = Word32 -- | Block header and transactions. data Block = Block - { blockHeader :: !BlockHeader - , blockTxns :: ![Tx] - } - deriving (Eq, Show, Read, Generic, Hashable, NFData) + { header :: !BlockHeader, + txs :: ![Tx] + } + deriving (Eq, Show, Read, Generic, Hashable, NFData) instance Serial Block where - deserialize = do - header <- deserialize - (VarInt c) <- deserialize - txs <- replicateM (fromIntegral c) deserialize - return $ Block header txs - serialize (Block h txs) = do - serialize h - putVarInt $ length txs - forM_ txs serialize + deserialize = do + header <- deserialize + (VarInt c) <- deserialize + txs <- replicateM (fromIntegral c) deserialize + return $ Block header txs + serialize (Block h txs) = do + serialize h + putVarInt $ length txs + forM_ txs serialize instance Serialize Block where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Binary Block where - get = deserialize - put = serialize + get = deserialize + put = serialize instance ToJSON Block where - toJSON (Block h t) = object ["header" .= h, "transactions" .= t] - toEncoding (Block h t) = pairs $ "header" .= h <> "transactions" .= t + toJSON (Block h t) = + object ["header" .= h, "transactions" .= t] + toEncoding (Block h t) = + pairs $ + mconcat + [ "header" `pair` toEncoding h, + "transactions" `pair` list toEncoding t + ] instance FromJSON Block where - parseJSON = - withObject "Block" $ \o -> - Block <$> o .: "header" <*> o .: "transactions" + parseJSON = + withObject "Block" $ \o -> + Block <$> o .: "header" <*> o .: "transactions" -- | Block header hash. To be serialized reversed for display purposes. -newtype BlockHash = BlockHash - { getBlockHash :: Hash256 - } - deriving (Eq, Ord, Generic, Hashable, Serial, NFData) +newtype BlockHash = BlockHash {get :: Hash256} + deriving (Eq, Ord, Generic, Hashable, Serial, NFData) instance Serialize BlockHash where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary BlockHash where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Show BlockHash where - showsPrec _ = shows . blockHashToHex + showsPrec _ = shows . blockHashToHex instance Read BlockHash where - readPrec = do - R.String str <- R.lexP - maybe R.pfail return $ hexToBlockHash $ cs str + readPrec = do + R.String str <- R.lexP + maybe R.pfail return $ hexToBlockHash $ cs str instance IsString BlockHash where - fromString s = - let e = error "Could not read block hash from hex string" - in fromMaybe e $ hexToBlockHash $ cs s + fromString s = + fromMaybe (error "Could not read block hash from hex string") $ + hexToBlockHash $ + cs s instance FromJSON BlockHash where - parseJSON = - withText "BlockHash" $ - maybe mzero return . hexToBlockHash + parseJSON = + withText "BlockHash" $ + maybe mzero return . hexToBlockHash instance ToJSON BlockHash where - toJSON = String . blockHashToHex - toEncoding h = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (BL.reverse (runPutL (serialize h))) - <> char7 '"' + toJSON = String . blockHashToHex + toEncoding = hexEncoding . L.reverse . runPutL . serialize -{- | Block hashes are reversed with respect to the in-memory byte order in a - block hash when displayed. --} +-- | Block hashes are reversed with respect to the in-memory byte order in a +-- block hash when displayed. blockHashToHex :: BlockHash -> Text blockHashToHex (BlockHash h) = encodeHex (B.reverse (runPutS (serialize h))) -{- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are - reversed as normal. --} +-- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are +-- reversed as normal. hexToBlockHash :: Text -> Maybe BlockHash hexToBlockHash hex = do - bs <- B.reverse <$> decodeHex hex - h <- eitherToMaybe (runGetS deserialize bs) - return $ BlockHash h + bs <- B.reverse <$> decodeHex hex + h <- eitherToMaybe (runGetS deserialize bs) + return $ BlockHash h -{- | Data type recording information of a 'Block'. The hash of a block is - defined as the hash of this data structure, serialized. The block mining - process involves finding a partial hash collision by varying the nonce in the - 'BlockHeader' and/or additional entropy in the coinbase 'Transaction' of this - 'Block'. Variations in the coinbase will result in different merkle roots in - the 'BlockHeader'. --} +-- | Data type recording information of a 'Block'. The hash of a block is +-- defined as the hash of this data structure, serialized. The block mining +-- process involves finding a partial hash collision by varying the nonce in the +-- 'BlockHeader' and/or additional entropy in the coinbase 'Transaction' of this +-- 'Block'. Variations in the coinbase will result in different merkle roots in +-- the 'BlockHeader'. data BlockHeader = BlockHeader - { blockVersion :: !Word32 -- 4 bytes - , -- | hash of the previous block (parent) - prevBlock :: !BlockHash -- 32 bytes - , -- | root of the merkle tree of transactions - merkleRoot :: !Hash256 -- 32 bytes - , -- | unix timestamp - blockTimestamp :: !Timestamp -- 4 bytes - , -- | difficulty target - blockBits :: !Word32 -- 4 bytes - , -- | random nonce - bhNonce :: !Word32 -- 4 bytes - } - deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData) + { version :: !Word32, -- 4 bytes + + -- | hash of the previous block (parent) + prev :: !BlockHash, -- 32 bytes + + -- | root of the merkle tree of transactions + merkle :: !Hash256, -- 32 bytes + + -- | unix timestamp + timestamp :: !Timestamp, -- 4 bytes + + -- | difficulty target + bits :: !Word32, -- 4 bytes + + -- | random nonce + nonce :: !Word32 -- 4 bytes + } + deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData) -- 80 bytes instance ToJSON BlockHeader where - toJSON (BlockHeader v p m t b n) = - object - [ "version" .= v - , "prevblock" .= p - , "merkleroot" .= encodeHex (runPutS (serialize m)) - , "timestamp" .= t - , "bits" .= b - , "nonce" .= n - ] - toEncoding (BlockHeader v p m t b n) = - pairs - ( "version" .= v - <> "prevblock" .= p - <> "merkleroot" .= encodeHex (runPutS (serialize m)) - <> "timestamp" .= t - <> "bits" .= b - <> "nonce" .= n - ) + toJSON (BlockHeader v p m t b n) = + object + [ "version" .= v, + "prevblock" .= p, + "merkleroot" .= encodeHex (runPutS $ serialize m), + "timestamp" .= t, + "bits" .= b, + "nonce" .= n + ] + toEncoding (BlockHeader v p m t b n) = + pairs $ + mconcat + [ "version" `pair` word32 v, + "prevblock" `pair` toEncoding p, + "merkleroot" `pair` hexEncoding (runPutL $ serialize m), + "timestamp" `pair` toEncoding t, + "bits" `pair` toEncoding b, + "nonce" `pair` toEncoding n + ] instance FromJSON BlockHeader where - parseJSON = - withObject "BlockHeader" $ \o -> - BlockHeader <$> o .: "version" - <*> o .: "prevblock" - <*> (f =<< o .: "merkleroot") - <*> o .: "timestamp" - <*> o .: "bits" - <*> o .: "nonce" - where - f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) + parseJSON = + withObject "BlockHeader" $ \o -> + BlockHeader + <$> o .: "version" + <*> o .: "prevblock" + <*> (f =<< o .: "merkleroot") + <*> o .: "timestamp" + <*> o .: "bits" + <*> o .: "nonce" + where + f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) instance Serial BlockHeader where - deserialize = do - v <- getWord32le - p <- deserialize - m <- deserialize - t <- getWord32le - b <- getWord32le - n <- getWord32le - return - BlockHeader - { blockVersion = v - , prevBlock = p - , merkleRoot = m - , blockTimestamp = t - , blockBits = b - , bhNonce = n - } - serialize (BlockHeader v p m bt bb n) = do - putWord32le v - serialize p - serialize m - putWord32le bt - putWord32le bb - putWord32le n + deserialize = do + v <- getWord32le + p <- deserialize + m <- deserialize + t <- getWord32le + b <- getWord32le + n <- getWord32le + return + BlockHeader + { version = v, + prev = p, + merkle = m, + timestamp = t, + bits = b, + nonce = n + } + serialize (BlockHeader v p m bt bb n) = do + putWord32le v + serialize p + serialize m + putWord32le bt + putWord32le bb + putWord32le n instance Binary BlockHeader where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize BlockHeader where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | Compute hash of 'BlockHeader'. headerHash :: BlockHeader -> BlockHash headerHash = BlockHash . doubleSHA256 . runPutS . serialize -{- | A block locator is a set of block headers, denser towards the best block - and sparser towards the genesis block. It starts at the highest block known. - It is used by a node to synchronize against the network. When the locator is - provided to a peer, it will send back block hashes starting from the first - block in the locator that it recognizes. --} +-- | A block locator is a set of block headers, denser towards the best block +-- and sparser towards the genesis block. It starts at the highest block known. +-- It is used by a node to synchronize against the network. When the locator is +-- provided to a peer, it will send back block hashes starting from the first +-- block in the locator that it recognizes. type BlockLocator = [BlockHash] -{- | Data type representing a getblocks message request. It is used in the - bitcoin protocol to retrieve blocks from a peer by providing it a - 'BlockLocator' object. The response to a 'GetBlocks' message is an 'Inv' - message containing a list of block hashes that the peer believes this node is - missing. The number of block hashes in that inv message will end at the stop - block hash, at at the tip of the chain, or after 500 entries, whichever comes - earlier. --} +-- | Data type representing a getblocks message request. It is used in the +-- bitcoin protocol to retrieve blocks from a peer by providing it a +-- 'BlockLocator' object. The response to a 'GetBlocks' message is an 'Inv' +-- message containing a list of block hashes that the peer believes this node is +-- missing. The number of block hashes in that inv message will end at the stop +-- block hash, at at the tip of the chain, or after 500 entries, whichever comes +-- earlier. data GetBlocks = GetBlocks - { getBlocksVersion :: !Word32 - , -- | block locator object - getBlocksLocator :: !BlockLocator - , -- | hash of the last desired block - getBlocksHashStop :: !BlockHash - } - deriving (Eq, Show, Read, Generic, NFData) + { version :: !Word32, + -- | block locator object + locator :: !BlockLocator, + -- | hash of the last desired block + stop :: !BlockHash + } + deriving (Eq, Show, Read, Generic, NFData) instance Serial GetBlocks where - deserialize = - GetBlocks - <$> getWord32le - <*> (repList =<< deserialize) - <*> deserialize - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize - serialize (GetBlocks v xs h) = putGetBlockMsg v xs h - -instance Serialize GetBlocks where - put = serialize - get = deserialize - -putGetBlockMsg :: MonadPut m => Word32 -> BlockLocator -> BlockHash -> m () -putGetBlockMsg v xs h = do + deserialize = + GetBlocks + <$> getWord32le + <*> (repList =<< deserialize) + <*> deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize + serialize (GetBlocks v xs h) = do putWord32le v putVarInt $ length xs forM_ xs serialize serialize h -{- | Similar to the 'GetBlocks' message type but for retrieving block headers - only. The response to a 'GetHeaders' request is a 'Headers' message - containing a list of block headers. A maximum of 2000 block headers can be - returned. 'GetHeaders' is used by simplified payment verification (SPV) - clients to exclude block contents when synchronizing the block chain. --} +instance Serialize GetBlocks where + put = serialize + get = deserialize + +-- | Similar to the 'GetBlocks' message type but for retrieving block headers +-- only. The response to a 'GetHeaders' request is a 'Headers' message +-- containing a list of block headers. A maximum of 2000 block headers can be +-- returned. 'GetHeaders' is used by simplified payment verification (SPV) +-- clients to exclude block contents when synchronizing the block chain. data GetHeaders = GetHeaders - { getHeadersVersion :: !Word32 - , -- | block locator object - getHeadersBL :: !BlockLocator - , -- | hash of the last desired block header - getHeadersHashStop :: !BlockHash - } - deriving (Eq, Show, Read, Generic, NFData) + { version :: !Word32, + -- | block locator object + locator :: !BlockLocator, + -- | hash of the last desired block header + stop :: !BlockHash + } + deriving (Eq, Show, Read, Generic, NFData) instance Serial GetHeaders where - deserialize = - GetHeaders - <$> getWord32le - <*> (repList =<< deserialize) - <*> deserialize - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize - serialize (GetHeaders v xs h) = putGetBlockMsg v xs h + deserialize = + GetHeaders + <$> getWord32le + <*> (repList =<< deserialize) + <*> deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize + serialize (GetHeaders v xs h) = do + putWord32le v + putVarInt $ length xs + forM_ xs serialize + serialize h instance Serialize GetHeaders where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary GetHeaders where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | 'BlockHeader' type with a transaction count as 'VarInt' type BlockHeaderCount = (BlockHeader, VarInt) -{- | The 'Headers' type is used to return a list of block headers in - response to a 'GetHeaders' message. --} +-- | The 'Headers' type is used to return a list of block headers in +-- response to a 'GetHeaders' message. newtype Headers = Headers - { -- | list of block headers with transaction count - headersList :: [BlockHeaderCount] - } - deriving (Eq, Show, Read, Generic, NFData) + { -- | list of block headers with transaction count + list :: [BlockHeaderCount] + } + deriving (Eq, Show, Read, Generic, NFData) instance Serial Headers where - deserialize = Headers <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) action - action = liftM2 (,) deserialize deserialize - serialize (Headers xs) = do - putVarInt $ length xs - forM_ xs $ \(a, b) -> serialize a >> serialize b + deserialize = Headers <$> (repList =<< deserialize) + where + repList (VarInt c) = replicateM (fromIntegral c) action + action = liftM2 (,) deserialize deserialize + serialize (Headers xs) = do + putVarInt $ length xs + forM_ xs $ \(a, b) -> serialize a >> serialize b instance Serialize Headers where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary Headers where - put = serialize - get = deserialize + put = serialize + get = deserialize -{- | Decode the compact number used in the difficulty target of a block. - - The compact format is a representation of a whole number \(N\) using an - unsigned 32-bit number similar to a floating point format. The most - significant 8 bits are the unsigned exponent of base 256. This exponent can - be thought of as the number of bytes of \(N\). The lower 23 bits are the - mantissa. Bit number 24 represents the sign of \(N\). - - \[ - N = -1^{sign} \times mantissa \times 256^{exponent-3} - \] --} +-- | Decode the compact number used in the difficulty target of a block. +-- +-- The compact format is a representation of a whole number \(N\) using an +-- unsigned 32-bit number similar to a floating point format. The most +-- significant 8 bits are the unsigned exponent of base 256. This exponent can +-- be thought of as the number of bytes of \(N\). The lower 23 bits are the +-- mantissa. Bit number 24 represents the sign of \(N\). +-- +-- \[ +-- N = -1^{sign} \times mantissa \times 256^{exponent-3} +-- \] decodeCompact :: - Word32 -> - -- | true means overflow - (Integer, Bool) + Word32 -> + -- | true means overflow + (Integer, Bool) decodeCompact nCompact = (if neg then res * (-1) else res, over) where nSize :: Int @@ -398,23 +382,22 @@ decodeCompact nCompact = (if neg then res * (-1) else res, over) nWord' = nCompact .&. 0x007fffff nWord :: Word32 nWord - | nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize)) - | otherwise = nWord' + | nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize)) + | otherwise = nWord' res :: Integer res - | nSize <= 3 = fromIntegral nWord - | otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3)) + | nSize <= 3 = fromIntegral nWord + | otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3)) neg = nWord /= 0 && (nCompact .&. 0x00800000) /= 0 over = - nWord /= 0 - && ( nSize > 34 - || nWord > 0xff && nSize > 33 - || nWord > 0xffff && nSize > 32 - ) + nWord /= 0 + && ( nSize > 34 + || nWord > 0xff && nSize > 33 + || nWord > 0xffff && nSize > 32 + ) -{- | Encode an 'Integer' to the compact number format used in the difficulty - target of a block. --} +-- | Encode an 'Integer' to the compact number format used in the difficulty +-- target of a block. encodeCompact :: Integer -> Word32 encodeCompact i = nCompact where @@ -422,23 +405,23 @@ encodeCompact i = nCompact neg = i < 0 nSize' :: Int nSize' = - let f 0 = 0 - f n = 1 + f (n `shiftR` 8) - in f i' + let f 0 = 0 + f n = 1 + f (n `shiftR` 8) + in f i' nCompact''' :: Word32 nCompact''' - | nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize')) - | otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3))) + | nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize')) + | otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3))) nCompact'' :: Word32 nSize :: Int (nCompact'', nSize) - | nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1) - | otherwise = (nCompact''', nSize') + | nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1) + | otherwise = (nCompact''', nSize') nCompact' :: Word32 nCompact' = nCompact'' .|. (fromIntegral nSize `shiftL` 24) nCompact :: Word32 nCompact - | neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000 - | otherwise = nCompact' + | neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000 + | otherwise = nCompact' low64 :: Integer low64 = 0xffffffffffffffff diff --git a/src/Haskoin/Block/Headers.hs b/src/Haskoin/Block/Headers.hs index 3d2e8c7e..57ee7172 100644 --- a/src/Haskoin/Block/Headers.hs +++ b/src/Haskoin/Block/Headers.hs @@ -1,22 +1,25 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Block.Headers -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Block chain header synchronization and proof-of-work consensus functions. --} -module Haskoin.Block.Headers ( - -- * Block Headers +-- | +-- Module : Haskoin.Block.Headers +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Block chain header synchronization and proof-of-work consensus functions. +module Haskoin.Block.Headers + ( -- * Block Headers BlockNode (..), BlockHeaders (..), BlockWork, @@ -69,38 +72,25 @@ module Haskoin.Block.Headers ( mtp, firstGreaterOrEqual, lastSmallerOrEqual, -) where + ) +where import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Monad (guard, mzero, unless, when) -import Control.Monad.Except ( - ExceptT (..), - runExceptT, - throwError, - ) -import Control.Monad.State.Strict as State ( - StateT, - get, - gets, - lift, - modify, - ) +import Control.Monad.Except (ExceptT (..), runExceptT, throwError) +import Control.Monad.State.Strict as State (StateT, get, gets, lift, modify) import Control.Monad.Trans.Maybe import Data.Binary (Binary (..)) import Data.Bits (shiftL, shiftR, (.&.)) -import qualified Data.ByteString as B -import Data.ByteString.Short ( - ShortByteString, - fromShort, - toShort, - ) +import Data.ByteString qualified as B +import Data.ByteString.Short (ShortByteString, fromShort, toShort) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial import Data.Function (on) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict qualified as HashMap import Data.Hashable import Data.List (sort, sortBy) import Data.Maybe (fromMaybe, listToMaybe) @@ -110,353 +100,345 @@ import Data.Word (Word32, Word64) import GHC.Generics (Generic) import Haskoin.Block.Common import Haskoin.Crypto -import Haskoin.Data +import Haskoin.Network.Data import Haskoin.Transaction.Genesis import Haskoin.Util -{- | Short version of the block hash. Uses the good end of the hash (the part - that doesn't have a long string of zeroes). --} +-- | Short version of the block hash. Uses the good end of the hash (the part +-- that doesn't have a long string of zeroes). type ShortBlockHash = Word64 -{- | Memory-based map to a serialized 'BlockNode' data structure. - 'ShortByteString' is used to avoid memory fragmentation and make the data - structure compact. --} +-- | Memory-based map to a serialized 'BlockNode' data structure. +-- 'ShortByteString' is used to avoid memory fragmentation and make the data +-- structure compact. type BlockMap = HashMap ShortBlockHash ShortByteString -- | Represents accumulated work in the block chain so far. type BlockWork = Integer -{- | Data structure representing a block header and its position in the - block chain. --} +-- | Data structure representing a block header and its position in the +-- block chain. data BlockNode = BlockNode - { nodeHeader :: !BlockHeader - , nodeHeight :: !BlockHeight - , -- | accumulated work so far - nodeWork :: !BlockWork - , -- | skip magic block hash - nodeSkip :: !BlockHash - } - deriving (Show, Read, Generic, Hashable, NFData) + { header :: !BlockHeader, + height :: !BlockHeight, + -- | accumulated work so far + work :: !BlockWork, + -- | skip magic block hash + skip :: !BlockHash + } + deriving (Show, Read, Generic, Hashable, NFData) instance Serial BlockNode where - deserialize = do - nodeHeader <- deserialize - nodeHeight <- getWord32le - nodeWork <- getInteger - if nodeHeight == 0 - then do - let nodeSkip = headerHash nodeHeader - return BlockNode{..} - else do - nodeSkip <- deserialize - return BlockNode{..} - serialize bn = do - serialize $ nodeHeader bn - putWord32le $ nodeHeight bn - putInteger $ nodeWork bn - case nodeHeight bn of - 0 -> return () - _ -> serialize $ nodeSkip bn + deserialize = do + header <- deserialize + height <- getWord32le + work <- getInteger + if height == 0 + then do + let skip = headerHash header + return BlockNode {..} + else do + skip <- deserialize + return BlockNode {..} + serialize bn = do + serialize $ bn.header + putWord32le $ bn.height + putInteger $ bn.work + case bn.height of + 0 -> return () + _ -> serialize $ bn.skip instance Serialize BlockNode where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary BlockNode where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Eq BlockNode where - (==) = (==) `on` nodeHeader + (==) = (==) `on` (.header) instance Ord BlockNode where - compare = compare `on` nodeHeight + compare = compare `on` (.height) -- | Memory-based header tree. data HeaderMemory = HeaderMemory - { memoryHeaderMap :: !BlockMap - , memoryBestHeader :: !BlockNode - } - deriving (Eq, Typeable, Show, Read, Generic, Hashable, NFData) + { blocks :: !BlockMap, + best :: !BlockNode + } + deriving (Eq, Typeable, Show, Read, Generic, Hashable, NFData) -- | Typeclass for block header chain storage monad. -class Monad m => BlockHeaders m where - -- | Add a new 'BlockNode' to the chain. Does not validate. - addBlockHeader :: BlockNode -> m () +class (Monad m) => BlockHeaders m where + -- | Add a new 'BlockNode' to the chain. Does not validate. + addBlockHeader :: BlockNode -> m () - -- | Get a 'BlockNode' associated with a 'BlockHash'. - getBlockHeader :: BlockHash -> m (Maybe BlockNode) + -- | Get a 'BlockNode' associated with a 'BlockHash'. + getBlockHeader :: BlockHash -> m (Maybe BlockNode) - -- | Locate the 'BlockNode' for the highest block in the chain - getBestBlockHeader :: m BlockNode + -- | Locate the 'BlockNode' for the highest block in the chain + getBestBlockHeader :: m BlockNode - -- | Set the highest block in the chain. - setBestBlockHeader :: BlockNode -> m () + -- | Set the highest block in the chain. + setBestBlockHeader :: BlockNode -> m () - -- | Add a continuous bunch of block headers the chain. Does not validate. - addBlockHeaders :: [BlockNode] -> m () - addBlockHeaders = mapM_ addBlockHeader + -- | Add a continuous bunch of block headers the chain. Does not validate. + addBlockHeaders :: [BlockNode] -> m () + addBlockHeaders = mapM_ addBlockHeader -instance Monad m => BlockHeaders (StateT HeaderMemory m) where - addBlockHeader = modify . addBlockHeaderMemory - getBlockHeader bh = getBlockHeaderMemory bh <$> State.get - getBestBlockHeader = gets memoryBestHeader - setBestBlockHeader bn = modify $ \s -> s{memoryBestHeader = bn} +instance (Monad m) => BlockHeaders (StateT HeaderMemory m) where + addBlockHeader = modify . addBlockHeaderMemory + getBlockHeader bh = getBlockHeaderMemory bh <$> State.get + getBestBlockHeader = gets (.best) + setBestBlockHeader bn = modify $ \s -> s {best = bn} -- | Initialize memory-based chain. initialChain :: Network -> HeaderMemory initialChain net = - HeaderMemory - { memoryHeaderMap = genesisMap net - , memoryBestHeader = genesisNode net - } + HeaderMemory + { blocks = genesisMap net, + best = genesisNode net + } -- | Initialize map for memory-based chain. genesisMap :: Network -> BlockMap genesisMap net = - HashMap.singleton - (shortBlockHash (headerHash (getGenesisHeader net))) - (toShort (runPutS (serialize (genesisNode net)))) + HashMap.singleton + (shortBlockHash (headerHash net.genesisHeader)) + (toShort (runPutS (serialize (genesisNode net)))) -- | Add block header to memory block map. addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory -addBlockHeaderMemory bn s@HeaderMemory{..} = - let bm' = addBlockToMap bn memoryHeaderMap - in s{memoryHeaderMap = bm'} +addBlockHeaderMemory bn s = s {blocks = addBlockToMap bn s.blocks} -- | Get block header from memory block map. getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode -getBlockHeaderMemory bh HeaderMemory{..} = do - bs <- shortBlockHash bh `HashMap.lookup` memoryHeaderMap - eitherToMaybe . runGetS deserialize $ fromShort bs +getBlockHeaderMemory bh s = do + bs <- shortBlockHash bh `HashMap.lookup` s.blocks + eitherToMaybe . runGetS deserialize $ fromShort bs -{- | Calculate short block hash taking eight non-zero bytes from the 16-byte - hash. This function will take the bytes that are not on the zero-side of the - hash, making colissions between short block hashes difficult. --} +-- | Calculate short block hash taking eight non-zero bytes from the 16-byte +-- hash. This function will take the bytes that are not on the zero-side of the +-- hash, making colissions between short block hashes difficult. shortBlockHash :: BlockHash -> ShortBlockHash shortBlockHash = - either error id . runGetS deserialize . B.take 8 . runPutS . serialize + either error id . runGetS deserialize . B.take 8 . runPutS . serialize -- | Add a block to memory-based block map. addBlockToMap :: BlockNode -> BlockMap -> BlockMap addBlockToMap node = - HashMap.insert - (shortBlockHash $ headerHash $ nodeHeader node) - (toShort $ runPutS $ serialize node) + HashMap.insert + (shortBlockHash $ headerHash $ node.header) + (toShort $ runPutS $ serialize node) -{- | Get the ancestor of the provided 'BlockNode' at the specified - 'BlockHeight'. --} +-- | Get the ancestor of the provided 'BlockNode' at the specified +-- 'BlockHeight'. getAncestor :: - BlockHeaders m => - BlockHeight -> - BlockNode -> - m (Maybe BlockNode) + (BlockHeaders m) => + BlockHeight -> + BlockNode -> + m (Maybe BlockNode) getAncestor height node - | height > nodeHeight node = return Nothing - | otherwise = go node + | height > node.height = return Nothing + | otherwise = go node where - e1 = error "Could not get skip header" - e2 = error "Could not get previous block header" + e1 = error "Could not get current walk skip" + e2 = error "Could not get previous walk skip" go walk - | nodeHeight walk > height = - let heightSkip = skipHeight (nodeHeight walk) - heightSkipPrev = skipHeight (nodeHeight walk - 1) - in if not (isGenesis walk) - && ( heightSkip == height - || ( heightSkip > height - && not - ( heightSkipPrev < heightSkip - 2 - && heightSkipPrev >= height - ) - ) - ) - then do - walk' <- fromMaybe e1 <$> getBlockHeader (nodeSkip walk) - go walk' - else do - walk' <- - fromMaybe e2 - <$> getBlockHeader (prevBlock (nodeHeader walk)) - go walk' - | otherwise = return $ Just walk + | walk.height > height = + let height_b = skipHeight (walk.height) + height_a = skipHeight (walk.height - 1) + not_genesis = not (isGenesis walk) + is_b = height_b == height + below_b = height_b > height + at_or_below_a = height <= height_a + far_enough = height_b - 2 > height_a && at_or_below_a + recurse_b = below_b && not far_enough + cond = not_genesis && (is_b || recurse_b) + in if cond + then do + walk' <- fromMaybe e1 <$> getBlockHeader walk.skip + go walk' + else do + walk' <- fromMaybe e2 <$> getBlockHeader walk.header.prev + go walk' + | otherwise = return $ Just walk -- | Is the provided 'BlockNode' the Genesis block? isGenesis :: BlockNode -> Bool -isGenesis BlockNode{nodeHeight = 0} = True +isGenesis BlockNode {height = 0} = True isGenesis _ = False -- | Build the genesis 'BlockNode' for the supplied 'Network'. genesisNode :: Network -> BlockNode genesisNode net = - BlockNode - { nodeHeader = getGenesisHeader net - , nodeHeight = 0 - , nodeWork = headerWork (getGenesisHeader net) - , nodeSkip = headerHash (getGenesisHeader net) - } + BlockNode + { header = net.genesisHeader, + height = 0, + work = headerWork net.genesisHeader, + skip = headerHash net.genesisHeader + } -{- | Validate a list of continuous block headers and import them to the - block chain. Return 'Left' on failure with error information. --} +-- | Validate a list of continuous block headers and import them to the +-- block chain. Return 'Left' on failure with error information. connectBlocks :: - BlockHeaders m => - Network -> - -- | current time - Timestamp -> - [BlockHeader] -> - m (Either String [BlockNode]) + (BlockHeaders m) => + Network -> + -- | current time + Timestamp -> + [BlockHeader] -> + m (Either String [BlockNode]) connectBlocks _ _ [] = return $ Right [] connectBlocks net t bhs@(bh : _) = - runExceptT $ do - unless (chained bhs) $ - throwError "Blocks to connect do not form a chain" - par <- - maybeToExceptT - "Could not get parent block" - (MaybeT (parentBlock bh)) - pars <- lift $ getParents 10 par - bb <- lift getBestBlockHeader - go par [] bb par pars bhs >>= \case - bns@(bn : _) -> do - lift $ addBlockHeaders bns - let bb' = chooseBest bn bb - when (bb' /= bb) $ lift $ setBestBlockHeader bb' - return bns - _ -> undefined + runExceptT $ do + unless (chained bhs) $ + throwError "Blocks to connect do not form a chain" + par <- + maybeToExceptT + "Could not get parent block" + (MaybeT (parentBlock bh)) + pars <- lift $ getParents 10 par + bb <- lift getBestBlockHeader + go par [] bb par pars bhs >>= \case + bns@(bn : _) -> do + lift $ addBlockHeaders bns + let bb' = chooseBest bn bb + when (bb' /= bb) $ lift $ setBestBlockHeader bb' + return bns + _ -> undefined where - chained (h1 : h2 : hs) = headerHash h1 == prevBlock h2 && chained (h2 : hs) + chained (h1 : h2 : hs) = headerHash h1 == h2.prev && chained (h2 : hs) chained _ = True skipit lbh ls par - | sh == nodeHeight lbh = return lbh - | sh < nodeHeight lbh = do - skM <- lift $ getAncestor sh lbh - case skM of - Just sk -> return sk - Nothing -> - throwError $ - "BUG: Could not get skip for block " - ++ show (headerHash $ nodeHeader par) - | otherwise = do - let sn = ls !! fromIntegral (nodeHeight par - sh) - when (nodeHeight sn /= sh) $ - throwError "BUG: Node height not right in skip" - return sn + | sh == lbh.height = return lbh + | sh < lbh.height = do + skM <- lift $ getAncestor sh lbh + case skM of + Just sk -> return sk + Nothing -> + throwError $ + "BUG: Could not get skip for block " + ++ show (headerHash $ par.header) + | otherwise = do + let sn = ls !! fromIntegral (par.height - sh) + when (sn.height /= sh) $ + throwError "BUG: Node height not right in skip" + return sn where - sh = skipHeight (nodeHeight par + 1) + sh = skipHeight (par.height + 1) go _ acc _ _ _ [] = return acc go lbh acc bb par pars (h : hs) = do - sk <- skipit lbh acc par - bn <- ExceptT . return $ validBlock net t bb par pars h sk - go lbh (bn : acc) (chooseBest bn bb) bn (take 10 $ par : pars) hs + sk <- skipit lbh acc par + bn <- ExceptT . return $ validBlock net t bb par pars h sk + go lbh (bn : acc) (chooseBest bn bb) bn (take 10 $ par : pars) hs -{- | Block's parent. If the block header is in the store, its parent must also - be there. No block header get deleted or pruned from the store. --} +-- | Block's parent. If the block header is in the store, its parent must also +-- be there. No block header get deleted or pruned from the store. parentBlock :: - BlockHeaders m => - BlockHeader -> - m (Maybe BlockNode) -parentBlock bh = getBlockHeader (prevBlock bh) + (BlockHeaders m) => + BlockHeader -> + m (Maybe BlockNode) +parentBlock = getBlockHeader . (.prev) -{- | Validate and connect single block header to the block chain. Return 'Left' - if fails to be validated. --} +-- | Validate and connect single block header to the block chain. Return 'Left' +-- if fails to be validated. connectBlock :: - BlockHeaders m => - Network -> - -- | current time - Timestamp -> - BlockHeader -> - m (Either String BlockNode) + (BlockHeaders m) => + Network -> + -- | current time + Timestamp -> + BlockHeader -> + m (Either String BlockNode) connectBlock net t bh = - runExceptT $ do - par <- - maybeToExceptT - "Could not get parent block" - (MaybeT (parentBlock bh)) - pars <- lift $ getParents 10 par - skM <- lift $ getAncestor (skipHeight (nodeHeight par + 1)) par - sk <- - case skM of - Just sk -> return sk - Nothing -> - throwError $ - "BUG: Could not get skip for block " - ++ show (headerHash $ nodeHeader par) - bb <- lift getBestBlockHeader - bn <- ExceptT . return $ validBlock net t bb par pars bh sk - let bb' = chooseBest bb bn - lift $ addBlockHeader bn - when (bb /= bb') . lift $ setBestBlockHeader bb' - return bn + runExceptT $ do + par <- + maybeToExceptT + "Could not get parent block" + (MaybeT (parentBlock bh)) + pars <- lift $ getParents 10 par + skM <- lift $ getAncestor (skipHeight (par.height + 1)) par + sk <- + case skM of + Just sk -> return sk + Nothing -> + throwError $ + "BUG: Could not get skip for block " + ++ show (headerHash $ par.header) + bb <- lift getBestBlockHeader + bn <- ExceptT . return $ validBlock net t bb par pars bh sk + let bb' = chooseBest bb bn + lift $ addBlockHeader bn + when (bb /= bb') . lift $ setBestBlockHeader bb' + return bn -- | Validate this block header. Build a 'BlockNode' if successful. validBlock :: - Network -> - -- | current time - Timestamp -> - -- | best block - BlockNode -> - -- | immediate parent - BlockNode -> - -- | 10 parents above - [BlockNode] -> - -- | header to validate - BlockHeader -> - -- | skip node (black magic) - BlockNode -> - Either String BlockNode + Network -> + -- | current time + Timestamp -> + -- | best block + BlockNode -> + -- | immediate parent + BlockNode -> + -- | 10 parents above + [BlockNode] -> + -- | header to validate + BlockHeader -> + -- | skip node (black magic) + BlockNode -> + Either String BlockNode validBlock net t bb par pars bh sk = do - let mt = medianTime . map (blockTimestamp . nodeHeader) $ par : pars - nt = blockTimestamp bh - hh = headerHash bh - nv = blockVersion bh - ng = nodeHeight par + 1 - aw = nodeWork par + headerWork bh - unless (isValidPOW net bh) $ - Left $ "Proof of work failed: " ++ show (headerHash bh) - unless (nt <= t + 2 * 60 * 60) $ - Left $ "Invalid header timestamp: " ++ show nt - unless (nt >= mt) $ - Left $ "Block timestamp too early: " ++ show nt - unless (afterLastCP net (nodeHeight bb) ng) $ - Left $ "Rewriting pre-checkpoint chain: " ++ show ng - unless (validCP net ng hh) $ - Left $ "Rejected checkpoint: " ++ show ng - unless (bip34 net ng hh) $ - Left $ "Rejected BIP-34 block: " ++ show hh - unless (validVersion net ng nv) $ - Left $ "Invalid block version: " ++ show nv - return - BlockNode - { nodeHeader = bh - , nodeHeight = ng - , nodeWork = aw - , nodeSkip = headerHash $ nodeHeader sk - } + let mt = medianTime . map (.header.timestamp) $ par : pars + nt = bh.timestamp + hh = headerHash bh + nv = bh.version + ng = par.height + 1 + aw = par.work + headerWork bh + unless (isValidPOW net bh) $ + Left $ + "Proof of work failed: " ++ show (headerHash bh) + unless (nt <= t + 2 * 60 * 60) $ + Left $ + "Invalid header timestamp: " ++ show nt + unless (nt >= mt) $ + Left $ + "Block timestamp too early: " ++ show nt + unless (afterLastCP net (bb.height) ng) $ + Left $ + "Rewriting pre-checkpoint chain: " ++ show ng + unless (validCP net ng hh) $ + Left $ + "Rejected checkpoint: " ++ show ng + unless (bip34 net ng hh) $ + Left $ + "Rejected BIP-34 block: " ++ show hh + unless (validVersion net ng nv) $ + Left $ + "Invalid block version: " ++ show nv + return + BlockNode + { header = bh, + height = ng, + work = aw, + skip = headerHash sk.header + } -{- | Return the median of all provided timestamps. Can be unsorted. Error on - empty list. --} +-- | Return the median of all provided timestamps. Can be unsorted. Error on +-- empty list. medianTime :: [Timestamp] -> Timestamp medianTime ts - | null ts = error "Cannot compute median time of empty header list" - | otherwise = sort ts !! (length ts `div` 2) + | null ts = error "Cannot compute median time of empty header list" + | otherwise = sort ts !! (length ts `div` 2) -{- | Calculate the height of the skip (magic) block that corresponds to the - given height. The block hash of the ancestor at that height will be placed on - the 'BlockNode' structure to help locate ancestors at any height quickly. --} +-- | Calculate the height of the skip (magic) block that corresponds to the +-- given height. The block hash of the ancestor at that height will be placed on +-- the 'BlockNode' structure to help locate ancestors at any height quickly. skipHeight :: BlockHeight -> BlockHeight skipHeight height - | height < 2 = 0 - | height .&. 1 /= 0 = invertLowestOne (invertLowestOne $ height - 1) + 1 - | otherwise = invertLowestOne height + | height < 2 = 0 + | height .&. 1 /= 0 = invertLowestOne (invertLowestOne $ height - 1) + 1 + | otherwise = invertLowestOne height -- | Part of the skip black magic calculation. invertLowestOne :: BlockHeight -> BlockHeight @@ -464,299 +446,287 @@ invertLowestOne height = height .&. (height - 1) -- | Get a number of parents for the provided block. getParents :: - BlockHeaders m => - Int -> - BlockNode -> - -- | starts from immediate parent - m [BlockNode] + (BlockHeaders m) => + Int -> + BlockNode -> + -- | starts from immediate parent + m [BlockNode] getParents = getpars [] where getpars acc 0 _ = return $ reverse acc - getpars acc n BlockNode{..} - | nodeHeight == 0 = return $ reverse acc - | otherwise = do - parM <- getBlockHeader $ prevBlock nodeHeader - case parM of - Just bn -> getpars (bn : acc) (n - 1) bn - Nothing -> error "BUG: All non-genesis blocks should have a parent" + getpars acc n BlockNode {..} + | height == 0 = return $ reverse acc + | otherwise = do + parM <- getBlockHeader header.prev + case parM of + Just bn -> getpars (bn : acc) (n - 1) bn + Nothing -> error "BUG: All non-genesis blocks should have a parent" -- | Verify that checkpoint location is valid. validCP :: - Network -> - -- | new child height - BlockHeight -> - -- | new child hash - BlockHash -> - Bool + Network -> + -- | new child height + BlockHeight -> + -- | new child hash + BlockHash -> + Bool validCP net height newChildHash = - case lookup height (getCheckpoints net) of - Just cpHash -> cpHash == newChildHash - Nothing -> True + case lookup height net.checkpoints of + Just cpHash -> cpHash == newChildHash + Nothing -> True -{- | New block height above the last checkpoint imported. Used to prevent a - reorg below the highest checkpoint that was already imported. --} +-- | New block height above the last checkpoint imported. Used to prevent a +-- reorg below the highest checkpoint that was already imported. afterLastCP :: - Network -> - -- | best height - BlockHeight -> - -- | new imported block height - BlockHeight -> - Bool + Network -> + -- | best height + BlockHeight -> + -- | new imported block height + BlockHeight -> + Bool afterLastCP net bestHeight newChildHeight = - case lM of - Just l -> l < newChildHeight - Nothing -> True + case lM of + Just l -> l < newChildHeight + Nothing -> True where lM = - listToMaybe . reverse $ - [c | (c, _) <- getCheckpoints net, c <= bestHeight] + listToMaybe . reverse $ + [c | (c, _) <- net.checkpoints, c <= bestHeight] -{- | This block should be at least version 2 (BIP34). Block height must be - included in the coinbase transaction to prevent non-unique transaction - hashes. --} +-- | This block should be at least version 2 (BIP34). Block height must be +-- included in the coinbase transaction to prevent non-unique transaction +-- hashes. bip34 :: - Network -> - -- | new child height - BlockHeight -> - -- | new child hash - BlockHash -> - Bool + Network -> + -- | new child height + BlockHeight -> + -- | new child hash + BlockHash -> + Bool bip34 net height hsh - | fst (getBip34Block net) == 0 = True - | fst (getBip34Block net) == height = snd (getBip34Block net) == hsh - | otherwise = True + | fst net.bip34Block == 0 = True + | fst net.bip34Block == height = snd net.bip34Block == hsh + | otherwise = True -- | Check if the provided block height and version are valid. validVersion :: - Network -> - -- | new child height - BlockHeight -> - -- | new child version - Word32 -> - Bool + Network -> + -- | new child height + BlockHeight -> + -- | new child version + Word32 -> + Bool validVersion net height version - | version < 2 = height < fst (getBip34Block net) - | version < 3 = height < getBip66Height net - | version < 4 = height < getBip65Height net - | otherwise = True + | version < 2 = height < fst net.bip34Block + | version < 3 = height < net.bip66Height + | version < 4 = height < net.bip65Height + | otherwise = True -{- | Find last block with normal, as opposed to minimum difficulty (for test - networks). --} -lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode -lastNoMinDiff _ bn@BlockNode{nodeHeight = 0} = return bn -lastNoMinDiff net bn@BlockNode{..} = do - let i = nodeHeight `mod` diffInterval net /= 0 - c = encodeCompact (getPowLimit net) - l = blockBits nodeHeader == c - e1 = - error $ - "Could not get block header for parent of " - ++ show (headerHash nodeHeader) - if i && l - then do - bn' <- fromMaybe e1 <$> getBlockHeader (prevBlock nodeHeader) - lastNoMinDiff net bn' - else return bn +-- | Find last block with normal, as opposed to minimum difficulty (for test +-- networks). +lastNoMinDiff :: (BlockHeaders m) => Network -> BlockNode -> m BlockNode +lastNoMinDiff _ bn@BlockNode {height = 0} = return bn +lastNoMinDiff net bn = do + let i = bn.height `mod` diffInterval net /= 0 + c = encodeCompact net.powLimit + l = bn.header.bits == c + e1 = + error $ + "Could not get block header for parent of " + ++ show (headerHash bn.header) + if i && l + then do + bn' <- fromMaybe e1 <$> getBlockHeader (bn.header.prev) + lastNoMinDiff net bn' + else return bn -{- | Returns the work required on a block header given the previous block. This - coresponds to @bitcoind@ function @GetNextWorkRequired@ in @main.cpp@. --} +-- | Returns the work required on a block header given the previous block. This +-- coresponds to @bitcoind@ function @GetNextWorkRequired@ in @main.cpp@. nextWorkRequired :: - BlockHeaders m => - Network -> - BlockNode -> - BlockHeader -> - m Word32 + (BlockHeaders m) => + Network -> + BlockNode -> + BlockHeader -> + m Word32 nextWorkRequired net par bh = do - ma <- getAsertAnchor net - case asert ma <|> daa <|> eda <|> pow of - Just f -> f par bh - Nothing -> error "Could not determine difficulty algorithm" + ma <- getAsertAnchor net + case asert ma <|> daa <|> eda <|> pow of + Just f -> f par bh + Nothing -> error "Could not determine difficulty algorithm" where asert ma = do - anchor <- ma - guard (nodeHeight par > nodeHeight anchor) - return $ nextAsertWorkRequired net anchor + anchor <- ma + guard (par.height > anchor.height) + return $ nextAsertWorkRequired net anchor daa = do - daa_height <- getDaaBlockHeight net - guard (nodeHeight par + 1 >= daa_height) - return $ nextDaaWorkRequired net + daa_height <- net.daaHeight + guard (par.height + 1 >= daa_height) + return $ nextDaaWorkRequired net eda = do - eda_height <- getEdaBlockHeight net - guard (nodeHeight par + 1 >= eda_height) - return $ nextEdaWorkRequired net + eda_height <- net.edaHeight + guard (par.height + 1 >= eda_height) + return $ nextEdaWorkRequired net pow = return $ nextPowWorkRequired net -{- | Find out the next amount of work required according to the Emergency - Difficulty Adjustment (EDA) algorithm from Bitcoin Cash. --} +-- | Find out the next amount of work required according to the Emergency +-- Difficulty Adjustment (EDA) algorithm from Bitcoin Cash. nextEdaWorkRequired :: - BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 + (BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32 nextEdaWorkRequired net par bh - | nodeHeight par + 1 `mod` diffInterval net == 0 = - nextWorkRequired net par bh - | minDifficulty = return (encodeCompact (getPowLimit net)) - | blockBits (nodeHeader par) == encodeCompact (getPowLimit net) = - return (encodeCompact (getPowLimit net)) - | otherwise = do - par6 <- fromMaybe e1 <$> getAncestor (nodeHeight par - 6) par - pars <- getParents 10 par - pars6 <- getParents 10 par6 - let par6med = - medianTime $ map (blockTimestamp . nodeHeader) (par6 : pars6) - parmed = medianTime $ map (blockTimestamp . nodeHeader) (par : pars) - mtp6 = parmed - par6med - if mtp6 < 12 * 3600 - then return $ blockBits (nodeHeader par) - else - return $ - let (diff, _) = decodeCompact (blockBits (nodeHeader par)) - ndiff = diff + (diff `shiftR` 2) - in if getPowLimit net > ndiff - then encodeCompact (getPowLimit net) - else encodeCompact ndiff + | par.height + 1 `mod` diffInterval net == 0 = + nextWorkRequired net par bh + | mindiff = return (encodeCompact net.powLimit) + | par.header.bits == encodeCompact net.powLimit = + return (encodeCompact net.powLimit) + | otherwise = do + par6 <- fromMaybe e1 <$> getAncestor (par.height - 6) par + pars <- getParents 10 par + pars6 <- getParents 10 par6 + let par6med = + medianTime $ map (.header.timestamp) (par6 : pars6) + parmed = medianTime $ map (.header.timestamp) (par : pars) + mtp6 = parmed - par6med + if mtp6 < 12 * 3600 + then return $ par.header.bits + else + return $ + let (diff, _) = decodeCompact par.header.bits + ndiff = diff + (diff `shiftR` 2) + in if net.powLimit > ndiff + then encodeCompact net.powLimit + else encodeCompact ndiff where - minDifficulty = - blockTimestamp bh - > blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 + mindiff = bh.timestamp > par.header.timestamp + net.targetSpacing * 2 e1 = error "Could not get seventh ancestor of block" -{- | Find the next amount of work required according to the Difficulty - Adjustment Algorithm (DAA) from Bitcoin Cash. --} +-- | Find the next amount of work required according to the Difficulty +-- Adjustment Algorithm (DAA) from Bitcoin Cash. nextDaaWorkRequired :: - BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 + (BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32 nextDaaWorkRequired net par bh - | minDifficulty = return (encodeCompact (getPowLimit net)) - | otherwise = do - unless (height >= diffInterval net) $ - error "Block height below difficulty interval" - l <- getSuitableBlock par - par144 <- fromMaybe e1 <$> getAncestor (height - 144) par - f <- getSuitableBlock par144 - let nextTarget = computeTarget net f l - if nextTarget > getPowLimit net - then return $ encodeCompact (getPowLimit net) - else return $ encodeCompact nextTarget + | mindiff = return (encodeCompact net.powLimit) + | otherwise = do + unless (par.height >= diffInterval net) $ + error "Block height below difficulty interval" + l <- getSuitableBlock par + par144 <- fromMaybe e1 <$> getAncestor (par.height - 144) par + f <- getSuitableBlock par144 + let nextTarget = computeTarget net f l + if nextTarget > net.powLimit + then return $ encodeCompact net.powLimit + else return $ encodeCompact nextTarget where - height = nodeHeight par e1 = error "Cannot get ancestor at parent - 144 height" - minDifficulty = - blockTimestamp bh - > blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 + mindiff = bh.timestamp > par.header.timestamp + net.targetSpacing * 2 -mtp :: BlockHeaders m => BlockNode -> m Timestamp +mtp :: (BlockHeaders m) => BlockNode -> m Timestamp mtp bn - | nodeHeight bn == 0 = return 0 - | otherwise = do - pars <- getParents 11 bn - return $ medianTime (map (blockTimestamp . nodeHeader) pars) + | bn.height == 0 = return 0 + | otherwise = do + pars <- getParents 11 bn + return $ medianTime (map (.header.timestamp) pars) firstGreaterOrEqual :: - BlockHeaders m => - Network -> - (BlockNode -> m Ordering) -> - m (Maybe BlockNode) + (BlockHeaders m) => + Network -> + (BlockNode -> m Ordering) -> + m (Maybe BlockNode) firstGreaterOrEqual = binSearch False lastSmallerOrEqual :: - BlockHeaders m => - Network -> - (BlockNode -> m Ordering) -> - m (Maybe BlockNode) + (BlockHeaders m) => + Network -> + (BlockNode -> m Ordering) -> + m (Maybe BlockNode) lastSmallerOrEqual = binSearch True binSearch :: - BlockHeaders m => - Bool -> - Network -> - (BlockNode -> m Ordering) -> - m (Maybe BlockNode) + (BlockHeaders m) => + Bool -> + Network -> + (BlockNode -> m Ordering) -> + m (Maybe BlockNode) binSearch top net f = runMaybeT $ do - (a, b) <- lift $ extremes net - go a b + (a, b) <- lift $ extremes net + go a b where go a b = do - m <- lift $ middleBlock a b - a' <- lift $ f a - b' <- lift $ f b - m' <- lift $ f m - r (a, a') (b, b') (m, m') + m <- lift $ middleBlock a b + a' <- lift $ f a + b' <- lift $ f b + m' <- lift $ f m + r (a, a') (b, b') (m, m') r (a, a') (b, b') (m, m') - | out_of_bounds a' b' = mzero - | select_first a' = return a - | select_last b' = return b - | no_middle a b = choose_one a b - | is_between a' m' = go a m - | is_between m' b' = go m b - | otherwise = mzero + | out_of_bounds a' b' = mzero + | select_first a' = return a + | select_last b' = return b + | no_middle a b = choose_one a b + | is_between a' m' = go a m + | is_between m' b' = go m b + | otherwise = mzero select_first a' - | not top = a' /= LT - | otherwise = False + | not top = a' /= LT + | otherwise = False select_last b' - | top = b' /= GT - | otherwise = False + | top = b' /= GT + | otherwise = False out_of_bounds a' b' - | top = a' == GT - | otherwise = b' == LT - no_middle a b = nodeHeight b - nodeHeight a <= 1 + | top = a' == GT + | otherwise = b' == LT + no_middle a b = b.height - a.height <= 1 is_between a' b' = a' /= GT && b' /= LT choose_one a b - | top = return a - | otherwise = return b + | top = return a + | otherwise = return b -extremes :: BlockHeaders m => Network -> m (BlockNode, BlockNode) +extremes :: (BlockHeaders m) => Network -> m (BlockNode, BlockNode) extremes net = do - b <- getBestBlockHeader - return (genesisNode net, b) + b <- getBestBlockHeader + return (genesisNode net, b) -middleBlock :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode +middleBlock :: (BlockHeaders m) => BlockNode -> BlockNode -> m BlockNode middleBlock a b = - getAncestor h b >>= \case - Nothing -> error "You fell into a pit full of mud and snakes" - Just x -> return x + getAncestor h b >>= \case + Nothing -> error "You fell into a pit full of mud and snakes" + Just x -> return x where - h = middleOf (nodeHeight a) (nodeHeight b) + h = middleOf a.height b.height -middleOf :: Integral a => a -> a -> a +middleOf :: (Integral a) => a -> a -> a middleOf a b = a + ((b - a) `div` 2) -- TODO: Use known anchor after fork -getAsertAnchor :: BlockHeaders m => Network -> m (Maybe BlockNode) +getAsertAnchor :: (BlockHeaders m) => Network -> m (Maybe BlockNode) getAsertAnchor net = - case getAsertActivationTime net of - Nothing -> return Nothing - Just act -> firstGreaterOrEqual net (f act) + case net.asertActivationTime of + Nothing -> return Nothing + Just act -> firstGreaterOrEqual net (f act) where f act bn = do - m <- mtp bn - return $ compare m act + m <- mtp bn + return $ compare m act -- | Find the next amount of work required according to the aserti3-2d algorithm. nextAsertWorkRequired :: - BlockHeaders m => - Network -> - BlockNode -> - BlockNode -> - BlockHeader -> - m Word32 + (BlockHeaders m) => + Network -> + BlockNode -> + BlockNode -> + BlockHeader -> + m Word32 nextAsertWorkRequired net anchor par bh = do - anchor_parent <- - fromMaybe e_fork - <$> getBlockHeader (prevBlock (nodeHeader anchor)) - let anchor_parent_time = toInteger $ blockTimestamp $ nodeHeader anchor_parent - time_diff = current_time - anchor_parent_time - return $ computeAsertBits halflife anchor_bits time_diff height_diff + anchor_parent <- + fromMaybe e_fork <$> getBlockHeader anchor.header.prev + let anchor_parent_time = toInteger anchor_parent.header.timestamp + time_diff = current_time - anchor_parent_time + return $ computeAsertBits halflife anchor_bits time_diff height_diff where - halflife = getAsertHalfLife net - anchor_height = toInteger $ nodeHeight anchor - anchor_bits = blockBits $ nodeHeader anchor - current_height = toInteger (nodeHeight par) + 1 + halflife = net.asertHalfLife + anchor_height = toInteger anchor.height + anchor_bits = anchor.header.bits + current_height = toInteger par.height + 1 height_diff = current_height - anchor_height - current_time = toInteger $ blockTimestamp bh + current_time = toInteger bh.timestamp e_fork = error "Could not get fork block header" idealBlockTime :: Integer @@ -775,234 +745,230 @@ maxTarget :: Integer maxTarget = fst $ decodeCompact maxBits computeAsertBits :: - Integer -> - Word32 -> - Integer -> - Integer -> - Word32 + Integer -> + Word32 -> + Integer -> + Integer -> + Word32 computeAsertBits halflife anchor_bits time_diff height_diff = - if e2 >= 0 && e2 < 65536 - then - if g4 == 0 - then encodeCompact 1 - else - if g4 > maxTarget - then maxBits - else encodeCompact g4 - else error $ "Exponent not in range: " ++ show e2 + if e2 >= 0 && e2 < 65536 + then + if g4 == 0 + then encodeCompact 1 + else + if g4 > maxTarget + then maxBits + else encodeCompact g4 + else error $ "Exponent not in range: " ++ show e2 where g1 = fst (decodeCompact anchor_bits) e1 = - ((time_diff - idealBlockTime * (height_diff + 1)) * radix) - `quot` halflife + ((time_diff - idealBlockTime * (height_diff + 1)) * radix) + `quot` halflife s = e1 `shiftR` rBits e2 = e1 - s * radix g2 = - g1 - * ( radix - + ( (195766423245049 * e2 + 971821376 * e2 ^ 2 + 5127 * e2 ^ 3 + 2 ^ 47) - `shiftR` (rBits * 3) - ) - ) + g1 + * ( radix + + ( (195766423245049 * e2 + 971821376 * e2 ^ 2 + 5127 * e2 ^ 3 + 2 ^ 47) + `shiftR` (rBits * 3) + ) + ) g3 = - if s < 0 - then g2 `shiftR` negate (fromIntegral s) - else g2 `shiftL` fromIntegral s + if s < 0 + then g2 `shiftR` negate (fromIntegral s) + else g2 `shiftL` fromIntegral s g4 = g3 `shiftR` rBits -- | Compute Bitcoin Cash DAA target for a new block. computeTarget :: Network -> BlockNode -> BlockNode -> Integer computeTarget net f l = - let work = (nodeWork l - nodeWork f) * fromIntegral (getTargetSpacing net) - actualTimespan = - blockTimestamp (nodeHeader l) - blockTimestamp (nodeHeader f) - actualTimespan' - | actualTimespan > 288 * getTargetSpacing net = - 288 * getTargetSpacing net - | actualTimespan < 72 * getTargetSpacing net = - 72 * getTargetSpacing net - | otherwise = actualTimespan - work' = work `div` fromIntegral actualTimespan' - in 2 ^ (256 :: Integer) `div` work' + let work = (l.work - f.work) * fromIntegral net.targetSpacing + tspan = l.header.timestamp - f.header.timestamp + tspan' + | tspan > 288 * net.targetSpacing = + 288 * net.targetSpacing + | tspan < 72 * net.targetSpacing = + 72 * net.targetSpacing + | otherwise = tspan + work' = work `div` fromIntegral tspan' + in 2 ^ (256 :: Integer) `div` work' -- | Get suitable block for Bitcoin Cash DAA computation. -getSuitableBlock :: BlockHeaders m => BlockNode -> m BlockNode +getSuitableBlock :: (BlockHeaders m) => BlockNode -> m BlockNode getSuitableBlock par = do - unless (nodeHeight par >= 3) $ error "Block height is less than three" - blocks <- (par :) <$> getParents 2 par - return $ sortBy (compare `on` blockTimestamp . nodeHeader) blocks !! 1 + unless (par.height >= 3) $ error "Block height is less than three" + blocks <- (par :) <$> getParents 2 par + return $ sortBy (compare `on` (.header.timestamp)) blocks !! 1 -{- | Returns the work required on a block header given the previous block. This - coresponds to bitcoind function GetNextWorkRequired in main.cpp. --} +-- | Returns the work required on a block header given the previous block. This +-- coresponds to bitcoind function GetNextWorkRequired in main.cpp. nextPowWorkRequired :: - BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 + (BlockHeaders m) => Network -> BlockNode -> BlockHeader -> m Word32 nextPowWorkRequired net par bh - | nodeHeight par + 1 `mod` diffInterval net /= 0 = - if getAllowMinDifficultyBlocks net - then - if ht > pt + delta - then return $ encodeCompact (getPowLimit net) - else do - d <- lastNoMinDiff net par - return $ blockBits $ nodeHeader d - else return $ blockBits $ nodeHeader par - | otherwise = do - let rh = nodeHeight par - (diffInterval net - 1) - a <- fromMaybe e1 <$> getAncestor rh par - let t = blockTimestamp $ nodeHeader a - return $ calcNextWork net (nodeHeader par) t + | par.height + 1 `mod` diffInterval net /= 0 = + if net.minDiffBlocks + then + if ht > pt + delta + then return $ encodeCompact net.powLimit + else do + d <- lastNoMinDiff net par + return d.header.bits + else return par.header.bits + | otherwise = do + let rh = par.height - diffInterval net - 1 + a <- fromMaybe e1 <$> getAncestor rh par + let t = a.header.timestamp + return $ calcNextWork net par.header t where e1 = error "Could not get ancestor for block header" - pt = blockTimestamp $ nodeHeader par - ht = blockTimestamp bh - delta = getTargetSpacing net * 2 + pt = par.header.timestamp + ht = bh.timestamp + delta = net.targetSpacing * 2 -- | Computes the work required for the first block in a new retarget period. calcNextWork :: - Network -> - -- | last block in previous retarget (parent) - BlockHeader -> - -- | timestamp of first block in previous retarget - Timestamp -> - Word32 + Network -> + -- | last block in previous retarget (parent) + BlockHeader -> + -- | timestamp of first block in previous retarget + Timestamp -> + Word32 calcNextWork net header time - | getPowNoRetargetting net = blockBits header - | new > getPowLimit net = encodeCompact (getPowLimit net) - | otherwise = encodeCompact new + | net.powNoRetarget = header.bits + | new > net.powLimit = encodeCompact net.powLimit + | otherwise = encodeCompact new where - s = blockTimestamp header - time + s = header.timestamp - time n - | s < getTargetTimespan net `div` 4 = getTargetTimespan net `div` 4 - | s > getTargetTimespan net * 4 = getTargetTimespan net * 4 - | otherwise = s - l = fst $ decodeCompact $ blockBits header - new = l * fromIntegral n `div` fromIntegral (getTargetTimespan net) + | s < net.targetTimespan `div` 4 = net.targetTimespan `div` 4 + | s > net.targetTimespan * 4 = net.targetTimespan * 4 + | otherwise = s + l = fst $ decodeCompact header.bits + new = l * fromIntegral n `div` fromIntegral net.targetTimespan -{- | Returns True if the difficulty target (bits) of the header is valid and the - proof of work of the header matches the advertised difficulty target. This - function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in - @main.cpp@. --} +-- | Returns True if the difficulty target (bits) of the header is valid and the +-- proof of work of the header matches the advertised difficulty target. This +-- function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in +-- @main.cpp@. isValidPOW :: Network -> BlockHeader -> Bool isValidPOW net h - | target <= 0 || over || target > getPowLimit net = False - | otherwise = blockPOW (headerHash h) <= fromIntegral target + | target <= 0 || over || target > net.powLimit = False + | otherwise = blockPOW (headerHash h) <= fromIntegral target where - (target, over) = decodeCompact $ blockBits h + (target, over) = decodeCompact h.bits -- | Returns the proof of work of a block header hash as an 'Integer' number. blockPOW :: BlockHash -> Integer blockPOW = bsToInteger . B.reverse . runPutS . serialize -{- | Returns the work represented by this block. Work is defined as the number - of tries needed to solve a block in the average case with respect to the - target. --} +-- | Returns the work represented by this block. Work is defined as the number +-- of tries needed to solve a block in the average case with respect to the +-- target. headerWork :: BlockHeader -> Integer headerWork bh = largestHash `div` (target + 1) where - target = fst $ decodeCompact $ blockBits bh + target = fst $ decodeCompact bh.bits largestHash = 1 `shiftL` 256 -- | Number of blocks on average between difficulty cycles (2016 blocks). diffInterval :: Network -> Word32 -diffInterval net = getTargetTimespan net `div` getTargetSpacing net +diffInterval net = net.targetTimespan `div` net.targetSpacing -- | Compare two blocks to get the best. chooseBest :: BlockNode -> BlockNode -> BlockNode chooseBest b1 b2 - | nodeWork b1 == nodeWork b2 = - if nodeHeight b1 >= nodeHeight b2 - then b1 - else b2 - | nodeWork b1 > nodeWork b2 = b1 - | otherwise = b2 + | b1.work == b2.work = + if b1.height >= b2.height + then b1 + else b2 + | b1.work > b2.work = b1 + | otherwise = b2 -- | Get list of blocks for a block locator. -blockLocatorNodes :: BlockHeaders m => BlockNode -> m [BlockNode] +blockLocatorNodes :: (BlockHeaders m) => BlockNode -> m [BlockNode] blockLocatorNodes best = - reverse <$> go [] best 1 + reverse <$> go [] best 1 where e1 = error "Could not get ancestor" go loc bn n = - let loc' = bn : loc - n' = - if length loc' > 10 - then n * 2 - else 1 - in if nodeHeight bn < n' - then do - a <- fromMaybe e1 <$> getAncestor 0 bn - return $ a : loc' - else do - let h = nodeHeight bn - n' - bn' <- fromMaybe e1 <$> getAncestor h bn - go loc' bn' n' + let loc' = bn : loc + n' = + if length loc' > 10 + then n * 2 + else 1 + in if bn.height < n' + then do + a <- fromMaybe e1 <$> getAncestor 0 bn + return $ a : loc' + else do + let h = bn.height - n' + bn' <- fromMaybe e1 <$> getAncestor h bn + go loc' bn' n' -- | Get block locator. -blockLocator :: BlockHeaders m => BlockNode -> m BlockLocator -blockLocator bn = map (headerHash . nodeHeader) <$> blockLocatorNodes bn +blockLocator :: (BlockHeaders m) => BlockNode -> m BlockLocator +blockLocator bn = map (headerHash . (.header)) <$> blockLocatorNodes bn -- | Become rich beyond your wildest dreams. mineBlock :: Network -> Word32 -> BlockHeader -> BlockHeader mineBlock net seed h = - head - [ j - | i <- (+ seed) <$> [0 .. maxBound] - , let j = h{bhNonce = i} - , isValidPOW net j - ] + head + [ j + | i <- (+ seed) <$> [0 .. maxBound], + let j = h {nonce = i}, + isValidPOW net j + ] -- | Generate and append new blocks (mining). Only practical in regtest network. appendBlocks :: - Network -> - -- | random seed - Word32 -> - BlockHeader -> - Int -> - [BlockHeader] + Network -> + -- | random seed + Word32 -> + BlockHeader -> + Int -> + [BlockHeader] appendBlocks _ _ _ 0 = [] appendBlocks net seed bh i = - bh' : appendBlocks net seed bh' (i - 1) + bh' : appendBlocks net seed bh' (i - 1) where bh' = - mineBlock - net - seed - bh - { prevBlock = headerHash bh - , -- Just to make it different in every header - merkleRoot = sha256 $ runPutS $ serialize seed - } + mineBlock + net + seed + bh + { prev = headerHash bh, + -- Just to make it different in every header + merkle = sha256 $ runPutS $ serialize seed + } -- | Find the last common block ancestor between provided block headers. -splitPoint :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode +splitPoint :: (BlockHeaders m) => BlockNode -> BlockNode -> m BlockNode splitPoint l r = do - let h = min (nodeHeight l) (nodeHeight r) - ll <- fromMaybe e <$> getAncestor h l - lr <- fromMaybe e <$> getAncestor h r - f ll lr + let h = min l.height r.height + ll <- fromMaybe e <$> getAncestor h l + lr <- fromMaybe e <$> getAncestor h r + f ll lr where e = error "BUG: Could not get ancestor at lowest height" f ll lr = - if ll == lr - then return lr - else do - let h = nodeHeight ll - 1 - pl <- fromMaybe e <$> getAncestor h ll - pr <- fromMaybe e <$> getAncestor h lr - f pl pr + if ll == lr + then return lr + else do + let h = ll.height - 1 + pl <- fromMaybe e <$> getAncestor h ll + pr <- fromMaybe e <$> getAncestor h lr + f pl pr -- | Generate the entire Genesis block for 'Network'. -genesisBlock :: Network -> Block -genesisBlock net = Block (getGenesisHeader net) [genesisTx] +genesisBlock :: Network -> Ctx -> Block +genesisBlock net ctx = Block net.genesisHeader [genesisTx ctx] -- | Compute block subsidy at particular height. computeSubsidy :: Network -> BlockHeight -> Word64 computeSubsidy net height = - let halvings = height `div` getHalvingInterval net - ini = 50 * 100 * 1000 * 1000 - in if halvings >= 64 - then 0 - else ini `shiftR` fromIntegral halvings + let halvings = height `div` net.halvingInterval + ini = 50 * 100 * 1000 * 1000 + in if halvings >= 64 + then 0 + else ini `shiftR` fromIntegral halvings diff --git a/src/Haskoin/Block/Merkle.hs b/src/Haskoin/Block/Merkle.hs index e4e0ec92..32c4bae3 100644 --- a/src/Haskoin/Block/Merkle.hs +++ b/src/Haskoin/Block/Merkle.hs @@ -1,18 +1,20 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Block.Merkle -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Function to deal with Merkle trees inside blocks. --} -module Haskoin.Block.Merkle ( - -- * Merkle Blocks +-- | +-- Module : Haskoin.Block.Merkle +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Function to deal with Merkle trees inside blocks. +module Haskoin.Block.Merkle + ( -- * Merkle Blocks MerkleBlock (..), MerkleRoot, FlagBits, @@ -32,7 +34,8 @@ module Haskoin.Block.Merkle ( extractMatches, splitIn, boolsToWord8, -) where + ) +where import Control.DeepSeq import Control.Monad (forM_, replicateM, when) @@ -50,8 +53,8 @@ import Data.Word (Word32, Word8) import GHC.Generics import Haskoin.Block.Common import Haskoin.Crypto.Hash -import Haskoin.Data import Haskoin.Network.Common +import Haskoin.Network.Data import Haskoin.Transaction.Common -- | Hash of the block's Merkle root. @@ -63,53 +66,52 @@ type FlagBits = [Bool] -- | Partial Merkle tree for a filtered block. type PartialMerkleTree = [Hash256] -{- | Filtered block: a block with a partial Merkle tree that only includes the - transactions that pass a bloom filter that was negotiated. --} +-- | Filtered block: a block with a partial Merkle tree that only includes the +-- transactions that pass a bloom filter that was negotiated. data MerkleBlock = MerkleBlock - { -- | block header - merkleHeader :: !BlockHeader - , -- | total number of transactions in block - merkleTotalTxns :: !Word32 - , -- | hashes in depth-first order - mHashes :: !PartialMerkleTree - , -- | bits to rebuild partial merkle tree - mFlags :: !FlagBits - } - deriving (Eq, Show, Read, Generic, Hashable, NFData) + { -- | block header + header :: !BlockHeader, + -- | total number of transactions in block + txn :: !Word32, + -- | hashes in depth-first order + hashes :: !PartialMerkleTree, + -- | bits to rebuild partial merkle tree + flags :: !FlagBits + } + deriving (Eq, Show, Read, Generic, Hashable, NFData) instance Serial MerkleBlock where - deserialize = do - header <- deserialize - ntx <- getWord32le - (VarInt matchLen) <- deserialize - hashes <- replicateM (fromIntegral matchLen) deserialize - (VarInt flagLen) <- deserialize - ws <- replicateM (fromIntegral flagLen) getWord8 - return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws) + deserialize = do + header <- deserialize + ntx <- getWord32le + (VarInt matchLen) <- deserialize + hashes <- replicateM (fromIntegral matchLen) deserialize + (VarInt flagLen) <- deserialize + ws <- replicateM (fromIntegral flagLen) getWord8 + return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws) - serialize (MerkleBlock h ntx hashes flags) = do - serialize h - putWord32le ntx - putVarInt $ length hashes - forM_ hashes serialize - let ws = encodeMerkleFlags flags - putVarInt $ length ws - forM_ ws putWord8 + serialize (MerkleBlock h ntx hashes flags) = do + serialize h + putWord32le ntx + putVarInt $ length hashes + forM_ hashes serialize + let ws = encodeMerkleFlags flags + putVarInt $ length ws + forM_ ws putWord8 instance Binary MerkleBlock where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize MerkleBlock where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | Unpack Merkle flags into 'FlagBits' structure. decodeMerkleFlags :: [Word8] -> FlagBits decodeMerkleFlags ws = - [ b | p <- [0 .. length ws * 8 - 1], b <- [testBit (ws !! (p `div` 8)) (p `mod` 8)] - ] + [ b | p <- [0 .. length ws * 8 - 1], b <- [testBit (ws !! (p `div` 8)) (p `mod` 8)] + ] -- | Pack Merkle flags from 'FlagBits'. encodeMerkleFlags :: FlagBits -> [Word8] @@ -117,33 +119,32 @@ encodeMerkleFlags bs = map boolsToWord8 $ splitIn 8 bs -- | Computes the height of a Merkle tree. calcTreeHeight :: - -- | number of transactions (leaf nodes) - Int -> - -- | height of the merkle tree - Int + -- | number of transactions (leaf nodes) + Int -> + -- | height of the merkle tree + Int calcTreeHeight ntx - | ntx < 2 = 0 - | even ntx = 1 + calcTreeHeight (ntx `div` 2) - | otherwise = calcTreeHeight $ ntx + 1 + | ntx < 2 = 0 + | even ntx = 1 + calcTreeHeight (ntx `div` 2) + | otherwise = calcTreeHeight $ ntx + 1 -{- | Computes the width of a Merkle tree at a specific height. The transactions - are at height 0. --} +-- | Computes the width of a Merkle tree at a specific height. The transactions +-- are at height 0. calcTreeWidth :: - -- | number of transactions (leaf nodes) - Int -> - -- | height at which we want to compute the width - Int -> - -- | width of the Merkle tree - Int + -- | number of transactions (leaf nodes) + Int -> + -- | height at which we want to compute the width + Int -> + -- | width of the Merkle tree + Int calcTreeWidth ntx h = (ntx + (1 `shiftL` h) - 1) `shiftR` h -- | Computes the root of a Merkle tree from a list of leaf node hashes. buildMerkleRoot :: - -- | transaction hashes (leaf nodes) - [TxHash] -> - -- | root of the Merkle tree - MerkleRoot + -- | transaction hashes (leaf nodes) + [TxHash] -> + -- | root of the Merkle tree + MerkleRoot buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs -- | Concatenate and compute double SHA256. @@ -152,46 +153,44 @@ hash2 a b = doubleSHA256 $ runPutS (serialize a) <> runPutS (serialize b) -- | Computes the hash of a specific node in a Merkle tree. calcHash :: - -- | height of the node - Int -> - -- | position of the node (0 for the leftmost node) - Int -> - -- | transaction hashes (leaf nodes) - [TxHash] -> - -- | hash of the node at the specified position - Hash256 + -- | height of the node + Int -> + -- | position of the node (0 for the leftmost node) + Int -> + -- | transaction hashes (leaf nodes) + [TxHash] -> + -- | hash of the node at the specified position + Hash256 calcHash height pos txs - | height < 0 || pos < 0 = error "calcHash: Invalid parameters" - | height == 0 = getTxHash $ txs !! pos - | otherwise = hash2 left right + | height < 0 || pos < 0 = error "calcHash: Invalid parameters" + | height == 0 = (txs !! pos).get + | otherwise = hash2 left right where left = calcHash (height - 1) (pos * 2) txs right - | pos * 2 + 1 < calcTreeWidth (length txs) (height - 1) = - calcHash (height - 1) (pos * 2 + 1) txs - | otherwise = left + | pos * 2 + 1 < calcTreeWidth (length txs) (height - 1) = + calcHash (height - 1) (pos * 2 + 1) txs + | otherwise = left -{- | Build a partial Merkle tree. Provide a list of tuples with all transaction - hashes in the block, and whether the transaction is to be included in the - partial tree. Returns a flag bits structure and the computed partial Merkle - tree. --} +-- | Build a partial Merkle tree. Provide a list of tuples with all transaction +-- hashes in the block, and whether the transaction is to be included in the +-- partial tree. Returns a flag bits structure and the computed partial Merkle +-- tree. buildPartialMerkle :: - -- | transaction hash and whether to include - [(TxHash, Bool)] -> - -- | flag bits and partial Merkle tree - (FlagBits, PartialMerkleTree) + -- | transaction hash and whether to include + [(TxHash, Bool)] -> + -- | flag bits and partial Merkle tree + (FlagBits, PartialMerkleTree) buildPartialMerkle hs = traverseAndBuild (calcTreeHeight $ length hs) 0 hs -{- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle' - above. --} +-- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle' +-- above. traverseAndBuild :: - Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree) + Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree) traverseAndBuild height pos txs - | height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters" - | height == 0 || not match = ([match], [calcHash height pos t]) - | otherwise = (match : lb ++ rb, lh ++ rh) + | height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters" + | height == 0 || not match = ([match], [calcHash height pos t]) + | otherwise = (match : lb ++ rb, lh ++ rh) where t = map fst txs s = pos `shiftL` height @@ -199,88 +198,86 @@ traverseAndBuild height pos txs match = any snd $ take (e - s) $ drop s txs (lb, lh) = traverseAndBuild (height - 1) (pos * 2) txs (rb, rh) - | (pos * 2 + 1) < calcTreeWidth (length txs) (height - 1) = - traverseAndBuild (height - 1) (pos * 2 + 1) txs - | otherwise = ([], []) + | (pos * 2 + 1) < calcTreeWidth (length txs) (height - 1) = + traverseAndBuild (height - 1) (pos * 2 + 1) txs + | otherwise = ([], []) -- | Helper function to extract transaction hashes from partial Merkle tree. traverseAndExtract :: - Int -> - Int -> - Int -> - FlagBits -> - PartialMerkleTree -> - Maybe (MerkleRoot, [TxHash], Int, Int) + Int -> + Int -> + Int -> + FlagBits -> + PartialMerkleTree -> + Maybe (MerkleRoot, [TxHash], Int, Int) traverseAndExtract height pos ntx flags hashes - | null flags = Nothing - | height == 0 || not match = leafResult - | isNothing leftM = Nothing - | (pos * 2 + 1) >= calcTreeWidth ntx (height - 1) = - Just (hash2 lh lh, lm, lcf + 1, lch) - | isNothing rightM = Nothing - | otherwise = - Just (hash2 lh rh, lm ++ rm, lcf + rcf + 1, lch + rch) + | null flags = Nothing + | height == 0 || not match = leafResult + | isNothing leftM = Nothing + | (pos * 2 + 1) >= calcTreeWidth ntx (height - 1) = + Just (hash2 lh lh, lm, lcf + 1, lch) + | isNothing rightM = Nothing + | otherwise = + Just (hash2 lh rh, lm ++ rm, lcf + rcf + 1, lch + rch) where leafResult - | null hashes = Nothing - | otherwise = Just (h, [TxHash h | height == 0 && match], 1, 1) + | null hashes = Nothing + | otherwise = Just (h, [TxHash h | height == 0 && match], 1, 1) (match : fs) = flags (h : _) = hashes leftM = traverseAndExtract (height - 1) (pos * 2) ntx fs hashes (lh, lm, lcf, lch) = fromMaybe e leftM rightM = - traverseAndExtract - (height - 1) - (pos * 2 + 1) - ntx - (drop lcf fs) - (drop lch hashes) + traverseAndExtract + (height - 1) + (pos * 2 + 1) + ntx + (drop lcf fs) + (drop lch hashes) (rh, rm, rcf, rch) = fromMaybe e rightM e = error "traverseAndExtract: unexpected error extracting a Maybe value" -{- | Extracts the matching hashes from a partial merkle tree. This will return - the list of transaction hashes that have been included (set to true) in - a call to 'buildPartialMerkle'. --} +-- | Extracts the matching hashes from a partial merkle tree. This will return +-- the list of transaction hashes that have been included (set to true) in +-- a call to 'buildPartialMerkle'. extractMatches :: - Network -> - FlagBits -> - PartialMerkleTree -> - -- | number of transaction at height 0 (leaf nodes) - Int -> - -- | Merkle root and list of matching transaction hashes - Either String (MerkleRoot, [TxHash]) + Network -> + FlagBits -> + PartialMerkleTree -> + -- | number of transaction at height 0 (leaf nodes) + Int -> + -- | Merkle root and list of matching transaction hashes + Either String (MerkleRoot, [TxHash]) extractMatches net flags hashes ntx - | ntx == 0 = - Left - "extractMatches: number of transactions can not be 0" - | ntx > getMaxBlockSize net `div` 60 = - Left - "extractMatches: number of transactions excessively high" - | length hashes > ntx = - Left - "extractMatches: More hashes provided than the number of transactions" - | length flags < length hashes = - Left - "extractMatches: At least one bit per node and one bit per hash" - | isNothing resM = - Left - "extractMatches: traverseAndExtract failed" - | (nBitsUsed + 7) `div` 8 /= (length flags + 7) `div` 8 = - Left - "extractMatches: All bits were not consumed" - | nHashUsed /= length hashes = - Left $ - "extractMatches: All hashes were not consumed: " ++ show nHashUsed - | otherwise = return (merkRoot, matches) + | ntx == 0 = + Left + "extractMatches: number of transactions can not be 0" + | ntx > net.maxBlockSize `div` 60 = + Left + "extractMatches: number of transactions excessively high" + | length hashes > ntx = + Left + "extractMatches: More hashes provided than the number of transactions" + | length flags < length hashes = + Left + "extractMatches: At least one bit per node and one bit per hash" + | isNothing resM = + Left + "extractMatches: traverseAndExtract failed" + | (nBitsUsed + 7) `div` 8 /= (length flags + 7) `div` 8 = + Left + "extractMatches: All bits were not consumed" + | nHashUsed /= length hashes = + Left $ + "extractMatches: All hashes were not consumed: " ++ show nHashUsed + | otherwise = return (merkRoot, matches) where resM = traverseAndExtract (calcTreeHeight ntx) 0 ntx flags hashes (merkRoot, matches, nBitsUsed, nHashUsed) = fromMaybe e resM e = error "extractMatches: unexpected error extracting a Maybe value" -{- | Helper function to split a list in chunks 'Int' length. Last chunk may be - smaller. --} +-- | Helper function to split a list in chunks 'Int' length. Last chunk may be +-- smaller. splitIn :: Int -> [a] -> [[a]] splitIn _ [] = [] splitIn c xs = xs1 : splitIn c xs2 @@ -294,15 +291,11 @@ boolsToWord8 xs = foldl setBit 0 (map snd $ filter fst $ zip xs [0 .. 7]) -- | Get matching transactions from Merkle block. merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash] -merkleBlockTxs net b = - let flags = mFlags b - hs = mHashes b - n = fromIntegral $ merkleTotalTxns b - merkle = merkleRoot $ merkleHeader b - in do - (root, ths) <- extractMatches net flags hs n - when (root /= merkle) $ Left "merkleBlockTxs: Merkle root incorrect" - return ths +merkleBlockTxs net b = do + (root, ths) <- extractMatches net b.flags b.hashes (fromIntegral b.txn) + when (root /= b.header.merkle) $ + Left "merkleBlockTxs: Merkle root incorrect" + return ths -- | Check if Merkle block root is valid against the block header. testMerkleRoot :: Network -> MerkleBlock -> Bool diff --git a/src/Haskoin/Constants.hs b/src/Haskoin/Constants.hs deleted file mode 100644 index ff8945bd..00000000 --- a/src/Haskoin/Constants.hs +++ /dev/null @@ -1,615 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : Haskoin.Constants -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Network constants for various networks, including Bitcoin SegWit (BTC), Bitcoin -Cash (BCH), and corresponding public test and private regression test networks. --} -module Haskoin.Constants ( - Network (..), - - -- * Constants - btc, - btcTest, - btcRegTest, - bch, - bchTest, - bchTest4, - bchRegTest, - allNets, - netByName, -) where - -import Control.DeepSeq -import Data.Binary (Binary (..)) -import Data.ByteString (ByteString) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.List -import Data.Maybe -import Data.Serialize (Serialize (..)) -import Data.String -import Data.Text (Text) -import Data.Word (Word32, Word64, Word8) -import GHC.Generics (Generic) -import Haskoin.Block -import Haskoin.Data -import Haskoin.Network.Common -import Haskoin.Transaction -import Text.Read - --- | Version of Haskoin Core package. -versionString :: IsString a => a - -#ifdef CURRENT_PACKAGE_VERSION -versionString = CURRENT_PACKAGE_VERSION -#else -versionString = "Unavailable" -#endif - --- | Query known networks by name. -netByName :: String -> Maybe Network -netByName str = find ((== str) . getNetworkName) allNets - --- | Bitcoin SegWit network. Symbol: BTC. -btc :: Network -btc = - Network - { getNetworkName = "btc" - , getAddrPrefix = 0 - , getScriptPrefix = 5 - , getSecretPrefix = 128 - , getExtPubKeyPrefix = 0x0488b21e - , getExtSecretPrefix = 0x0488ade4 - , getNetworkMagic = 0xf9beb4d9 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1231006505 - 0x1d00ffff - 2083236893 - , -- Hash 000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f - getMaxBlockSize = 1000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = - "/haskoin-btc:" <> versionString <> "/" - , getDefaultPort = 8333 - , getAllowMinDifficultyBlocks = False - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 227931 - , "000000000000024b89b42a942fe0d9fea3bb44ab7bd1b19115dd6a759c0808b8" - ) - , getBip65Height = 388381 - , getBip66Height = 363725 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 11111 - , "0000000069e244f73d78e8fd29ba2fd2ed618bd6fa2ee92559f542fdb26e7c1d" - ) - , - ( 33333 - , "000000002dd5588a74784eaa7ab0507a18ad16a236e7b1ce69f00d7ddfb5d0a6" - ) - , - ( 74000 - , "0000000000573993a3c9e41ce34471c079dcf5f52a0e824a81e7f953b8661a20" - ) - , - ( 105000 - , "00000000000291ce28027faea320c8d2b054b2e0fe44a773f3eefb151d6bdc97" - ) - , - ( 134444 - , "00000000000005b12ffd4cd315cd34ffd4a594f430ac814c91184a0d42d2b0fe" - ) - , - ( 168000 - , "000000000000099e61ea72015e79632f216fe6cb33d7899acb35b75c8303b763" - ) - , - ( 193000 - , "000000000000059f452a5f7340de6682a977387c17010ff6e6c3bd83ca8b1317" - ) - , - ( 210000 - , "000000000000048b95347e83192f69cf0366076336c639f9b7228e9ba171342e" - ) - , - ( 216116 - , "00000000000001b4f4b433e81ee46494af945cf96014816a4e2370f11b23df4e" - ) - , - ( 225430 - , "00000000000001c108384350f74090433e7fcf79a606b8e797f065b130575932" - ) - , - ( 250000 - , "000000000000003887df1f29024b06fc2200b55f8af8f35453d7be294df2d214" - ) - , - ( 279000 - , "0000000000000001ae8c72a0b0c301f67e3afca10e819efa9041e458e9bd7e40" - ) - , - ( 295000 - , "00000000000000004d9b4ef50f0f9d686fd69db2e03af35a100370c64632a983" - ) - ] - , getSeeds = - [ "seed.bitcoin.sipa.be" -- Pieter Wuille - , "dnsseed.bluematt.me" -- Matt Corallo - , "dnsseed.bitcoin.dashjr.org" -- Luke Dashjr - , "seed.bitcoinstats.com" -- Chris Decker - , "seed.bitcoin.jonasschnelli.ch" -- Jonas Schnelli - , "seed.btc.petertodd.org" -- Peter Todd - , "seed.bitcoin.sprovoost.nl" -- Sjors Provoost - , "dnsseed.emzy.de" -- Stephan Oeste - , "seed.bitcoin.wiz.biz" -- Jason Maurice - ] - , getBip44Coin = 0 - , getSigHashForkId = Nothing - , getEdaBlockHeight = Nothing - , getDaaBlockHeight = Nothing - , getAsertActivationTime = Nothing - , getAsertHalfLife = 0 - , getSegWit = True - , getCashAddrPrefix = Nothing - , getBech32Prefix = Just "bc" - , getReplaceByFee = True - , getHalvingInterval = 210000 - } - --- | Testnet for Bitcoin SegWit network. -btcTest :: Network -btcTest = - Network - { getNetworkName = "btctest" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0x0b110907 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1296688602 - 486604799 - 414098458 - , -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 - getMaxBlockSize = 1000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-btc-test:" <> versionString <> "/" - , getDefaultPort = 18333 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 21111 - , "0000000023b3a96d3484e5abb3755c413e7d41500f8e2a5c3f0dd01299cd8ef8" - ) - , getBip65Height = 581885 - , getBip66Height = 330776 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 546 - , "000000002a936ca763904c3c35fce2f3556c559c0214345d31b1bcebf76acb70" - ) - ] - , getSeeds = - [ "testnet-seed.bitcoin.jonasschnelli.ch" - , "seed.tbtc.petertodd.org" - , "seed.testnet.bitcoin.sprovoost.nl" - , "testnet-seed.bluematt.me" - ] - , getBip44Coin = 1 - , getSigHashForkId = Nothing - , getEdaBlockHeight = Nothing - , getDaaBlockHeight = Nothing - , getAsertActivationTime = Nothing - , getAsertHalfLife = 0 - , getSegWit = True - , getCashAddrPrefix = Nothing - , getBech32Prefix = Just "tb" - , getReplaceByFee = True - , getHalvingInterval = 210000 - } - --- | RegTest for Bitcoin SegWit network. -btcRegTest :: Network -btcRegTest = - Network - { getNetworkName = "btcreg" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xfabfb5da - , getGenesisHeader = - BlockHeader - -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1296688602 - 0x207fffff - 2 - , getMaxBlockSize = 1000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-btc-regtest:" <> versionString <> "/" - , getDefaultPort = 18444 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = True - , getPowLimit = - 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 100000000 - , "0000000000000000000000000000000000000000000000000000000000000000" - ) - , getBip65Height = 1351 - , getBip66Height = 1251 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = [] - , getSeeds = ["localhost"] - , getBip44Coin = 1 - , getSigHashForkId = Nothing - , getEdaBlockHeight = Nothing - , getDaaBlockHeight = Nothing - , getAsertActivationTime = Nothing - , getAsertHalfLife = 0 - , getSegWit = True - , getCashAddrPrefix = Nothing - , getBech32Prefix = Just "bcrt" - , getReplaceByFee = True - , getHalvingInterval = 150 - } - --- | Bitcoin Cash network. Symbol: BCH. -bch :: Network -bch = - Network - { getNetworkName = "bch" - , getAddrPrefix = 0 - , getScriptPrefix = 5 - , getSecretPrefix = 128 - , getExtPubKeyPrefix = 0x0488b21e - , getExtSecretPrefix = 0x0488ade4 - , getNetworkMagic = 0xe3e1f3e8 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1231006505 - 0x1d00ffff - 2083236893 - , -- Hash 000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f - getMaxBlockSize = 32000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-bch:" <> versionString <> "/" - , getDefaultPort = 8333 - , getAllowMinDifficultyBlocks = False - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 227931 - , "000000000000024b89b42a942fe0d9fea3bb44ab7bd1b19115dd6a759c0808b8" - ) - , getBip65Height = 388381 - , getBip66Height = 363725 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 11111 - , "0000000069e244f73d78e8fd29ba2fd2ed618bd6fa2ee92559f542fdb26e7c1d" - ) - , - ( 33333 - , "000000002dd5588a74784eaa7ab0507a18ad16a236e7b1ce69f00d7ddfb5d0a6" - ) - , - ( 74000 - , "0000000000573993a3c9e41ce34471c079dcf5f52a0e824a81e7f953b8661a20" - ) - , - ( 105000 - , "00000000000291ce28027faea320c8d2b054b2e0fe44a773f3eefb151d6bdc97" - ) - , - ( 134444 - , "00000000000005b12ffd4cd315cd34ffd4a594f430ac814c91184a0d42d2b0fe" - ) - , - ( 168000 - , "000000000000099e61ea72015e79632f216fe6cb33d7899acb35b75c8303b763" - ) - , - ( 193000 - , "000000000000059f452a5f7340de6682a977387c17010ff6e6c3bd83ca8b1317" - ) - , - ( 210000 - , "000000000000048b95347e83192f69cf0366076336c639f9b7228e9ba171342e" - ) - , - ( 216116 - , "00000000000001b4f4b433e81ee46494af945cf96014816a4e2370f11b23df4e" - ) - , - ( 225430 - , "00000000000001c108384350f74090433e7fcf79a606b8e797f065b130575932" - ) - , - ( 250000 - , "000000000000003887df1f29024b06fc2200b55f8af8f35453d7be294df2d214" - ) - , - ( 279000 - , "0000000000000001ae8c72a0b0c301f67e3afca10e819efa9041e458e9bd7e40" - ) - , - ( 295000 - , "00000000000000004d9b4ef50f0f9d686fd69db2e03af35a100370c64632a983" - ) - , -- UAHF fork block. - - ( 478559 - , "000000000000000000651ef99cb9fcbe0dadde1d424bd9f15ff20136191a5eec" - ) - , -- Nov, 13 DAA activation block. - - ( 504031 - , "0000000000000000011ebf65b60d0a3de80b8175be709d653b4c1a1beeb6ab9c" - ) - ] - , getSeeds = - [ "seed.bitcoinabc.org" - , "seed-bch.bitcoinforks.org" - , "btccash-seeder.bitcoinunlimited.info" - , "seed.bchd.cash" - , "seed.bch.loping.net" - , "dnsseed.electroncash.de" - ] - , getBip44Coin = 145 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Just 478559 - , getDaaBlockHeight = Just 404031 - , getAsertActivationTime = Just 1605441600 - , getAsertHalfLife = 60 * 60 * 10 - , getSegWit = False - , getCashAddrPrefix = Just "bitcoincash" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 210000 - } - --- | Testnet for Bitcoin Cash network. -bchTest4 :: Network -bchTest4 = - Network - { getNetworkName = "bchtest4" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xe2b7daaf - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1597811185 - 0x1d00ffff - 114152193 - , -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 - getMaxBlockSize = 2000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-bch-test4:" <> versionString <> "/" - , getDefaultPort = 28333 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 2 - , "00000000b0c65b1e03baace7d5c093db0d6aac224df01484985ffd5e86a1a20c" - ) - , getBip65Height = 3 - , getBip66Height = 4 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 5000 - , "000000009f092d074574a216faec682040a853c4f079c33dfd2c3ef1fd8108c4" - ) - , -- Axion activation - - ( 16845 - , "00000000fb325b8f34fe80c96a5f708a08699a68bbab82dba4474d86bd743077" - ) - , - ( 38000 - , "000000000015197537e59f339e3b1bbf81a66f691bd3d7aa08560fc7bf5113fb" - ) - , - ( 54700 - , "00000000009af4379d87f17d0f172ee4769b48839a5a3a3e81d69da4322518b8" - ) - ] - , getSeeds = - [ "testnet4-seed-bch.bitcoinforks.org" - , "testnet4-seed-bch.toom.im" - , "seed.tbch4.loping.net" - , "testnet4-seed.flowee.cash" - ] - , getBip44Coin = 1 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Just 7 - , getDaaBlockHeight = Just 3000 - , getAsertActivationTime = Just 1605441600 - , getAsertHalfLife = 60 * 60 - , getSegWit = False - , getCashAddrPrefix = Just "bchtest" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 210000 - } - --- | Testnet for Bitcoin Cash network. -bchTest :: Network -bchTest = - Network - { getNetworkName = "bchtest" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xf4e5f3f4 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1296688602 - 486604799 - 414098458 - , -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 - getMaxBlockSize = 32000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-bch-test:" <> versionString <> "/" - , getDefaultPort = 18333 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 21111 - , "0000000023b3a96d3484e5abb3755c413e7d41500f8e2a5c3f0dd01299cd8ef8" - ) - , getBip65Height = 581885 - , getBip66Height = 330776 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 546 - , "000000002a936ca763904c3c35fce2f3556c559c0214345d31b1bcebf76acb70" - ) - , -- UAHF fork block. - - ( 1155876 - , "00000000000e38fef93ed9582a7df43815d5c2ba9fd37ef70c9a0ea4a285b8f5" - ) - , -- Nov, 13. DAA activation block. - - ( 1188697 - , "0000000000170ed0918077bde7b4d36cc4c91be69fa09211f748240dabe047fb" - ) - ] - , getSeeds = - [ "testnet-seed.bitcoinabc.org" - , "testnet-seed-bch.bitcoinforks.org" - , "testnet-seed.bchd.cash" - , "seed.tbch.loping.net" - ] - , getBip44Coin = 1 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Just 1155876 - , getDaaBlockHeight = Just 1188697 - , getAsertActivationTime = Just 1605441600 - , getAsertHalfLife = 60 * 60 - , getSegWit = False - , getCashAddrPrefix = Just "bchtest" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 210000 - } - --- | RegTest for Bitcoin Cash network. -bchRegTest :: Network -bchRegTest = - Network - { getNetworkName = "bchreg" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xdab5bffa - , getGenesisHeader = - BlockHeader - -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1296688602 - 0x207fffff - 2 - , getMaxBlockSize = 1000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-bch-regtest:" <> versionString <> "/" - , getDefaultPort = 18444 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = True - , getPowLimit = - 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 100000000 - , "0000000000000000000000000000000000000000000000000000000000000000" - ) - , getBip65Height = 1351 - , getBip66Height = 1251 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 0 - , "0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206" - ) - ] - , getSeeds = ["localhost"] - , getBip44Coin = 1 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Nothing - , getDaaBlockHeight = Just 0 - , getAsertActivationTime = Just 1605441600 - , getAsertHalfLife = 2 * 24 * 60 * 60 - , getSegWit = False - , getCashAddrPrefix = Just "bchreg" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 150 - } - --- | List of all networks supported by this library. -allNets :: [Network] -allNets = [btc, bch, btcTest, bchTest4, bchTest, btcRegTest, bchRegTest] diff --git a/src/Haskoin/Crypto.hs b/src/Haskoin/Crypto.hs index 99fc5f91..b15225e7 100644 --- a/src/Haskoin/Crypto.hs +++ b/src/Haskoin/Crypto.hs @@ -1,19 +1,21 @@ -{- | -Module : Haskoin.Crypto -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Hashing functions and ECDSA signatures. --} -module Haskoin.Crypto ( +-- | +-- Module : Haskoin.Crypto +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Hashing functions and ECDSA signatures. +module Haskoin.Crypto + ( module Secp256k1, module Hash, + module Keys, module Signature, - module Secp256k1, -) where + ) +where import Crypto.Secp256k1 as Secp256k1 import Haskoin.Crypto.Hash as Hash +import Haskoin.Crypto.Keys as Keys import Haskoin.Crypto.Signature as Signature diff --git a/src/Haskoin/Crypto/Hash.hs b/src/Haskoin/Crypto/Hash.hs index 41102173..d811547e 100644 --- a/src/Haskoin/Crypto/Hash.hs +++ b/src/Haskoin/Crypto/Hash.hs @@ -1,24 +1,29 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Crypto.Hash -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Hashing functions and corresponding data types. Uses functions from the -cryptonite library. --} -module Haskoin.Crypto.Hash ( - -- * Hashes - Hash512 (getHash512), - Hash256 (getHash256), - Hash160 (getHash160), - CheckSum32 (getCheckSum32), +-- | +-- Module : Haskoin.Crypto.Hash +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Hashing functions and corresponding data types. Uses functions from the +-- cryptonite library. +module Haskoin.Crypto.Hash + ( -- * Hashes + Hash512 (get), + Hash256 (get), + Hash160 (get), + CheckSum32 (get), sha512, sha256, ripemd160, @@ -31,233 +36,232 @@ module Haskoin.Crypto.Hash ( split512, join512, initTaggedHash, -) where + ) +where import Control.DeepSeq -import Crypto.Hash ( - Context, - RIPEMD160 (..), - SHA1 (..), - SHA256 (..), - SHA512 (..), - hashInit, - hashUpdates, - hashWith, - ) +import Crypto.Hash import Crypto.MAC.HMAC (HMAC, hmac) import Data.Binary (Binary (..)) -import Data.ByteArray (ByteArrayAccess) -import qualified Data.ByteArray as BA +import Data.ByteArray (ByteArrayAccess, convert) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as BSS -import qualified Data.Bytes.Get as Get -import qualified Data.Bytes.Put as Put +import Data.ByteString qualified as B +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Bytes.Get +import Data.Bytes.Put import Data.Bytes.Serial (Serial (..)) import Data.Either (fromRight) +import Data.Function (on) import Data.Hashable (Hashable) import Data.Serialize (Serialize (..)) import Data.String (IsString, fromString) import Data.String.Conversions (cs) +import Data.Void (Void) import Data.Word (Word32) import GHC.Generics (Generic) -import Haskoin.Util +import Haskoin.Util.Helpers +import Haskoin.Util.Marshal import Text.Read as R -- | 'Word32' wrapped for type-safe 32-bit checksums. newtype CheckSum32 = CheckSum32 - { getCheckSum32 :: Word32 - } - deriving (Eq, Ord, Serial, Show, Read, Hashable, Generic, NFData) + { get :: Word32 + } + deriving (Eq, Ord, Show, Read, Generic) + deriving newtype (Hashable, NFData) + +instance Serial CheckSum32 where + serialize (CheckSum32 c) = putWord32be c + deserialize = CheckSum32 <$> getWord32be instance Serialize CheckSum32 where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary CheckSum32 where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | Type for 512-bit hashes. -newtype Hash512 = Hash512 {getHash512 :: ShortByteString} - deriving (Eq, Ord, Hashable, Generic, NFData) +newtype Hash512 = Hash512 {get :: ShortByteString} + deriving (Eq, Ord, Generic) + deriving newtype (Hashable, NFData) -- | Type for 256-bit hashes. -newtype Hash256 = Hash256 {getHash256 :: ShortByteString} - deriving (Eq, Ord, Hashable, Generic, NFData) +newtype Hash256 = Hash256 {get :: ShortByteString} + deriving (Eq, Ord, Generic) + deriving newtype (Hashable, NFData) -- | Type for 160-bit hashes. -newtype Hash160 = Hash160 {getHash160 :: ShortByteString} - deriving (Eq, Ord, Hashable, Generic, NFData) +newtype Hash160 = Hash160 {get :: ShortByteString} + deriving (Eq, Ord, Generic) + deriving newtype (Hashable, NFData) instance Show Hash512 where - showsPrec _ = shows . encodeHex . BSS.fromShort . getHash512 + showsPrec _ = shows . encodeHex . fromShort . (.get) instance Read Hash512 where - readPrec = do - R.String str <- lexP - maybe pfail return $ Hash512 . BSS.toShort <$> decodeHex (cs str) + readPrec = do + R.String str <- lexP + maybe pfail (return . Hash512 . toShort) (decodeHex (cs str)) instance Show Hash256 where - showsPrec _ = shows . encodeHex . BSS.fromShort . getHash256 + showsPrec _ = shows . encodeHex . fromShort . (.get) instance Read Hash256 where - readPrec = do - R.String str <- lexP - maybe pfail return $ Hash256 . BSS.toShort <$> decodeHex (cs str) + readPrec = do + R.String str <- lexP + maybe pfail (return . Hash256 . toShort) (decodeHex (cs str)) instance Show Hash160 where - showsPrec _ = shows . encodeHex . BSS.fromShort . getHash160 + showsPrec _ = shows . encodeHex . fromShort . (.get) instance Read Hash160 where - readPrec = do - R.String str <- lexP - maybe pfail return $ Hash160 . BSS.toShort <$> decodeHex (cs str) + readPrec = do + R.String str <- lexP + maybe pfail (return . Hash160 . toShort) (decodeHex (cs str)) instance IsString Hash512 where - fromString str = - case decodeHex $ cs str of - Nothing -> e - Just bs -> - case BS.length bs of - 64 -> Hash512 (BSS.toShort bs) - _ -> e - where - e = error "Could not decode hash from hex string" + fromString str = + case decodeHex $ cs str of + Nothing -> e + Just bs -> + case B.length bs of + 64 -> Hash512 (toShort bs) + _ -> e + where + e = error "Could not decode hash from hex string" instance Serial Hash512 where - deserialize = Hash512 . BSS.toShort <$> Get.getByteString 64 - serialize = Put.putByteString . BSS.fromShort . getHash512 + deserialize = Hash512 . toShort <$> getByteString 64 + serialize = putByteString . fromShort . (.get) instance Serialize Hash512 where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary Hash512 where - put = serialize - get = deserialize + put = serialize + get = deserialize instance IsString Hash256 where - fromString str = - case decodeHex $ cs str of - Nothing -> e - Just bs -> - case BS.length bs of - 32 -> Hash256 (BSS.toShort bs) - _ -> e - where - e = error "Could not decode hash from hex string" + fromString str = + case decodeHex $ cs str of + Nothing -> e + Just bs -> + case B.length bs of + 32 -> Hash256 (toShort bs) + _ -> e + where + e = error "Could not decode hash from hex string" instance Serial Hash256 where - deserialize = Hash256 . BSS.toShort <$> Get.getByteString 32 - serialize = Put.putByteString . BSS.fromShort . getHash256 + deserialize = Hash256 . toShort <$> getByteString 32 + serialize = putByteString . fromShort . (.get) instance Serialize Hash256 where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary Hash256 where - put = serialize - get = deserialize + put = serialize + get = deserialize instance IsString Hash160 where - fromString str = - case decodeHex $ cs str of - Nothing -> e - Just bs -> - case BS.length bs of - 20 -> Hash160 (BSS.toShort bs) - _ -> e - where - e = error "Could not decode hash from hex string" + fromString str = + case decodeHex $ cs str of + Nothing -> e + Just bs -> + case B.length bs of + 20 -> Hash160 (toShort bs) + _ -> e + where + e = error "Could not decode hash from hex string" instance Serial Hash160 where - deserialize = Hash160 . BSS.toShort <$> Get.getByteString 20 - serialize = Put.putByteString . BSS.fromShort . getHash160 + deserialize = Hash160 . toShort <$> getByteString 20 + serialize = putByteString . fromShort . (.get) instance Serialize Hash160 where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary Hash160 where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | Calculate SHA512 hash. -sha512 :: ByteArrayAccess b => b -> Hash512 -sha512 = Hash512 . BSS.toShort . BA.convert . hashWith SHA512 +sha512 :: (ByteArrayAccess b) => b -> Hash512 +sha512 = Hash512 . toShort . convert . hashWith SHA512 -- | Calculate SHA256 hash. -sha256 :: ByteArrayAccess b => b -> Hash256 -sha256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256 +sha256 :: (ByteArrayAccess b) => b -> Hash256 +sha256 = Hash256 . toShort . convert . hashWith SHA256 -- | Calculate RIPEMD160 hash. -ripemd160 :: ByteArrayAccess b => b -> Hash160 -ripemd160 = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 +ripemd160 :: (ByteArrayAccess b) => b -> Hash160 +ripemd160 = Hash160 . toShort . convert . hashWith RIPEMD160 -- | Claculate SHA1 hash. -sha1 :: ByteArrayAccess b => b -> Hash160 -sha1 = Hash160 . BSS.toShort . BA.convert . hashWith SHA1 +sha1 :: (ByteArrayAccess b) => b -> Hash160 +sha1 = Hash160 . toShort . convert . hashWith SHA1 -- | Compute two rounds of SHA-256. -doubleSHA256 :: ByteArrayAccess b => b -> Hash256 +doubleSHA256 :: (ByteArrayAccess b) => b -> Hash256 doubleSHA256 = - Hash256 . BSS.toShort . BA.convert . hashWith SHA256 . hashWith SHA256 + Hash256 . toShort . convert . hashWith SHA256 . hashWith SHA256 -- | Compute SHA-256 followed by RIPMED-160. -addressHash :: ByteArrayAccess b => b -> Hash160 +addressHash :: (ByteArrayAccess b) => b -> Hash160 addressHash = - Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 . hashWith SHA256 + Hash160 . toShort . convert . hashWith RIPEMD160 . hashWith SHA256 {- CheckSum -} -- | Computes a 32 bit checksum. -checkSum32 :: ByteArrayAccess b => b -> CheckSum32 +checkSum32 :: (ByteArrayAccess b) => b -> CheckSum32 checkSum32 = - fromRight (error "Could not decode bytes as CheckSum32") - . Get.runGetS deserialize - . BS.take 4 - . BA.convert - . hashWith SHA256 - . hashWith SHA256 + fromRight (error "Could not decode bytes as CheckSum32") + . runGetS deserialize + . B.take 4 + . convert + . hashWith SHA256 + . hashWith SHA256 {- HMAC -} -- | Computes HMAC over SHA-512. hmac512 :: ByteString -> ByteString -> Hash512 hmac512 key msg = - Hash512 $ BSS.toShort $ BA.convert (hmac key msg :: HMAC SHA512) + Hash512 $ toShort $ convert (hmac key msg :: HMAC SHA512) -- | Computes HMAC over SHA-256. hmac256 :: (ByteArrayAccess k, ByteArrayAccess m) => k -> m -> Hash256 hmac256 key msg = - Hash256 $ BSS.toShort $ BA.convert (hmac key msg :: HMAC SHA256) + Hash256 $ toShort $ convert (hmac key msg :: HMAC SHA256) -- | Split a 'Hash512' into a pair of 'Hash256'. split512 :: Hash512 -> (Hash256, Hash256) split512 h = - (Hash256 (BSS.toShort a), Hash256 (BSS.toShort b)) + (Hash256 (toShort a), Hash256 (toShort b)) where - (a, b) = BS.splitAt 32 . BSS.fromShort $ getHash512 h + (a, b) = B.splitAt 32 $ fromShort h.get -- | Join a pair of 'Hash256' into a 'Hash512'. join512 :: (Hash256, Hash256) -> Hash512 -join512 (a, b) = - Hash512 - . BSS.toShort - $ BSS.fromShort (getHash256 a) `BS.append` BSS.fromShort (getHash256 b) +join512 (a, b) = Hash512 (toShort (a.get `app` b.get)) + where + app = B.append `on` fromShort -{- | Initialize tagged hash specified in BIP340 - -@since 0.21.0 --} +-- | Initialize tagged hash specified in BIP340 +-- +-- @since 0.21.0 initTaggedHash :: - -- | Hash tag - ByteString -> - Context SHA256 + -- | Hash tag + ByteString -> + Context SHA256 initTaggedHash tag = - (`hashUpdates` [hashedTag, hashedTag]) $ - hashInit @SHA256 + (`hashUpdates` [hashedTag, hashedTag]) $ + hashInit @SHA256 where hashedTag = hashWith SHA256 tag diff --git a/src/Haskoin/Crypto/Keys.hs b/src/Haskoin/Crypto/Keys.hs new file mode 100644 index 00000000..d93b0b50 --- /dev/null +++ b/src/Haskoin/Crypto/Keys.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Haskoin.Keys +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- ECDSA private and public keys, extended keys (BIP-32) and mnemonic sentences +-- (BIP-39). +module Haskoin.Crypto.Keys + ( module Haskoin.Crypto.Keys.Common, + module Haskoin.Crypto.Keys.Extended, + module Haskoin.Crypto.Keys.Mnemonic, + ) +where + +import Haskoin.Crypto.Keys.Common +import Haskoin.Crypto.Keys.Extended +import Haskoin.Crypto.Keys.Mnemonic diff --git a/src/Haskoin/Crypto/Keys/Common.hs b/src/Haskoin/Crypto/Keys/Common.hs new file mode 100644 index 00000000..52bf29e6 --- /dev/null +++ b/src/Haskoin/Crypto/Keys/Common.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Haskoin.Keys.Common +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- ECDSA private and public key functions. +module Haskoin.Crypto.Keys.Common + ( -- * Bitcoin Public & Private Keys + PublicKey (..), + PrivateKey (..), + wrapPubKey, + derivePublicKey, + wrapSecKey, + fromMiniKey, + tweakPubKey, + tweakSecKey, + + -- ** Private Key Wallet Import Format (WIF) + fromWif, + toWif, + ) +where + +import Control.DeepSeq +import Control.Monad (guard, mzero, (<=<)) +import Crypto.Secp256k1 +import Data.Aeson + ( Encoding, + FromJSON, + ToJSON (..), + Value (String), + object, + parseJSON, + withText, + ) +import Data.Aeson.Encoding (text, unsafeToEncoding) +import Data.Aeson.Types (Parser) +import Data.Binary (Binary (..)) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Builder (char7) +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Hashable +import Data.Maybe (fromMaybe) +import Data.Serialize (Serialize (..)) +import Data.String (IsString, fromString) +import Data.String.Conversions (cs) +import GHC.Generics (Generic) +import Haskoin.Address.Base58 +import Haskoin.Crypto.Hash +import Haskoin.Network.Data +import Haskoin.Util + +-- | Elliptic curve public key type with expected serialized compression flag. +data PublicKey = PublicKey + { point :: !PubKey, + compress :: !Bool + } + deriving (Generic, Show, Read, Hashable, Eq, NFData) + +instance MarshalJSON Ctx PublicKey where + marshalValue ctx = String . encodeHex . runPutS . marshalPut ctx + + marshalEncoding ctx = hexEncoding . runPutL . marshalPut ctx + + unmarshalValue ctx = + withText "PublicKey" $ \t -> do + bs <- maybe (fail "Expected hex public key") return $ decodeHex t + either fail return $ unmarshal ctx bs + +instance Marshal Ctx PublicKey where + marshalGet ctx = do + c <- + lookAhead $ + getWord8 >>= \case + 0x02 -> return True + 0x03 -> return True + 0x04 -> return False + _ -> fail "Not a public key" + bs <- getByteString $ if c then 33 else 65 + case importPubKey ctx bs of + Nothing -> fail "Could not decode public key" + Just k -> return $ PublicKey k c + + marshalPut ctx pk = + putByteString $ exportPubKey ctx pk.compress pk.point + +-- | Wrap a public key from secp256k1 library adding information about compression. +wrapPubKey :: Bool -> PubKey -> PublicKey +wrapPubKey c p = PublicKey p c + +-- | Derives a public key from a private key. This function will preserve +-- compression flag. +derivePublicKey :: Ctx -> PrivateKey -> PublicKey +derivePublicKey ctx (PrivateKey d c) = PublicKey (derivePubKey ctx d) c + +-- | Tweak a public key. +tweakPubKey :: Ctx -> PubKey -> Hash256 -> Maybe PubKey +tweakPubKey ctx p = + tweakAddPubKey ctx p <=< tweak . runPutS . serialize + +-- | Elliptic curve private key type with expected public key compression +-- information. Compression information is stored in private key WIF formats and +-- needs to be preserved to generate the correct address from the corresponding +-- public key. +data PrivateKey = PrivateKey + { key :: !SecKey, + compress :: !Bool + } + deriving (Eq, Show, Read, Generic, NFData) + +instance Serial PrivateKey where + serialize p = do + putByteString p.key.get + serialize p.compress + deserialize = do + k <- getByteString 32 + c <- deserialize + return PrivateKey {key = SecKey k, compress = c} + +instance MarshalJSON Network PrivateKey where + marshalValue net = String . toWif net + marshalEncoding net = text . toWif net + unmarshalValue net = + withText "PrivateKey" $ + maybe (fail "Could not decode WIF") return . fromWif net + +-- | Wrap private key with corresponding public key compression flag. +wrapSecKey :: Bool -> SecKey -> PrivateKey +wrapSecKey c d = PrivateKey d c + +-- | Tweak a private key. +tweakSecKey :: Ctx -> SecKey -> Hash256 -> Maybe SecKey +tweakSecKey ctx k = + tweakAddSecKey ctx k <=< tweak . runPutS . serialize + +-- | Decode Casascius mini private keys (22 or 30 characters). +fromMiniKey :: ByteString -> Maybe PrivateKey +fromMiniKey bs = do + guard checkShortKey + wrapSecKey False <$> (secKey . runPutS . serialize . sha256) bs + where + checkHash = runPutS $ serialize $ sha256 $ bs `BS.append` "?" + checkShortKey = BS.length bs `elem` [22, 30] && BS.head checkHash == 0x00 + +-- | Decode private key from WIF (wallet import format) string. +fromWif :: Network -> Base58 -> Maybe PrivateKey +fromWif net wif = do + bs <- decodeBase58Check wif + -- Check that this is a private key + guard (BS.head bs == net.secretPrefix) + case BS.length bs of + -- Uncompressed format + 33 -> wrapSecKey False <$> (secKey . BS.tail) bs + -- Compressed format + 34 -> do + guard $ BS.last bs == 0x01 + wrapSecKey True <$> (secKey . BS.tail . BS.init) bs + -- Bad length + _ -> Nothing + +-- | Encode private key into a WIF string. +toWif :: Network -> PrivateKey -> Base58 +toWif net (PrivateKey k c) = + encodeBase58Check . BS.cons net.secretPrefix $ + if c then k.get `BS.snoc` 0x01 else k.get diff --git a/src/Haskoin/Crypto/Keys/Extended.hs b/src/Haskoin/Crypto/Keys/Extended.hs new file mode 100644 index 00000000..c81b34ff --- /dev/null +++ b/src/Haskoin/Crypto/Keys/Extended.hs @@ -0,0 +1,1057 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +-- | +-- Module : Haskoin.Keys.Extended +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- BIP-32 extended keys. +module Haskoin.Crypto.Keys.Extended + ( -- * Extended Keys + XPubKey (..), + XPrvKey (..), + ChainCode, + KeyIndex, + Fingerprint, + fingerprintToText, + textToFingerprint, + DerivationException (..), + makeXPrvKey, + deriveXPubKey, + prvSubKey, + pubSubKey, + hardSubKey, + xPrvIsHard, + xPubIsHard, + xPrvChild, + xPubChild, + xPubID, + xPrvID, + xPubFP, + xPrvFP, + xPubAddr, + xPubWitnessAddr, + xPubCompatWitnessAddr, + xPubExport, + xPrvExport, + xPubImport, + xPrvImport, + xPrvWif, + + -- ** Helper Functions + prvSubKeys, + pubSubKeys, + hardSubKeys, + deriveAddr, + deriveWitnessAddr, + deriveCompatWitnessAddr, + deriveAddrs, + deriveWitnessAddrs, + deriveCompatWitnessAddrs, + deriveMSAddr, + deriveMSAddrs, + cycleIndex, + + -- ** Derivation Paths + DerivPathI (..), + AnyDeriv, + HardDeriv, + SoftDeriv, + HardOrAny, + AnyOrSoft, + DerivPath, + HardPath, + SoftPath, + Bip32PathIndex (..), + derivePath, + derivePubPath, + toHard, + toSoft, + toGeneric, + (++/), + pathToStr, + listToPath, + pathToList, + + -- *** Derivation Path Parser + XKey (..), + ParsedPath (..), + parsePath, + parseHard, + parseSoft, + applyPath, + derivePathAddr, + derivePathAddrs, + derivePathMSAddr, + derivePathMSAddrs, + concatBip32Segments, + ) +where + +import Control.Applicative +import Control.DeepSeq +import Control.Exception (Exception, throw) +import Control.Monad (guard, mzero, unless, (<=<)) +import Crypto.Secp256k1 +import Data.Aeson as Aeson + ( FromJSON, + ToJSON (..), + Value (String), + parseJSON, + toJSON, + withText, + ) +import Data.Aeson.Encoding (Encoding, string, text) +import Data.Aeson.Types (Parser) +import Data.Binary (Binary (get, put)) +import Data.Bits (clearBit, setBit, testBit) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.Bytes.Get + ( MonadGet + ( getByteString, + getWord32be, + getWord8 + ), + runGetS, + ) +import Data.Bytes.Put + ( MonadPut + ( putByteString, + putWord32be, + putWord8 + ), + runPutS, + ) +import Data.Bytes.Serial (Serial (..)) +import Data.Either (fromRight) +import Data.Hashable (Hashable) +import Data.List (foldl') +import Data.List.Split (splitOn) +import Data.Maybe (fromMaybe) +import Data.Serialize (Serialize (..)) +import Data.Serialize qualified as S +import Data.String (IsString, fromString) +import Data.String.Conversions (cs) +import Data.Text qualified as Text +import Data.Typeable (Typeable) +import Data.Word (Word32, Word8) +import GHC.Generics (Generic) +import Haskoin.Address +import Haskoin.Crypto.Hash +import Haskoin.Crypto.Keys.Common +import Haskoin.Crypto.Keys.Extended.Internal +import Haskoin.Network.Data +import Haskoin.Script.Standard +import Haskoin.Util +import Text.Read as Read + ( Lexeme (Ident, Number, String), + Read (readPrec), + lexP, + parens, + pfail, + ) +import Text.Read.Lex (numberToInteger) + +-- | A derivation exception is thrown in the very unlikely event that a +-- derivation is invalid. +newtype DerivationException = DerivationException String + deriving (Eq, Read, Show, Typeable, Generic) + deriving newtype (NFData) + +instance Exception DerivationException + +-- | Chain code as specified in BIP-32. +type ChainCode = Hash256 + +-- | Index of key as specified in BIP-32. +type KeyIndex = Word32 + +-- | Data type representing an extended BIP32 private key. An extended key +-- is a node in a tree of key derivations. It has a depth in the tree, a +-- parent node and an index to differentiate it from other siblings. +data XPrvKey = XPrvKey + { -- | depth in the tree + depth :: !Word8, + -- | fingerprint of parent + parent :: !Fingerprint, + -- | derivation index + index :: !KeyIndex, + -- | chain code + chain :: !ChainCode, + -- | private key of this node + key :: !SecKey + } + deriving (Generic, Eq, Show, Read, NFData, Hashable) + +instance Marshal Network XPrvKey where + marshalGet net = do + ver <- getWord32be + unless (ver == net.xPrvPrefix) $ + fail "Get: Invalid version for extended private key" + XPrvKey + <$> getWord8 + <*> deserialize + <*> getWord32be + <*> deserialize + <*> getPadPrvKey + + marshalPut net k = do + putWord32be net.xPrvPrefix + putWord8 k.depth + serialize k.parent + putWord32be k.index + serialize $ k.chain + putPadPrvKey k.key + +instance MarshalJSON Network XPrvKey where + marshalValue net = Aeson.String . xPrvExport net + + marshalEncoding net = text . xPrvExport net + + unmarshalValue net = + withText "XPrvKey" $ \t -> + case xPrvImport net t of + Nothing -> fail "could not read xprv" + Just x -> return x + +-- | Data type representing an extended BIP32 public key. +data XPubKey = XPubKey + { -- | depth in the tree + depth :: !Word8, + -- | fingerprint of parent + parent :: !Fingerprint, + -- | derivation index + index :: !KeyIndex, + -- | chain code + chain :: !ChainCode, + -- | public key of this node + key :: !PubKey + } + deriving (Generic, Eq, Show, Read, Hashable, NFData) + +instance Marshal (Network, Ctx) XPubKey where + marshalGet (net, ctx) = do + ver <- getWord32be + unless (ver == net.xPubPrefix) $ + fail "Get: Invalid version for extended public key" + XPubKey + <$> getWord8 + <*> deserialize + <*> getWord32be + <*> deserialize + <*> ((\PublicKey {point} -> point) <$> marshalGet ctx) + + marshalPut (net, ctx) k = do + putWord32be net.xPubPrefix + putWord8 k.depth + serialize k.parent + putWord32be k.index + serialize k.chain + marshalPut ctx $ wrapPubKey True k.key + +instance MarshalJSON (Network, Ctx) XPubKey where + unmarshalValue (net, ctx) = + withText "XPubKey" $ \t -> + case xPubImport net ctx t of + Nothing -> fail "could not read xpub" + Just x -> return x + + marshalValue (net, ctx) = Aeson.String . xPubExport net ctx + + marshalEncoding (net, ctx) = text . xPubExport net ctx + +-- | Build a BIP32 compatible extended private key from a bytestring. This will +-- produce a root node (@depth=0@ and @parent=0@). +makeXPrvKey :: ByteString -> XPrvKey +makeXPrvKey bs = + XPrvKey 0 (Fingerprint 0) 0 c k + where + (p, c) = split512 $ hmac512 "Bitcoin seed" bs + k = fromMaybe err (secKey (runPutS (serialize p))) + err = throw $ DerivationException "Invalid seed" + +-- | Derive an extended public key from an extended private key. This function +-- will preserve the depth, parent, index and chaincode fields of the extended +-- private keys. +deriveXPubKey :: Ctx -> XPrvKey -> XPubKey +deriveXPubKey ctx (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey ctx k) + +-- | Compute a private, soft child key derivation. A private soft derivation +-- will allow the equivalent extended public key to derive the public key for +-- this child. Given a parent key /m/ and a derivation index /i/, this function +-- will compute /m\/i/. +-- +-- Soft derivations allow for more flexibility such as read-only wallets. +-- However, care must be taken not the leak both the parent extended public key +-- and one of the extended child private keys as this would compromise the +-- extended parent private key. +prvSubKey :: + Ctx -> + -- | extended parent private key + XPrvKey -> + -- | child derivation index + KeyIndex -> + -- | extended child private key + XPrvKey +prvSubKey ctx xkey child + | child >= 0 && child < 0x80000000 = + XPrvKey (xkey.depth + 1) (xPrvFP ctx xkey) child c k + | otherwise = error "Invalid child derivation index" + where + pK = (deriveXPubKey ctx xkey).key + m = B.append (exportPubKey ctx True pK) (runPutS (serialize child)) + (a, c) = split512 $ hmac512 (runPutS $ serialize xkey.chain) m + k = fromMaybe err $ tweakSecKey ctx xkey.key a + err = throw $ DerivationException "Invalid prvSubKey derivation" + +-- | Compute a public, soft child key derivation. Given a parent key /M/ +-- and a derivation index /i/, this function will compute /M\/i/. +pubSubKey :: + Ctx -> + -- | extended parent public key + XPubKey -> + -- | child derivation index + KeyIndex -> + -- | extended child public key + XPubKey +pubSubKey ctx xKey child + | child >= 0 && child < 0x80000000 = + XPubKey (xKey.depth + 1) (xPubFP ctx xKey) child c pK + | otherwise = error "Invalid child derivation index" + where + m = B.append (exportPubKey ctx True xKey.key) (runPutS $ serialize child) + (a, c) = split512 $ hmac512 (runPutS $ serialize xKey.chain) m + pK = fromMaybe err $ tweakPubKey ctx xKey.key a + err = throw $ DerivationException "Invalid pubSubKey derivation" + +-- | Compute a hard child key derivation. Hard derivations can only be computed +-- for private keys. Hard derivations do not allow the parent public key to +-- derive the child public keys. However, they are safer as a breach of the +-- parent public key and child private keys does not lead to a breach of the +-- parent private key. Given a parent key /m/ and a derivation index /i/, this +-- function will compute /m\/i'/. +hardSubKey :: + Ctx -> + -- | extended parent private key + XPrvKey -> + -- | child derivation index + KeyIndex -> + -- | extended child private key + XPrvKey +hardSubKey ctx xkey child + | child >= 0 && child < 0x80000000 = + XPrvKey (xkey.depth + 1) (xPrvFP ctx xkey) i c k + | otherwise = error "Invalid child derivation index" + where + i = setBit child 31 + m = B.append (bsPadPrvKey xkey.key) (runPutS $ serialize i) + (a, c) = split512 $ hmac512 (runPutS $ serialize xkey.chain) m + k = fromMaybe err $ tweakSecKey ctx xkey.key a + err = throw $ DerivationException "Invalid hardSubKey derivation" + +-- | Returns true if the extended private key was derived through a hard +-- derivation. +xPrvIsHard :: XPrvKey -> Bool +xPrvIsHard k = testBit k.index 31 + +-- | Returns true if the extended public key was derived through a hard +-- derivation. +xPubIsHard :: XPubKey -> Bool +xPubIsHard k = testBit k.index 31 + +-- | Returns the derivation index of this extended private key without the hard +-- bit set. +xPrvChild :: XPrvKey -> KeyIndex +xPrvChild k = clearBit k.index 31 + +-- | Returns the derivation index of this extended public key without the hard +-- bit set. +xPubChild :: XPubKey -> KeyIndex +xPubChild k = clearBit k.index 31 + +-- | Computes the key identifier of an extended private key. +xPrvID :: Ctx -> XPrvKey -> Hash160 +xPrvID ctx = xPubID ctx . deriveXPubKey ctx + +-- | Computes the key identifier of an extended public key. +xPubID :: Ctx -> XPubKey -> Hash160 +xPubID ctx = + ripemd160 + . runPutS + . serialize + . sha256 + . exportPubKey ctx True + . (.key) + +-- | Computes the key fingerprint of an extended private key. +xPrvFP :: Ctx -> XPrvKey -> Fingerprint +xPrvFP ctx = + fromRight err + . runGetS deserialize + . B.take 4 + . runPutS + . serialize + . xPrvID ctx + where + err = error "Could not decode xPrvFP" + +-- | Computes the key fingerprint of an extended public key. +xPubFP :: Ctx -> XPubKey -> Fingerprint +xPubFP ctx = + fromRight err + . runGetS deserialize + . B.take 4 + . runPutS + . serialize + . xPubID ctx + where + err = error "Could not decode xPubFP" + +-- | Compute a standard P2PKH address for an extended public key. +xPubAddr :: Ctx -> XPubKey -> Address +xPubAddr ctx xkey = pubKeyAddr ctx (wrapPubKey True xkey.key) + +-- | Compute a SegWit P2WPKH address for an extended public key. +xPubWitnessAddr :: Ctx -> XPubKey -> Address +xPubWitnessAddr ctx xkey = + pubKeyWitnessAddr ctx (wrapPubKey True xkey.key) + +-- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended +-- public key. +xPubCompatWitnessAddr :: Ctx -> XPubKey -> Address +xPubCompatWitnessAddr ctx xkey = + pubKeyCompatWitnessAddr ctx (wrapPubKey True xkey.key) + +-- | Exports an extended private key to the BIP32 key export format ('Base58'). +xPrvExport :: Network -> XPrvKey -> Base58 +xPrvExport net = encodeBase58Check . marshal net + +-- | Exports an extended public key to the BIP32 key export format ('Base58'). +xPubExport :: Network -> Ctx -> XPubKey -> Base58 +xPubExport net ctx = encodeBase58Check . marshal (net, ctx) + +-- | Decodes a BIP32 encoded extended private key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. +xPrvImport :: Network -> Base58 -> Maybe XPrvKey +xPrvImport net = + eitherToMaybe . unmarshal net <=< decodeBase58Check + +-- | Decodes a BIP32 encoded extended public key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. +xPubImport :: Network -> Ctx -> Base58 -> Maybe XPubKey +xPubImport net ctx = + eitherToMaybe . unmarshal (net, ctx) <=< decodeBase58Check + +-- | Export an extended private key to WIF (Wallet Import Format). +xPrvWif :: Network -> XPrvKey -> Base58 +xPrvWif net xkey = toWif net (wrapSecKey True xkey.key) + +{- Derivation helpers -} + +-- | Cyclic list of all private soft child key derivations of a parent key +-- starting from an offset index. +prvSubKeys :: Ctx -> XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] +prvSubKeys ctx k = map (\i -> (prvSubKey ctx k i, i)) . cycleIndex + +-- | Cyclic list of all public soft child key derivations of a parent key +-- starting from an offset index. +pubSubKeys :: Ctx -> XPubKey -> KeyIndex -> [(XPubKey, KeyIndex)] +pubSubKeys ctx k = map (\i -> (pubSubKey ctx k i, i)) . cycleIndex + +-- | Cyclic list of all hard child key derivations of a parent key starting +-- from an offset index. +hardSubKeys :: Ctx -> XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] +hardSubKeys ctx k = map (\i -> (hardSubKey ctx k i, i)) . cycleIndex + +-- | Derive a standard address from an extended public key and an index. +deriveAddr :: Ctx -> XPubKey -> KeyIndex -> (Address, PubKey) +deriveAddr ctx k i = + (xPubAddr ctx key, key.key) + where + key = pubSubKey ctx k i + +-- | Derive a SegWit P2WPKH address from an extended public key and an index. +deriveWitnessAddr :: Ctx -> XPubKey -> KeyIndex -> (Address, PubKey) +deriveWitnessAddr ctx k i = + (xPubWitnessAddr ctx key, key.key) + where + key = pubSubKey ctx k i + +-- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended +-- public key and an index. +deriveCompatWitnessAddr :: Ctx -> XPubKey -> KeyIndex -> (Address, PubKey) +deriveCompatWitnessAddr ctx k i = + (xPubCompatWitnessAddr ctx key, key.key) + where + key = pubSubKey ctx k i + +-- | Cyclic list of all addresses derived from a public key starting from an +-- offset index. +deriveAddrs :: Ctx -> XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] +deriveAddrs ctx k = + map f . cycleIndex + where + f i = let (a, key) = deriveAddr ctx k i in (a, key, i) + +-- | Cyclic list of all SegWit P2WPKH addresses derived from a public key +-- starting from an offset index. +deriveWitnessAddrs :: + Ctx -> XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] +deriveWitnessAddrs ctx k = + map f . cycleIndex + where + f i = let (a, key) = deriveWitnessAddr ctx k i in (a, key, i) + +-- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses +-- derived from a public key starting from an offset index. +deriveCompatWitnessAddrs :: + Ctx -> XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] +deriveCompatWitnessAddrs ctx k = + map f . cycleIndex + where + f i = let (a, key) = deriveCompatWitnessAddr ctx k i in (a, key, i) + +-- | Derive a multisig address from a list of public keys, the number of +-- required signatures /m/ and a derivation index. The derivation type is a +-- public, soft derivation. +deriveMSAddr :: + Ctx -> [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript) +deriveMSAddr ctx keys m i = (payToScriptAddress ctx rdm, rdm) + where + rdm = sortMulSig ctx $ PayMulSig k m + k = map (wrapPubKey True . (.key) . flip (pubSubKey ctx) i) keys + +-- | Cyclic list of all multisig addresses derived from a list of public keys, +-- a number of required signatures /m/ and starting from an offset index. The +-- derivation type is a public, soft derivation. +deriveMSAddrs :: + Ctx -> + [XPubKey] -> + Int -> + KeyIndex -> + [(Address, RedeemScript, KeyIndex)] +deriveMSAddrs ctx keys m = map f . cycleIndex + where + f i = + let (a, rdm) = deriveMSAddr ctx keys m i + in (a, rdm, i) + +-- | Helper function to go through derivation indices. +cycleIndex :: KeyIndex -> [KeyIndex] +cycleIndex i + | i == 0 = cycle [0 .. 0x7fffffff] + | i < 0x80000000 = cycle $ [i .. 0x7fffffff] ++ [0 .. (i - 1)] + | otherwise = error $ "cycleIndex: invalid index " ++ show i + +{- Derivation Paths -} + +-- | Phantom type signaling a hardened derivation path that can only be computed +-- from private extended key. +data HardDeriv deriving (Generic, NFData) + +-- | Phantom type signaling no knowledge about derivation path: can be hardened or not. +data AnyDeriv deriving (Generic, NFData) + +-- | Phantom type signaling derivation path including only non-hardened paths +-- that can be computed from an extended public key. +data SoftDeriv deriving (Generic, NFData) + +-- | Hardened derivation path. Can be computed from extended private key only. +type HardPath = DerivPathI HardDeriv + +-- | Any derivation path. +type DerivPath = DerivPathI AnyDeriv + +-- | Non-hardened derivation path can be computed from extended public key. +type SoftPath = DerivPathI SoftDeriv + +-- | Helper class to perform validations on a hardened derivation path. +class HardOrAny a + +instance HardOrAny HardDeriv + +instance HardOrAny AnyDeriv + +-- | Helper class to perform validations on a non-hardened derivation path. +class AnyOrSoft a + +instance AnyOrSoft AnyDeriv + +instance AnyOrSoft SoftDeriv + +-- | Data type representing a derivation path. Two constructors are provided +-- for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be +-- expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type +-- classes are used to constrain the valid values for the phantom type /t/. If +-- you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'. +-- Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv' +-- if you only have soft derivations. +-- +-- Using this type is as easy as writing the required derivation like in these +-- example: +-- +-- > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath +-- > Deriv :| 0 :| 1 :| 2 :: HardPath +-- > Deriv :| 0 :/ 1 :/ 2 :: DerivPath +data DerivPathI t where + (:|) :: (HardOrAny t) => !(DerivPathI t) -> !KeyIndex -> DerivPathI t + (:/) :: (AnyOrSoft t) => !(DerivPathI t) -> !KeyIndex -> DerivPathI t + Deriv :: DerivPathI t + +instance NFData (DerivPathI t) where + rnf (a :| b) = rnf a `seq` rnf b + rnf (a :/ b) = rnf a `seq` rnf b + rnf Deriv = () + +instance Eq (DerivPathI t) where + (nextA :| iA) == (nextB :| iB) = iA == iB && nextA == nextB + (nextA :/ iA) == (nextB :/ iB) = iA == iB && nextA == nextB + Deriv == Deriv = True + _ == _ = False + +instance Ord (DerivPathI t) where + -- Same hardness on each side + (nextA :| iA) `compare` (nextB :| iB) = + if nextA == nextB then iA `compare` iB else nextA `compare` nextB + (nextA :/ iA) `compare` (nextB :/ iB) = + if nextA == nextB then iA `compare` iB else nextA `compare` nextB + -- Different hardness: hard paths are LT soft paths + (nextA :/ _iA) `compare` (nextB :| _iB) = + if nextA == nextB then LT else nextA `compare` nextB + (nextA :| _iA) `compare` (nextB :/ _iB) = + if nextA == nextB then GT else nextA `compare` nextB + Deriv `compare` Deriv = EQ + Deriv `compare` _ = LT + _ `compare` Deriv = GT + +instance Serial DerivPath where + deserialize = listToPath <$> getList getWord32be + serialize = putList putWord32be . pathToList + +instance Serialize DerivPath where + put = serialize + get = deserialize + +instance Binary DerivPath where + put = serialize + get = deserialize + +instance Serial HardPath where + deserialize = + maybe + (fail "Could not decode hard path") + return + . toHard + . listToPath + =<< getList getWord32be + serialize = putList putWord32be . pathToList + +instance Serialize HardPath where + put = serialize + get = deserialize + +instance Binary HardPath where + put = serialize + get = deserialize + +instance Serial SoftPath where + deserialize = + maybe + (fail "Could not decode soft path") + return + . toSoft + . listToPath + =<< getList getWord32be + serialize = putList putWord32be . pathToList + +instance Serialize SoftPath where + put = serialize + get = deserialize + +instance Binary SoftPath where + put = serialize + get = deserialize + +-- | Get a list of derivation indices from a derivation path. +pathToList :: DerivPathI t -> [KeyIndex] +pathToList = + reverse . go + where + go (next :| i) = setBit i 31 : go next + go (next :/ i) = i : go next + go _ = [] + +-- | Convert a list of derivation indices to a derivation path. +listToPath :: [KeyIndex] -> DerivPath +listToPath = + go . reverse + where + go (i : is) + | testBit i 31 = go is :| clearBit i 31 + | otherwise = go is :/ i + go [] = Deriv + +-- | Convert a derivation path to a human-readable string. +pathToStr :: DerivPathI t -> String +pathToStr p = + case p of + next :| i -> concat [pathToStr next, "/", show i, "'"] + next :/ i -> concat [pathToStr next, "/", show i] + Deriv -> "" + +-- | Turn a derivation path into a hard derivation path. Will fail if the path +-- contains soft derivations. +toHard :: DerivPathI t -> Maybe HardPath +toHard p = case p of + next :| i -> (:| i) <$> toHard next + Deriv -> Just Deriv + _ -> Nothing + +-- | Turn a derivation path into a soft derivation path. Will fail if the path +-- has hard derivations. +toSoft :: DerivPathI t -> Maybe SoftPath +toSoft p = case p of + next :/ i -> (:/ i) <$> toSoft next + Deriv -> Just Deriv + _ -> Nothing + +-- | Make a derivation path generic. +toGeneric :: DerivPathI t -> DerivPath +toGeneric p = case p of + next :/ i -> toGeneric next :/ i + next :| i -> toGeneric next :| i + Deriv -> Deriv + +-- | Append two derivation paths together. The result will be a mixed +-- derivation path. +(++/) :: DerivPathI t1 -> DerivPathI t2 -> DerivPath +(++/) p1 p2 = + go id (toGeneric p2) $ toGeneric p1 + where + go f p = case p of + next :/ i -> go (f . (:/ i)) $ toGeneric next + next :| i -> go (f . (:| i)) $ toGeneric next + _ -> f + +-- | Derive a private key from a derivation path +derivePath :: Ctx -> DerivPathI t -> XPrvKey -> XPrvKey +derivePath ctx = go id + where + -- Build the full derivation function starting from the end + go f p = case p of + next :| i -> go (f . flip (hardSubKey ctx) i) next + next :/ i -> go (f . flip (prvSubKey ctx) i) next + _ -> f + +-- | Derive a public key from a soft derivation path +derivePubPath :: Ctx -> SoftPath -> XPubKey -> XPubKey +derivePubPath ctx = go id + where + -- Build the full derivation function starting from the end + go f p = case p of + next :/ i -> go (f . flip (pubSubKey ctx) i) next + _ -> f + +instance Show DerivPath where + showsPrec d p = + showParen (d > 10) $ + showString "DerivPath " . shows (pathToStr p) + +instance Read DerivPath where + readPrec = parens $ do + Ident "DerivPath" <- lexP + Read.String str <- lexP + maybe pfail (return . (.get)) (parsePath str) + +instance Show HardPath where + showsPrec d p = + showParen (d > 10) $ + showString "HardPath " . shows (pathToStr p) + +instance Read HardPath where + readPrec = parens $ do + Ident "HardPath" <- lexP + Read.String str <- lexP + maybe pfail return $ parseHard str + +instance Show SoftPath where + showsPrec d p = + showParen (d > 10) $ + showString "SoftPath " . shows (pathToStr p) + +instance Read SoftPath where + readPrec = parens $ do + Ident "SoftPath" <- lexP + Read.String str <- lexP + maybe pfail return $ parseSoft str + +instance IsString ParsedPath where + fromString = + fromMaybe e . parsePath + where + e = error "Could not parse derivation path" + +instance IsString DerivPath where + fromString = + (.get) . fromMaybe e . parsePath + where + e = error "Could not parse derivation path" + +instance IsString HardPath where + fromString = + fromMaybe e . parseHard + where + e = error "Could not parse hard derivation path" + +instance IsString SoftPath where + fromString = + fromMaybe e . parseSoft + where + e = error "Could not parse soft derivation path" + +instance FromJSON ParsedPath where + parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of + Just p -> return p + _ -> mzero + +instance FromJSON DerivPath where + parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of + Just p -> return p.get + _ -> mzero + +instance FromJSON HardPath where + parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of + Just p -> return p + _ -> mzero + +instance FromJSON SoftPath where + parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of + Just p -> return p + _ -> mzero + +instance ToJSON (DerivPathI t) where + toJSON = Aeson.String . cs . pathToStr + toEncoding = string . pathToStr + +instance ToJSON ParsedPath where + toJSON (ParsedPrv p) = Aeson.String . cs . ("m" ++) . pathToStr $ p + toJSON (ParsedPub p) = Aeson.String . cs . ("M" ++) . pathToStr $ p + toJSON (ParsedEmpty p) = Aeson.String . cs . ("" ++) . pathToStr $ p + toEncoding (ParsedPrv p) = text . cs . ("m" ++) . pathToStr $ p + toEncoding (ParsedPub p) = text . cs . ("M" ++) . pathToStr $ p + toEncoding (ParsedEmpty p) = text . cs . ("" ++) . pathToStr $ p + +{- Parsing derivation paths of the form m/1/2'/3 or M/1/2'/3 -} + +-- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or +-- /M\/1\/2'\/3/. +data ParsedPath + = ParsedPrv {get :: !DerivPath} + | ParsedPub {get :: !DerivPath} + | ParsedEmpty {get :: !DerivPath} + deriving (Eq, Generic, NFData) + +instance Show ParsedPath where + showsPrec d p = showParen (d > 10) $ showString "ParsedPath " . shows f + where + f = + case p of + ParsedPrv d' -> "m" <> pathToStr d' + ParsedPub d' -> "M" <> pathToStr d' + ParsedEmpty d' -> pathToStr d' + +instance Read ParsedPath where + readPrec = parens $ do + Ident "ParsedPath" <- lexP + Read.String str <- lexP + maybe pfail return $ parsePath str + +-- | Parse derivation path string for extended key. +-- Forms: /m\/0'\/2/, /M\/2\/3\/4/. +parsePath :: String -> Maybe ParsedPath +parsePath str = do + res <- concatBip32Segments <$> mapM parseBip32PathIndex xs + case x of + "m" -> Just $ ParsedPrv res + "M" -> Just $ ParsedPub res + "" -> Just $ ParsedEmpty res + _ -> Nothing + where + (x : xs) = splitOn "/" str + +-- | Concatenate derivation path indices into a derivation path. +concatBip32Segments :: [Bip32PathIndex] -> DerivPath +concatBip32Segments = foldl' appendBip32Segment Deriv + +-- | Append an extra derivation path index element into an existing path. +appendBip32Segment :: DerivPath -> Bip32PathIndex -> DerivPath +appendBip32Segment d (Bip32SoftIndex i) = d :/ i +appendBip32Segment d (Bip32HardIndex i) = d :| i + +-- | Parse a BIP32 derivation path index element from a string. +parseBip32PathIndex :: String -> Maybe Bip32PathIndex +parseBip32PathIndex segment = case reads segment of + [(i, "")] -> guard (is31Bit i) >> return (Bip32SoftIndex i) + [(i, "'")] -> guard (is31Bit i) >> return (Bip32HardIndex i) + _ -> Nothing + +-- | Type for BIP32 path index element. +data Bip32PathIndex + = Bip32HardIndex KeyIndex + | Bip32SoftIndex KeyIndex + deriving (Eq, Generic, NFData) + +instance Show Bip32PathIndex where + showsPrec d (Bip32HardIndex i) = + showParen (d > 10) $ + showString "Bip32HardIndex " . shows i + showsPrec d (Bip32SoftIndex i) = + showParen (d > 10) $ + showString "Bip32SoftIndex " . shows i + +instance Read Bip32PathIndex where + readPrec = h <|> s + where + h = + parens $ do + Ident "Bip32HardIndex" <- lexP + Number n <- lexP + maybe + pfail + (return . Bip32HardIndex . fromIntegral) + (numberToInteger n) + s = + parens $ do + Ident "Bip32SoftIndex" <- lexP + Number n <- lexP + maybe + pfail + (return . Bip32SoftIndex . fromIntegral) + (numberToInteger n) + +-- | Test whether the number could be a valid BIP32 derivation index. +is31Bit :: (Integral a) => a -> Bool +is31Bit i = i >= 0 && i < 0x80000000 + +-- | Helper function to parse a hard path. +parseHard :: String -> Maybe HardPath +parseHard = toHard . (.get) <=< parsePath + +-- | Helper function to parse a soft path. +parseSoft :: String -> Maybe SoftPath +parseSoft = toSoft . (.get) <=< parsePath + +-- | Data type representing a private or public key with its respective network. +data XKey + = XPrv + { xprv :: !XPrvKey, + net :: !Network + } + | XPub + { xpub :: !XPubKey, + net :: !Network + } + deriving (Show, Read, Eq, Generic, NFData) + +-- | Apply a parsed path to an extended key to derive the new key defined in the +-- path. If the path starts with /m/, a private key will be returned and if the +-- path starts with /M/, a public key will be returned. Private derivations on a +-- public key, and public derivations with a hard segment, return an error +-- value. +applyPath :: Ctx -> ParsedPath -> XKey -> Either String XKey +applyPath ctx path key = + case (path, key) of + (ParsedPrv _, XPrv k n) -> return $ XPrv (derivPrvF k) n + (ParsedPrv _, XPub {}) -> Left "applyPath: Invalid public key" + (ParsedPub _, XPrv k n) -> return $ XPub (deriveXPubKey ctx (derivPrvF k)) n + (ParsedPub _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n + -- For empty parsed paths, we take a hint from the provided key + (ParsedEmpty _, XPrv k n) -> return $ XPrv (derivPrvF k) n + (ParsedEmpty _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n + where + derivPrvF = goPrv id path.get + derivPubFE = goPubE id path.get + -- Build the full private derivation function starting from the end + goPrv f p = + case p of + next :| i -> goPrv (f . flip (hardSubKey ctx) i) next + next :/ i -> goPrv (f . flip (prvSubKey ctx) i) next + Deriv -> f + -- Build the full public derivation function starting from the end + goPubE f p = + case p of + next :/ i -> goPubE (f . flip (pubSubKey ctx) i) next + Deriv -> Right f + _ -> Left "applyPath: Invalid hard derivation" + +{- Helpers for derivation paths and addresses -} + +-- | Derive an address from a given parent path. +derivePathAddr :: Ctx -> XPubKey -> SoftPath -> KeyIndex -> (Address, PubKey) +derivePathAddr ctx key path = deriveAddr ctx (derivePubPath ctx path key) + +-- | Cyclic list of all addresses derived from a given parent path and starting +-- from the given offset index. +derivePathAddrs :: + Ctx -> XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKey, KeyIndex)] +derivePathAddrs ctx key path = deriveAddrs ctx (derivePubPath ctx path key) + +-- | Derive a multisig address from a given parent path. The number of required +-- signatures (m in m of n) is also needed. +derivePathMSAddr :: + Ctx -> + [XPubKey] -> + SoftPath -> + Int -> + KeyIndex -> + (Address, RedeemScript) +derivePathMSAddr ctx keys path = + deriveMSAddr ctx $ map (derivePubPath ctx path) keys + +-- | Cyclic list of all multisig addresses derived from a given parent path and +-- starting from the given offset index. The number of required signatures +-- (m in m of n) is also needed. +derivePathMSAddrs :: + Ctx -> + [XPubKey] -> + SoftPath -> + Int -> + KeyIndex -> + [(Address, RedeemScript, KeyIndex)] +derivePathMSAddrs ctx keys path = + deriveMSAddrs ctx $ map (derivePubPath ctx path) keys + +{- Utilities for extended keys -} + +-- | De-serialize HDW-specific private key. +getPadPrvKey :: (MonadGet m) => m SecKey +getPadPrvKey = do + pad <- getWord8 + unless (pad == 0x00) $ fail "Private key must be padded with 0x00" + bs <- getByteString 32 + case secKey bs of + Nothing -> fail $ "Could not decode secret key: " ++ cs (encodeHex bs) + Just x -> return x + +-- | Serialize HDW-specific private key. +putPadPrvKey :: (MonadPut m) => SecKey -> m () +putPadPrvKey p = putWord8 0x00 >> putByteString p.get + +bsPadPrvKey :: SecKey -> ByteString +bsPadPrvKey = runPutS . putPadPrvKey diff --git a/src/Haskoin/Crypto/Keys/Extended/Internal.hs b/src/Haskoin/Crypto/Keys/Extended/Internal.hs new file mode 100644 index 00000000..ba1bd071 --- /dev/null +++ b/src/Haskoin/Crypto/Keys/Extended/Internal.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Haskoin.Crypto.Keys.Extended.Internal + ( Fingerprint (..), + fingerprintToText, + textToFingerprint, + ) +where + +import Control.DeepSeq (NFData) +import Control.Monad ((>=>)) +import Data.Aeson + ( FromJSON (parseJSON), + ToJSON (toEncoding, toJSON), + withText, + ) +import Data.Aeson.Encoding (text) +import Data.Binary (Binary (..)) +import Data.Bytes.Get (getWord32be) +import Data.Bytes.Put (putWord32be) +import Data.Bytes.Serial (Serial (..)) +import Data.Either (fromRight) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) +import Data.Serialize (Serialize (..)) +import Data.Serialize qualified as S +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Typeable (Typeable) +import Data.Word (Word32) +import GHC.Generics (Generic) +import Haskoin.Util.Helpers (decodeHex, encodeHex) +import Text.Read (readEither, readPrec) + +-- | Fingerprint of parent +newtype Fingerprint = Fingerprint {get :: Word32} + deriving (Eq, Ord, Hashable, Typeable, Generic, NFData) + +fingerprintToText :: Fingerprint -> Text +fingerprintToText = encodeHex . S.encode + +textToFingerprint :: Text -> Either String Fingerprint +textToFingerprint = + maybe (Left "Fingerprint: invalid hex") Right . decodeHex >=> S.decode + +instance Show Fingerprint where + show = show . Text.unpack . encodeHex . S.encode + +instance Read Fingerprint where + readPrec = + readPrec + >>= maybe (fail "Fingerprint: invalid hex") pure . decodeHex + >>= either (fail . ("Fingerprint: " <>)) pure . S.decode + +instance IsString Fingerprint where + fromString = + fromRight decodeError + . S.decode + . fromMaybe hexError + . decodeHex + . Text.pack + where + decodeError = error "Fingerprint literal: Unable to decode" + hexError = error "Fingerprint literal: Invalid hex" + +instance Serial Fingerprint where + serialize = putWord32be . (.get) + deserialize = Fingerprint <$> getWord32be + +instance Binary Fingerprint where + put = serialize + get = deserialize + +instance Serialize Fingerprint where + put = serialize + get = deserialize + +instance FromJSON Fingerprint where + parseJSON = withText "Fingerprint" $ either fail pure . textToFingerprint + +instance ToJSON Fingerprint where + toJSON = toJSON . fingerprintToText + toEncoding = text . fingerprintToText \ No newline at end of file diff --git a/src/Haskoin/Crypto/Keys/Mnemonic.hs b/src/Haskoin/Crypto/Keys/Mnemonic.hs new file mode 100644 index 00000000..8762f46d --- /dev/null +++ b/src/Haskoin/Crypto/Keys/Mnemonic.hs @@ -0,0 +1,2233 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +-- | +-- Module : Haskoin.Keys.Mnemonic +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Mnemonic keys (BIP-39). Only English dictionary. +module Haskoin.Crypto.Keys.Mnemonic + ( -- * Mnemonic Sentences + Entropy, + Mnemonic, + Passphrase, + Seed, + toMnemonic, + fromMnemonic, + mnemonicToSeed, + ) +where + +import Control.Monad (when) +import Crypto.Hash (SHA256 (..), hashWith) +import Crypto.KDF.PBKDF2 (Parameters (..), fastPBKDF2_SHA512) +import Data.Bits (shiftL, shiftR) +import Data.ByteArray qualified as BA +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.List +import Data.Map.Strict qualified as M +import Data.Maybe +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as E +import Data.Vector (Vector, (!)) +import Data.Vector qualified as V +import Haskoin.Util + +-- | Random data used to create a mnemonic sentence. Use a good entropy source. +-- You will get your coins stolen if you don't. You have been warned. +type Entropy = ByteString + +-- | Human-readable mnemonic sentence. +type Mnemonic = Text + +-- | Optional passphrase for mnemnoic sentence. +type Passphrase = Text + +-- | Seed for a private key from a mnemonic sentence. +type Seed = ByteString + +-- | Mnemonic key checksum. +type Checksum = ByteString + +-- | Paremeters for PBKDF2 function. +pbkdfParams :: Parameters +pbkdfParams = Parameters {iterCounts = 2048, outputLength = 64} + +-- | Provide intial 'Entropy' as a 'ByteString' of length multiple of 4 bytes. +-- Output a 'Mnemonic' sentence. +toMnemonic :: Entropy -> Either String Mnemonic +toMnemonic ent = do + when (B.null ent) $ + Left "toMnemonic: entropy can not be empty" + when (remainder /= 0) $ + Left "toMnemonic: entropy must be multiples of 4 bytes" + when (cs_len > 16) $ + Left "toMnemonic: maximum entropy is 64 bytes (512 bits)" + return ms + where + (cs_len, remainder) = B.length ent `quotRem` 4 + c = calcCS cs_len ent + indices = bsToIndices $ ent `B.append` c + ms = T.unwords $ map (wl !) indices + +-- | Revert 'toMnemonic'. Do not use this to generate a 'Seed'. Instead use +-- 'mnemonicToSeed'. This outputs the original 'Entropy' used to generate a +-- 'Mnemonic' sentence. +fromMnemonic :: Mnemonic -> Either String Entropy +fromMnemonic ms = do + when (T.null ms) $ + Left "fromMnemonic: empty mnemonic" + when (word_count > 48) $ + Left $ + "fromMnemonic: too many words: " ++ show word_count + when (word_count `mod` 3 /= 0) $ + Left $ + "fromMnemonic: wrong number of words:" ++ show word_count + ms_bs <- indicesToBS =<< getIndices ms_words + let (ms_ent, ms_cs) = B.splitAt (ent_len * 4) ms_bs + ms_cs_num = numCS cs_len ms_cs + ent_cs_num = numCS cs_len $ calcCS cs_len ms_ent + when (ent_cs_num /= ms_cs_num) $ + Left $ + "fromMnemonic: checksum failed: " ++ sh ent_cs_num ms_cs_num + return ms_ent + where + ms_words = T.words ms + word_count = length ms_words + (ent_len, cs_len) = (word_count * 11) `quotRem` 32 + sh cs_a cs_b = show cs_a ++ " /= " ++ show cs_b + +-- | Compute 'Checksum'. +calcCS :: Int -> Entropy -> Checksum +calcCS len = getBits len . BA.convert . hashWith SHA256 + +numCS :: Int -> Entropy -> Integer +numCS len = + shiftCS . bsToInteger + where + shiftCS = case 8 - len `mod` 8 of + 8 -> id + x -> flip shiftR x + +-- | Turn an arbitrary sequence of characters into a 512-bit 'Seed'. Use +-- 'mnemonicToSeed' to get a seed from a 'Mnemonic' sentence. Warning: Does not +-- perform NFKD normalization. +anyToSeed :: Passphrase -> Mnemonic -> Seed +anyToSeed pf ms = + fastPBKDF2_SHA512 + pbkdfParams + (E.encodeUtf8 ms) + ("mnemonic" `mappend` E.encodeUtf8 pf) + +-- | Get a 512-bit 'Seed' from a 'Mnemonic' sentence. Will validate checksum. +-- 'Passphrase' can be used to protect the 'Mnemonic'. Use an empty string as +-- 'Passphrase' if none is required. +mnemonicToSeed :: Passphrase -> Mnemonic -> Either String Seed +mnemonicToSeed pf ms = do + ent <- fromMnemonic ms + mnm <- toMnemonic ent + return $ anyToSeed pf mnm + +-- | Get indices of words in word list. +getIndices :: [Text] -> Either String [Int] +getIndices ws + | null n = return $ catMaybes i + | otherwise = Left $ "getIndices: words not found: " ++ cs w + where + i = map (`M.lookup` wl') ws + n = elemIndices Nothing i + w = T.unwords $ map (ws !!) n + +-- | Turn a list of 11-bit numbers into a 'ByteString' +indicesToBS :: [Int] -> Either String ByteString +indicesToBS is = do + when lrg $ Left "indicesToBS: index larger or equal than 2048" + return . pad . integerToBS $ foldl' f 0 is `shiftL` shift_width + where + lrg = isJust $ find (>= 2048) is + (q, r) = (length is * 11) `quotRem` 8 + shift_width = + if r == 0 + then 0 + else 8 - r + bl = + if r == 0 + then q + else q + 1 -- length of resulting ByteString + pad bs = B.append (B.replicate (bl - B.length bs) 0x00) bs + f acc x = (acc `shiftL` 11) + fromIntegral x + +-- | Turn a 'ByteString' into a list of 11-bit numbers. +bsToIndices :: ByteString -> [Int] +bsToIndices bs = + reverse . go q $ bsToInteger bs `shiftR` r + where + (q, r) = (B.length bs * 8) `quotRem` 11 + go 0 _ = [] + go n i = fromIntegral (i `mod` 2048) : go (n - 1) (i `shiftR` 11) + +wl' :: M.Map Text Int +wl' = V.ifoldr' (flip M.insert) M.empty wl + +-- | Standard English dictionary from BIP-39 specification. +wl :: Vector Text +wl = + V.fromListN + 2048 + [ "abandon", + "ability", + "able", + "about", + "above", + "absent", + "absorb", + "abstract", + "absurd", + "abuse", + "access", + "accident", + "account", + "accuse", + "achieve", + "acid", + "acoustic", + "acquire", + "across", + "act", + "action", + "actor", + "actress", + "actual", + "adapt", + "add", + "addict", + "address", + "adjust", + "admit", + "adult", + "advance", + "advice", + "aerobic", + "affair", + "afford", + "afraid", + "again", + "age", + "agent", + "agree", + "ahead", + "aim", + "air", + "airport", + "aisle", + "alarm", + "album", + "alcohol", + "alert", + "alien", + "all", + "alley", + "allow", + "almost", + "alone", + "alpha", + "already", + "also", + "alter", + "always", + "amateur", + "amazing", + "among", + "amount", + "amused", + "analyst", + "anchor", + "ancient", + "anger", + "angle", + "angry", + "animal", + "ankle", + "announce", + "annual", + "another", + "answer", + "antenna", + "antique", + "anxiety", + "any", + "apart", + "apology", + "appear", + "apple", + "approve", + "april", + "arch", + "arctic", + "area", + "arena", + "argue", + "arm", + "armed", + "armor", + "army", + "around", + "arrange", + "arrest", + "arrive", + "arrow", + "art", + "artefact", + "artist", + "artwork", + "ask", + "aspect", + "assault", + "asset", + "assist", + "assume", + "asthma", + "athlete", + "atom", + "attack", + "attend", + "attitude", + "attract", + "auction", + "audit", + "august", + "aunt", + "author", + "auto", + "autumn", + "average", + "avocado", + "avoid", + "awake", + "aware", + "away", + "awesome", + "awful", + "awkward", + "axis", + "baby", + "bachelor", + "bacon", + "badge", + "bag", + "balance", + "balcony", + "ball", + "bamboo", + "banana", + "banner", + "bar", + "barely", + "bargain", + "barrel", + "base", + "basic", + "basket", + "battle", + "beach", + "bean", + "beauty", + "because", + "become", + "beef", + "before", + "begin", + "behave", + "behind", + "believe", + "below", + "belt", + "bench", + "benefit", + "best", + "betray", + "better", + "between", + "beyond", + "bicycle", + "bid", + "bike", + "bind", + "biology", + "bird", + "birth", + "bitter", + "black", + "blade", + "blame", + "blanket", + "blast", + "bleak", + "bless", + "blind", + "blood", + "blossom", + "blouse", + "blue", + "blur", + "blush", + "board", + "boat", + "body", + "boil", + "bomb", + "bone", + "bonus", + "book", + "boost", + "border", + "boring", + "borrow", + "boss", + "bottom", + "bounce", + "box", + "boy", + "bracket", + "brain", + "brand", + "brass", + "brave", + "bread", + "breeze", + "brick", + "bridge", + "brief", + "bright", + "bring", + "brisk", + "broccoli", + "broken", + "bronze", + "broom", + "brother", + "brown", + "brush", + "bubble", + "buddy", + "budget", + "buffalo", + "build", + "bulb", + "bulk", + "bullet", + "bundle", + "bunker", + "burden", + "burger", + "burst", + "bus", + "business", + "busy", + "butter", + "buyer", + "buzz", + "cabbage", + "cabin", + "cable", + "cactus", + "cage", + "cake", + "call", + "calm", + "camera", + "camp", + "can", + "canal", + "cancel", + "candy", + "cannon", + "canoe", + "canvas", + "canyon", + "capable", + "capital", + "captain", + "car", + "carbon", + "card", + "cargo", + "carpet", + "carry", + "cart", + "case", + "cash", + "casino", + "castle", + "casual", + "cat", + "catalog", + "catch", + "category", + "cattle", + "caught", + "cause", + "caution", + "cave", + "ceiling", + "celery", + "cement", + "census", + "century", + "cereal", + "certain", + "chair", + "chalk", + "champion", + "change", + "chaos", + "chapter", + "charge", + "chase", + "chat", + "cheap", + "check", + "cheese", + "chef", + "cherry", + "chest", + "chicken", + "chief", + "child", + "chimney", + "choice", + "choose", + "chronic", + "chuckle", + "chunk", + "churn", + "cigar", + "cinnamon", + "circle", + "citizen", + "city", + "civil", + "claim", + "clap", + "clarify", + "claw", + "clay", + "clean", + "clerk", + "clever", + "click", + "client", + "cliff", + "climb", + "clinic", + "clip", + "clock", + "clog", + "close", + "cloth", + "cloud", + "clown", + "club", + "clump", + "cluster", + "clutch", + "coach", + "coast", + "coconut", + "code", + "coffee", + "coil", + "coin", + "collect", + "color", + "column", + "combine", + "come", + "comfort", + "comic", + "common", + "company", + "concert", + "conduct", + "confirm", + "congress", + "connect", + "consider", + "control", + "convince", + "cook", + "cool", + "copper", + "copy", + "coral", + "core", + "corn", + "correct", + "cost", + "cotton", + "couch", + "country", + "couple", + "course", + "cousin", + "cover", + "coyote", + "crack", + "cradle", + "craft", + "cram", + "crane", + "crash", + "crater", + "crawl", + "crazy", + "cream", + "credit", + "creek", + "crew", + "cricket", + "crime", + "crisp", + "critic", + "crop", + "cross", + "crouch", + "crowd", + "crucial", + "cruel", + "cruise", + "crumble", + "crunch", + "crush", + "cry", + "crystal", + "cube", + "culture", + "cup", + "cupboard", + "curious", + "current", + "curtain", + "curve", + "cushion", + "custom", + "cute", + "cycle", + "dad", + "damage", + "damp", + "dance", + "danger", + "daring", + "dash", + "daughter", + "dawn", + "day", + "deal", + "debate", + "debris", + "decade", + "december", + "decide", + "decline", + "decorate", + "decrease", + "deer", + "defense", + "define", + "defy", + "degree", + "delay", + "deliver", + "demand", + "demise", + "denial", + "dentist", + "deny", + "depart", + "depend", + "deposit", + "depth", + "deputy", + "derive", + "describe", + "desert", + "design", + "desk", + "despair", + "destroy", + "detail", + "detect", + "develop", + "device", + "devote", + "diagram", + "dial", + "diamond", + "diary", + "dice", + "diesel", + "diet", + "differ", + "digital", + "dignity", + "dilemma", + "dinner", + "dinosaur", + "direct", + "dirt", + "disagree", + "discover", + "disease", + "dish", + "dismiss", + "disorder", + "display", + "distance", + "divert", + "divide", + "divorce", + "dizzy", + "doctor", + "document", + "dog", + "doll", + "dolphin", + "domain", + "donate", + "donkey", + "donor", + "door", + "dose", + "double", + "dove", + "draft", + "dragon", + "drama", + "drastic", + "draw", + "dream", + "dress", + "drift", + "drill", + "drink", + "drip", + "drive", + "drop", + "drum", + "dry", + "duck", + "dumb", + "dune", + "during", + "dust", + "dutch", + "duty", + "dwarf", + "dynamic", + "eager", + "eagle", + "early", + "earn", + "earth", + "easily", + "east", + "easy", + "echo", + "ecology", + "economy", + "edge", + "edit", + "educate", + "effort", + "egg", + "eight", + "either", + "elbow", + "elder", + "electric", + "elegant", + "element", + "elephant", + "elevator", + "elite", + "else", + "embark", + "embody", + "embrace", + "emerge", + "emotion", + "employ", + "empower", + "empty", + "enable", + "enact", + "end", + "endless", + "endorse", + "enemy", + "energy", + "enforce", + "engage", + "engine", + "enhance", + "enjoy", + "enlist", + "enough", + "enrich", + "enroll", + "ensure", + "enter", + "entire", + "entry", + "envelope", + "episode", + "equal", + "equip", + "era", + "erase", + "erode", + "erosion", + "error", + "erupt", + "escape", + "essay", + "essence", + "estate", + "eternal", + "ethics", + "evidence", + "evil", + "evoke", + "evolve", + "exact", + "example", + "excess", + "exchange", + "excite", + "exclude", + "excuse", + "execute", + "exercise", + "exhaust", + "exhibit", + "exile", + "exist", + "exit", + "exotic", + "expand", + "expect", + "expire", + "explain", + "expose", + "express", + "extend", + "extra", + "eye", + "eyebrow", + "fabric", + "face", + "faculty", + "fade", + "faint", + "faith", + "fall", + "false", + "fame", + "family", + "famous", + "fan", + "fancy", + "fantasy", + "farm", + "fashion", + "fat", + "fatal", + "father", + "fatigue", + "fault", + "favorite", + "feature", + "february", + "federal", + "fee", + "feed", + "feel", + "female", + "fence", + "festival", + "fetch", + "fever", + "few", + "fiber", + "fiction", + "field", + "figure", + "file", + "film", + "filter", + "final", + "find", + "fine", + "finger", + "finish", + "fire", + "firm", + "first", + "fiscal", + "fish", + "fit", + "fitness", + "fix", + "flag", + "flame", + "flash", + "flat", + "flavor", + "flee", + "flight", + "flip", + "float", + "flock", + "floor", + "flower", + "fluid", + "flush", + "fly", + "foam", + "focus", + "fog", + "foil", + "fold", + "follow", + "food", + "foot", + "force", + "forest", + "forget", + "fork", + "fortune", + "forum", + "forward", + "fossil", + "foster", + "found", + "fox", + "fragile", + "frame", + "frequent", + "fresh", + "friend", + "fringe", + "frog", + "front", + "frost", + "frown", + "frozen", + "fruit", + "fuel", + "fun", + "funny", + "furnace", + "fury", + "future", + "gadget", + "gain", + "galaxy", + "gallery", + "game", + "gap", + "garage", + "garbage", + "garden", + "garlic", + "garment", + "gas", + "gasp", + "gate", + "gather", + "gauge", + "gaze", + "general", + "genius", + "genre", + "gentle", + "genuine", + "gesture", + "ghost", + "giant", + "gift", + "giggle", + "ginger", + "giraffe", + "girl", + "give", + "glad", + "glance", + "glare", + "glass", + "glide", + "glimpse", + "globe", + "gloom", + "glory", + "glove", + "glow", + "glue", + "goat", + "goddess", + "gold", + "good", + "goose", + "gorilla", + "gospel", + "gossip", + "govern", + "gown", + "grab", + "grace", + "grain", + "grant", + "grape", + "grass", + "gravity", + "great", + "green", + "grid", + "grief", + "grit", + "grocery", + "group", + "grow", + "grunt", + "guard", + "guess", + "guide", + "guilt", + "guitar", + "gun", + "gym", + "habit", + "hair", + "half", + "hammer", + "hamster", + "hand", + "happy", + "harbor", + "hard", + "harsh", + "harvest", + "hat", + "have", + "hawk", + "hazard", + "head", + "health", + "heart", + "heavy", + "hedgehog", + "height", + "hello", + "helmet", + "help", + "hen", + "hero", + "hidden", + "high", + "hill", + "hint", + "hip", + "hire", + "history", + "hobby", + "hockey", + "hold", + "hole", + "holiday", + "hollow", + "home", + "honey", + "hood", + "hope", + "horn", + "horror", + "horse", + "hospital", + "host", + "hotel", + "hour", + "hover", + "hub", + "huge", + "human", + "humble", + "humor", + "hundred", + "hungry", + "hunt", + "hurdle", + "hurry", + "hurt", + "husband", + "hybrid", + "ice", + "icon", + "idea", + "identify", + "idle", + "ignore", + "ill", + "illegal", + "illness", + "image", + "imitate", + "immense", + "immune", + "impact", + "impose", + "improve", + "impulse", + "inch", + "include", + "income", + "increase", + "index", + "indicate", + "indoor", + "industry", + "infant", + "inflict", + "inform", + "inhale", + "inherit", + "initial", + "inject", + "injury", + "inmate", + "inner", + "innocent", + "input", + "inquiry", + "insane", + "insect", + "inside", + "inspire", + "install", + "intact", + "interest", + "into", + "invest", + "invite", + "involve", + "iron", + "island", + "isolate", + "issue", + "item", + "ivory", + "jacket", + "jaguar", + "jar", + "jazz", + "jealous", + "jeans", + "jelly", + "jewel", + "job", + "join", + "joke", + "journey", + "joy", + "judge", + "juice", + "jump", + "jungle", + "junior", + "junk", + "just", + "kangaroo", + "keen", + "keep", + "ketchup", + "key", + "kick", + "kid", + "kidney", + "kind", + "kingdom", + "kiss", + "kit", + "kitchen", + "kite", + "kitten", + "kiwi", + "knee", + "knife", + "knock", + "know", + "lab", + "label", + "labor", + "ladder", + "lady", + "lake", + "lamp", + "language", + "laptop", + "large", + "later", + "latin", + "laugh", + "laundry", + "lava", + "law", + "lawn", + "lawsuit", + "layer", + "lazy", + "leader", + "leaf", + "learn", + "leave", + "lecture", + "left", + "leg", + "legal", + "legend", + "leisure", + "lemon", + "lend", + "length", + "lens", + "leopard", + "lesson", + "letter", + "level", + "liar", + "liberty", + "library", + "license", + "life", + "lift", + "light", + "like", + "limb", + "limit", + "link", + "lion", + "liquid", + "list", + "little", + "live", + "lizard", + "load", + "loan", + "lobster", + "local", + "lock", + "logic", + "lonely", + "long", + "loop", + "lottery", + "loud", + "lounge", + "love", + "loyal", + "lucky", + "luggage", + "lumber", + "lunar", + "lunch", + "luxury", + "lyrics", + "machine", + "mad", + "magic", + "magnet", + "maid", + "mail", + "main", + "major", + "make", + "mammal", + "man", + "manage", + "mandate", + "mango", + "mansion", + "manual", + "maple", + "marble", + "march", + "margin", + "marine", + "market", + "marriage", + "mask", + "mass", + "master", + "match", + "material", + "math", + "matrix", + "matter", + "maximum", + "maze", + "meadow", + "mean", + "measure", + "meat", + "mechanic", + "medal", + "media", + "melody", + "melt", + "member", + "memory", + "mention", + "menu", + "mercy", + "merge", + "merit", + "merry", + "mesh", + "message", + "metal", + "method", + "middle", + "midnight", + "milk", + "million", + "mimic", + "mind", + "minimum", + "minor", + "minute", + "miracle", + "mirror", + "misery", + "miss", + "mistake", + "mix", + "mixed", + "mixture", + "mobile", + "model", + "modify", + "mom", + "moment", + "monitor", + "monkey", + "monster", + "month", + "moon", + "moral", + "more", + "morning", + "mosquito", + "mother", + "motion", + "motor", + "mountain", + "mouse", + "move", + "movie", + "much", + "muffin", + "mule", + "multiply", + "muscle", + "museum", + "mushroom", + "music", + "must", + "mutual", + "myself", + "mystery", + "myth", + "naive", + "name", + "napkin", + "narrow", + "nasty", + "nation", + "nature", + "near", + "neck", + "need", + "negative", + "neglect", + "neither", + "nephew", + "nerve", + "nest", + "net", + "network", + "neutral", + "never", + "news", + "next", + "nice", + "night", + "noble", + "noise", + "nominee", + "noodle", + "normal", + "north", + "nose", + "notable", + "note", + "nothing", + "notice", + "novel", + "now", + "nuclear", + "number", + "nurse", + "nut", + "oak", + "obey", + "object", + "oblige", + "obscure", + "observe", + "obtain", + "obvious", + "occur", + "ocean", + "october", + "odor", + "off", + "offer", + "office", + "often", + "oil", + "okay", + "old", + "olive", + "olympic", + "omit", + "once", + "one", + "onion", + "online", + "only", + "open", + "opera", + "opinion", + "oppose", + "option", + "orange", + "orbit", + "orchard", + "order", + "ordinary", + "organ", + "orient", + "original", + "orphan", + "ostrich", + "other", + "outdoor", + "outer", + "output", + "outside", + "oval", + "oven", + "over", + "own", + "owner", + "oxygen", + "oyster", + "ozone", + "pact", + "paddle", + "page", + "pair", + "palace", + "palm", + "panda", + "panel", + "panic", + "panther", + "paper", + "parade", + "parent", + "park", + "parrot", + "party", + "pass", + "patch", + "path", + "patient", + "patrol", + "pattern", + "pause", + "pave", + "payment", + "peace", + "peanut", + "pear", + "peasant", + "pelican", + "pen", + "penalty", + "pencil", + "people", + "pepper", + "perfect", + "permit", + "person", + "pet", + "phone", + "photo", + "phrase", + "physical", + "piano", + "picnic", + "picture", + "piece", + "pig", + "pigeon", + "pill", + "pilot", + "pink", + "pioneer", + "pipe", + "pistol", + "pitch", + "pizza", + "place", + "planet", + "plastic", + "plate", + "play", + "please", + "pledge", + "pluck", + "plug", + "plunge", + "poem", + "poet", + "point", + "polar", + "pole", + "police", + "pond", + "pony", + "pool", + "popular", + "portion", + "position", + "possible", + "post", + "potato", + "pottery", + "poverty", + "powder", + "power", + "practice", + "praise", + "predict", + "prefer", + "prepare", + "present", + "pretty", + "prevent", + "price", + "pride", + "primary", + "print", + "priority", + "prison", + "private", + "prize", + "problem", + "process", + "produce", + "profit", + "program", + "project", + "promote", + "proof", + "property", + "prosper", + "protect", + "proud", + "provide", + "public", + "pudding", + "pull", + "pulp", + "pulse", + "pumpkin", + "punch", + "pupil", + "puppy", + "purchase", + "purity", + "purpose", + "purse", + "push", + "put", + "puzzle", + "pyramid", + "quality", + "quantum", + "quarter", + "question", + "quick", + "quit", + "quiz", + "quote", + "rabbit", + "raccoon", + "race", + "rack", + "radar", + "radio", + "rail", + "rain", + "raise", + "rally", + "ramp", + "ranch", + "random", + "range", + "rapid", + "rare", + "rate", + "rather", + "raven", + "raw", + "razor", + "ready", + "real", + "reason", + "rebel", + "rebuild", + "recall", + "receive", + "recipe", + "record", + "recycle", + "reduce", + "reflect", + "reform", + "refuse", + "region", + "regret", + "regular", + "reject", + "relax", + "release", + "relief", + "rely", + "remain", + "remember", + "remind", + "remove", + "render", + "renew", + "rent", + "reopen", + "repair", + "repeat", + "replace", + "report", + "require", + "rescue", + "resemble", + "resist", + "resource", + "response", + "result", + "retire", + "retreat", + "return", + "reunion", + "reveal", + "review", + "reward", + "rhythm", + "rib", + "ribbon", + "rice", + "rich", + "ride", + "ridge", + "rifle", + "right", + "rigid", + "ring", + "riot", + "ripple", + "risk", + "ritual", + "rival", + "river", + "road", + "roast", + "robot", + "robust", + "rocket", + "romance", + "roof", + "rookie", + "room", + "rose", + "rotate", + "rough", + "round", + "route", + "royal", + "rubber", + "rude", + "rug", + "rule", + "run", + "runway", + "rural", + "sad", + "saddle", + "sadness", + "safe", + "sail", + "salad", + "salmon", + "salon", + "salt", + "salute", + "same", + "sample", + "sand", + "satisfy", + "satoshi", + "sauce", + "sausage", + "save", + "say", + "scale", + "scan", + "scare", + "scatter", + "scene", + "scheme", + "school", + "science", + "scissors", + "scorpion", + "scout", + "scrap", + "screen", + "script", + "scrub", + "sea", + "search", + "season", + "seat", + "second", + "secret", + "section", + "security", + "seed", + "seek", + "segment", + "select", + "sell", + "seminar", + "senior", + "sense", + "sentence", + "series", + "service", + "session", + "settle", + "setup", + "seven", + "shadow", + "shaft", + "shallow", + "share", + "shed", + "shell", + "sheriff", + "shield", + "shift", + "shine", + "ship", + "shiver", + "shock", + "shoe", + "shoot", + "shop", + "short", + "shoulder", + "shove", + "shrimp", + "shrug", + "shuffle", + "shy", + "sibling", + "sick", + "side", + "siege", + "sight", + "sign", + "silent", + "silk", + "silly", + "silver", + "similar", + "simple", + "since", + "sing", + "siren", + "sister", + "situate", + "six", + "size", + "skate", + "sketch", + "ski", + "skill", + "skin", + "skirt", + "skull", + "slab", + "slam", + "sleep", + "slender", + "slice", + "slide", + "slight", + "slim", + "slogan", + "slot", + "slow", + "slush", + "small", + "smart", + "smile", + "smoke", + "smooth", + "snack", + "snake", + "snap", + "sniff", + "snow", + "soap", + "soccer", + "social", + "sock", + "soda", + "soft", + "solar", + "soldier", + "solid", + "solution", + "solve", + "someone", + "song", + "soon", + "sorry", + "sort", + "soul", + "sound", + "soup", + "source", + "south", + "space", + "spare", + "spatial", + "spawn", + "speak", + "special", + "speed", + "spell", + "spend", + "sphere", + "spice", + "spider", + "spike", + "spin", + "spirit", + "split", + "spoil", + "sponsor", + "spoon", + "sport", + "spot", + "spray", + "spread", + "spring", + "spy", + "square", + "squeeze", + "squirrel", + "stable", + "stadium", + "staff", + "stage", + "stairs", + "stamp", + "stand", + "start", + "state", + "stay", + "steak", + "steel", + "stem", + "step", + "stereo", + "stick", + "still", + "sting", + "stock", + "stomach", + "stone", + "stool", + "story", + "stove", + "strategy", + "street", + "strike", + "strong", + "struggle", + "student", + "stuff", + "stumble", + "style", + "subject", + "submit", + "subway", + "success", + "such", + "sudden", + "suffer", + "sugar", + "suggest", + "suit", + "summer", + "sun", + "sunny", + "sunset", + "super", + "supply", + "supreme", + "sure", + "surface", + "surge", + "surprise", + "surround", + "survey", + "suspect", + "sustain", + "swallow", + "swamp", + "swap", + "swarm", + "swear", + "sweet", + "swift", + "swim", + "swing", + "switch", + "sword", + "symbol", + "symptom", + "syrup", + "system", + "table", + "tackle", + "tag", + "tail", + "talent", + "talk", + "tank", + "tape", + "target", + "task", + "taste", + "tattoo", + "taxi", + "teach", + "team", + "tell", + "ten", + "tenant", + "tennis", + "tent", + "term", + "test", + "text", + "thank", + "that", + "theme", + "then", + "theory", + "there", + "they", + "thing", + "this", + "thought", + "three", + "thrive", + "throw", + "thumb", + "thunder", + "ticket", + "tide", + "tiger", + "tilt", + "timber", + "time", + "tiny", + "tip", + "tired", + "tissue", + "title", + "toast", + "tobacco", + "today", + "toddler", + "toe", + "together", + "toilet", + "token", + "tomato", + "tomorrow", + "tone", + "tongue", + "tonight", + "tool", + "tooth", + "top", + "topic", + "topple", + "torch", + "tornado", + "tortoise", + "toss", + "total", + "tourist", + "toward", + "tower", + "town", + "toy", + "track", + "trade", + "traffic", + "tragic", + "train", + "transfer", + "trap", + "trash", + "travel", + "tray", + "treat", + "tree", + "trend", + "trial", + "tribe", + "trick", + "trigger", + "trim", + "trip", + "trophy", + "trouble", + "truck", + "true", + "truly", + "trumpet", + "trust", + "truth", + "try", + "tube", + "tuition", + "tumble", + "tuna", + "tunnel", + "turkey", + "turn", + "turtle", + "twelve", + "twenty", + "twice", + "twin", + "twist", + "two", + "type", + "typical", + "ugly", + "umbrella", + "unable", + "unaware", + "uncle", + "uncover", + "under", + "undo", + "unfair", + "unfold", + "unhappy", + "uniform", + "unique", + "unit", + "universe", + "unknown", + "unlock", + "until", + "unusual", + "unveil", + "update", + "upgrade", + "uphold", + "upon", + "upper", + "upset", + "urban", + "urge", + "usage", + "use", + "used", + "useful", + "useless", + "usual", + "utility", + "vacant", + "vacuum", + "vague", + "valid", + "valley", + "valve", + "van", + "vanish", + "vapor", + "various", + "vast", + "vault", + "vehicle", + "velvet", + "vendor", + "venture", + "venue", + "verb", + "verify", + "version", + "very", + "vessel", + "veteran", + "viable", + "vibrant", + "vicious", + "victory", + "video", + "view", + "village", + "vintage", + "violin", + "virtual", + "virus", + "visa", + "visit", + "visual", + "vital", + "vivid", + "vocal", + "voice", + "void", + "volcano", + "volume", + "vote", + "voyage", + "wage", + "wagon", + "wait", + "walk", + "wall", + "walnut", + "want", + "warfare", + "warm", + "warrior", + "wash", + "wasp", + "waste", + "water", + "wave", + "way", + "wealth", + "weapon", + "wear", + "weasel", + "weather", + "web", + "wedding", + "weekend", + "weird", + "welcome", + "west", + "wet", + "whale", + "what", + "wheat", + "wheel", + "when", + "where", + "whip", + "whisper", + "wide", + "width", + "wife", + "wild", + "will", + "win", + "window", + "wine", + "wing", + "wink", + "winner", + "winter", + "wire", + "wisdom", + "wise", + "wish", + "witness", + "wolf", + "woman", + "wonder", + "wood", + "wool", + "word", + "work", + "world", + "worry", + "worth", + "wrap", + "wreck", + "wrestle", + "wrist", + "write", + "wrong", + "yard", + "year", + "yellow", + "you", + "young", + "youth", + "zebra", + "zero", + "zone", + "zoo" + ] diff --git a/src/Haskoin/Crypto/Signature.hs b/src/Haskoin/Crypto/Signature.hs index 31e24047..c91213a1 100644 --- a/src/Haskoin/Crypto/Signature.hs +++ b/src/Haskoin/Crypto/Signature.hs @@ -1,93 +1,106 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Crypto.Signature -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1 -library. --} -module Haskoin.Crypto.Signature ( - -- * Signatures - putSig, - getSig, +-- | +-- Module : Haskoin.Crypto.Signature +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1 +-- library. +module Haskoin.Crypto.Signature + ( -- * Signatures signHash, verifyHashSig, isCanonicalHalfOrder, decodeStrictSig, exportSig, -) where + ) +where import Control.Monad (guard, unless, when) import Crypto.Secp256k1 +import Data.Aeson +import Data.Aeson.Encoding import Data.Binary (Binary (..)) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial import Data.Maybe (fromMaybe, isNothing) import Data.Serialize (Serialize (..)) +import Data.Text qualified as T import Haskoin.Crypto.Hash +import Haskoin.Util.Helpers +import Haskoin.Util.Marshal import Numeric (showHex) -- | Convert 256-bit hash into a 'Msg' for signing or verification. hashToMsg :: Hash256 -> Msg hashToMsg = - fromMaybe e . msg . runPutS . serialize + fromMaybe e . msg . runPutS . serialize where e = error "Could not convert 32-byte hash to secp256k1 message" -- | Sign a 256-bit hash using secp256k1 elliptic curve. -signHash :: SecKey -> Hash256 -> Sig -signHash k = signMsg k . hashToMsg +signHash :: Ctx -> SecKey -> Hash256 -> Sig +signHash ctx k = signMsg ctx k . hashToMsg -- | Verify an ECDSA signature for a 256-bit hash. -verifyHashSig :: Hash256 -> Sig -> PubKey -> Bool -verifyHashSig h s p = verifySig p norm (hashToMsg h) +verifyHashSig :: Ctx -> Hash256 -> Sig -> PubKey -> Bool +verifyHashSig ctx h s p = verifySig ctx p norm (hashToMsg h) where - norm = fromMaybe s (normalizeSig s) + norm = fromMaybe s (normalizeSig ctx s) --- | Deserialize an ECDSA signature as commonly encoded in Bitcoin. -getSig :: MonadGet m => m Sig -getSig = do - l <- - lookAhead $ do - t <- getWord8 - -- 0x30 is DER sequence type - unless (t == 0x30) $ - fail $ - "Bad DER identifier byte 0x" ++ showHex t ". Expecting 0x30" - l <- getWord8 - when (l == 0x00) $ fail "Indeterminate form unsupported" - when (l >= 0x80) $ fail "Multi-octect length not supported" - return $ fromIntegral l +instance Marshal Ctx Sig where + marshalGet ctx = do + l <- lookAhead $ do + t <- getWord8 + -- 0x30 is DER sequence type + unless (t == 0x30) $ + fail $ + "Bad DER identifier byte 0x" ++ showHex t ". Expecting 0x30" + l <- getWord8 + when (l == 0x00) $ fail "Indeterminate form unsupported" + when (l >= 0x80) $ fail "Multi-octect length not supported" + return $ fromIntegral l bs <- getByteString $ l + 2 - case decodeStrictSig bs of - Just s -> return s - Nothing -> fail "Invalid signature" + case decodeStrictSig ctx bs of + Just s -> return s + Nothing -> fail "Invalid signature" --- | Serialize an ECDSA signature for Bitcoin use. -putSig :: MonadPut m => Sig -> m () -putSig s = putByteString $ exportSig s + marshalPut ctx s = putByteString $ exportSig ctx s + +instance MarshalJSON Ctx Sig where + marshalValue ctx = String . encodeHex . exportSig ctx + marshalEncoding ctx = hexEncoding . L.fromStrict . exportSig ctx + unmarshalValue ctx = + withText "Sig" $ \t -> + case decodeHex t >>= importSig ctx of + Nothing -> fail $ "Could not decode signature: " <> T.unpack t + Just s -> return s -- | Is canonical half order. -isCanonicalHalfOrder :: Sig -> Bool -isCanonicalHalfOrder = isNothing . normalizeSig +isCanonicalHalfOrder :: Ctx -> Sig -> Bool +isCanonicalHalfOrder ctx = isNothing . normalizeSig ctx -- | Decode signature strictly. -decodeStrictSig :: ByteString -> Maybe Sig -decodeStrictSig bs = do - g <- importSig bs - -- - -- 4.1.4.1 (r and s can not be zero) - let compact = exportCompactSig g - let zero = BS.replicate 32 0 - guard $ BS.take 32 (getCompactSig compact) /= zero - guard $ BS.take 32 (BS.drop 32 (getCompactSig compact)) /= zero - guard $ isCanonicalHalfOrder g - return g +decodeStrictSig :: Ctx -> ByteString -> Maybe Sig +decodeStrictSig ctx bs = do + g <- importSig ctx bs + -- + -- 4.1.4.1 (r and s can not be zero) + let compact = exportCompactSig ctx g + let zero = B.replicate 32 0 + guard $ B.take 32 compact.get /= zero + guard $ (B.take 32 . B.drop 32) compact.get /= zero + guard $ isCanonicalHalfOrder ctx g + return g diff --git a/src/Haskoin/Data.hs b/src/Haskoin/Data.hs deleted file mode 100644 index bb03fdcb..00000000 --- a/src/Haskoin/Data.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} - -module Haskoin.Data ( - Network (..), -) where - -import Control.DeepSeq -import Data.Binary (Binary (..)) -import Data.ByteString (ByteString) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.List -import Data.Serialize (Serialize (..)) -import Data.String -import Data.Text (Text) -import Data.Word (Word32, Word64, Word8) -import GHC.Generics (Generic) -import Haskoin.Block.Common -import Text.Read - --- | Network definition. -data Network = Network - { -- | lowercase alphanumeric and dashes - getNetworkName :: !String - , -- | prefix for 'Base58' P2PKH addresses - getAddrPrefix :: !Word8 - , -- | prefix for 'Base58' P2SH addresses - getScriptPrefix :: !Word8 - , -- | prefix for WIF private key - getSecretPrefix :: !Word8 - , -- | prefix for extended public key - getExtPubKeyPrefix :: !Word32 - , -- | prefix for extended private key - getExtSecretPrefix :: !Word32 - , -- | network magic - getNetworkMagic :: !Word32 - , -- | genesis block header - getGenesisHeader :: !BlockHeader - , -- | maximum block size in bytes - getMaxBlockSize :: !Int - , -- | maximum amount of satoshi - getMaxSatoshi :: !Word64 - , -- | user agent string - getHaskoinUserAgent :: !ByteString - , -- | default port for P2P connections - getDefaultPort :: !Int - , -- | allow min difficulty blocks (testnet) - getAllowMinDifficultyBlocks :: !Bool - , -- | do not retarget difficulty (regtest) - getPowNoRetargetting :: !Bool - , -- | proof-of-work target higest possible value - getPowLimit :: !Integer - , -- | block at which BIP34 activates - getBip34Block :: !(BlockHeight, BlockHash) - , -- | block at which BIP65 activates - getBip65Height :: !BlockHeight - , -- | block at which BIP66 activates - getBip66Height :: !BlockHeight - , -- | time between difficulty retargets - getTargetTimespan :: !Word32 - , -- | time between blocks - getTargetSpacing :: !Word32 - , -- | checkpoints - getCheckpoints :: ![(BlockHeight, BlockHash)] - , -- | BIP44 derivation path root - getBip44Coin :: !Word32 - , -- | peer-to-peer network seeds - getSeeds :: ![String] - , -- | fork id for replay protection - getSigHashForkId :: !(Maybe Word32) - , -- | EDA start block height - getEdaBlockHeight :: !(Maybe Word32) - , -- | DAA start block height - getDaaBlockHeight :: !(Maybe Word32) - , -- | asert3-2d algorithm activation time - -- TODO: Replace with block height after fork - getAsertActivationTime :: !(Maybe Word32) - , -- | asert3-2d algorithm halflife (not used for non-BCH networks) - getAsertHalfLife :: !Integer - , -- | segregated witness active - getSegWit :: !Bool - , -- | 'CashAddr' prefix (for Bitcoin Cash) - getCashAddrPrefix :: !(Maybe Text) - , -- | 'Bech32' prefix (for SegWit network) - getBech32Prefix :: !(Maybe Text) - , -- | Replace-By-Fee (BIP-125) - getReplaceByFee :: !Bool - , -- | Subsidy halving interval - getHalvingInterval :: !Word32 - } - deriving (Eq, Show, Read, Generic, NFData) diff --git a/src/Haskoin/Keys.hs b/src/Haskoin/Keys.hs deleted file mode 100644 index fcc49713..00000000 --- a/src/Haskoin/Keys.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- | -Module : Haskoin.Keys -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -ECDSA private and public keys, extended keys (BIP-32) and mnemonic sentences -(BIP-39). --} -module Haskoin.Keys ( - module Haskoin.Keys.Common, - module Haskoin.Keys.Extended, - module Haskoin.Keys.Mnemonic, -) where - -import Haskoin.Keys.Common -import Haskoin.Keys.Extended -import Haskoin.Keys.Mnemonic diff --git a/src/Haskoin/Keys/Common.hs b/src/Haskoin/Keys/Common.hs deleted file mode 100644 index c88c0f97..00000000 --- a/src/Haskoin/Keys/Common.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- | -Module : Haskoin.Keys.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -ECDSA private and public key functions. --} -module Haskoin.Keys.Common ( - -- * Public & Private Keys - PubKeyI (..), - SecKeyI (..), - exportPubKey, - importPubKey, - wrapPubKey, - derivePubKeyI, - wrapSecKey, - fromMiniKey, - tweakPubKey, - tweakSecKey, - getSecKey, - secKey, - - -- ** Private Key Wallet Import Format (WIF) - fromWif, - toWif, -) where - -import Control.DeepSeq -import Control.Monad (guard, mzero, (<=<)) -import Crypto.Secp256k1 -import Data.Aeson ( - FromJSON, - ToJSON (..), - Value (String), - parseJSON, - withText, - ) -import Data.Aeson.Encoding (unsafeToEncoding) -import Data.Binary (Binary (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder (char7) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Hashable -import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) -import Data.String (IsString, fromString) -import Data.String.Conversions (cs) -import GHC.Generics (Generic) -import Haskoin.Address.Base58 -import Haskoin.Crypto.Hash -import Haskoin.Data -import Haskoin.Util - --- | Elliptic curve public key type with expected serialized compression flag. -data PubKeyI = PubKeyI - { pubKeyPoint :: !PubKey - , pubKeyCompressed :: !Bool - } - deriving (Generic, Eq, Show, Read, Hashable, NFData) - -instance IsString PubKeyI where - fromString str = - fromMaybe e $ eitherToMaybe . runGetS deserialize <=< decodeHex $ cs str - where - e = error "Could not decode public key" - -instance ToJSON PubKeyI where - toJSON = String . encodeHex . runPutS . serialize - toEncoding s = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (runPutL (serialize s)) - <> char7 '"' - -instance FromJSON PubKeyI where - parseJSON = - withText "PubKeyI" $ - maybe mzero return . ((eitherToMaybe . runGetS deserialize) <=< decodeHex) - -instance Serial PubKeyI where - deserialize = - s >>= \case - True -> c - False -> u - where - s = - lookAhead $ - getWord8 >>= \case - 0x02 -> return True - 0x03 -> return True - 0x04 -> return False - _ -> fail "Not a public key" - c = do - bs <- getByteString 33 - maybe (fail "Could not decode public key") return $ - PubKeyI <$> importPubKey bs <*> pure True - u = do - bs <- getByteString 65 - maybe (fail "Could not decode public key") return $ - PubKeyI <$> importPubKey bs <*> pure False - - serialize pk = putByteString $ exportPubKey (pubKeyCompressed pk) (pubKeyPoint pk) - -instance Serialize PubKeyI where - put = serialize - get = deserialize - -instance Binary PubKeyI where - put = serialize - get = deserialize - --- | Wrap a public key from secp256k1 library adding information about compression. -wrapPubKey :: Bool -> PubKey -> PubKeyI -wrapPubKey c p = PubKeyI p c - -{- | Derives a public key from a private key. This function will preserve - compression flag. --} -derivePubKeyI :: SecKeyI -> PubKeyI -derivePubKeyI (SecKeyI d c) = PubKeyI (derivePubKey d) c - --- | Tweak a public key. -tweakPubKey :: PubKey -> Hash256 -> Maybe PubKey -tweakPubKey p h = tweakAddPubKey p =<< tweak (runPutS (serialize h)) - -{- | Elliptic curve private key type with expected public key compression - information. Compression information is stored in private key WIF formats and - needs to be preserved to generate the correct address from the corresponding - public key. --} -data SecKeyI = SecKeyI - { secKeyData :: !SecKey - , secKeyCompressed :: !Bool - } - deriving (Eq, Show, Read, Generic, NFData) - --- | Wrap private key with corresponding public key compression flag. -wrapSecKey :: Bool -> SecKey -> SecKeyI -wrapSecKey c d = SecKeyI d c - --- | Tweak a private key. -tweakSecKey :: SecKey -> Hash256 -> Maybe SecKey -tweakSecKey key h = tweakAddSecKey key =<< tweak (runPutS (serialize h)) - --- | Decode Casascius mini private keys (22 or 30 characters). -fromMiniKey :: ByteString -> Maybe SecKeyI -fromMiniKey bs = do - guard checkShortKey - wrapSecKey False <$> secKey (runPutS (serialize (sha256 bs))) - where - checkHash = runPutS $ serialize $ sha256 $ bs `BS.append` "?" - checkShortKey = BS.length bs `elem` [22, 30] && BS.head checkHash == 0x00 - --- | Decode private key from WIF (wallet import format) string. -fromWif :: Network -> Base58 -> Maybe SecKeyI -fromWif net wif = do - bs <- decodeBase58Check wif - -- Check that this is a private key - guard (BS.head bs == getSecretPrefix net) - case BS.length bs of - -- Uncompressed format - 33 -> wrapSecKey False <$> secKey (BS.tail bs) - -- Compressed format - 34 -> do - guard $ BS.last bs == 0x01 - wrapSecKey True <$> secKey (BS.tail $ BS.init bs) - -- Bad length - _ -> Nothing - --- | Encode private key into a WIF string. -toWif :: Network -> SecKeyI -> Base58 -toWif net (SecKeyI k c) = - encodeBase58Check . BS.cons (getSecretPrefix net) $ - if c - then getSecKey k `BS.snoc` 0x01 - else getSecKey k diff --git a/src/Haskoin/Keys/Extended.hs b/src/Haskoin/Keys/Extended.hs deleted file mode 100644 index 4cbfe109..00000000 --- a/src/Haskoin/Keys/Extended.hs +++ /dev/null @@ -1,1084 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : Haskoin.Keys.Extended -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -BIP-32 extended keys. --} -module Haskoin.Keys.Extended ( - -- * Extended Keys - XPubKey (..), - XPrvKey (..), - ChainCode, - KeyIndex, - Fingerprint, - fingerprintToText, - textToFingerprint, - DerivationException (..), - makeXPrvKey, - deriveXPubKey, - prvSubKey, - pubSubKey, - hardSubKey, - xPrvIsHard, - xPubIsHard, - xPrvChild, - xPubChild, - xPubID, - xPrvID, - xPubFP, - xPrvFP, - xPubAddr, - xPubWitnessAddr, - xPubCompatWitnessAddr, - xPubExport, - xPubToJSON, - xPubToEncoding, - xPubFromJSON, - xPrvExport, - xPrvToJSON, - xPrvToEncoding, - xPrvFromJSON, - xPubImport, - xPrvImport, - xPrvWif, - putXPrvKey, - putXPubKey, - getXPrvKey, - getXPubKey, - - -- ** Helper Functions - prvSubKeys, - pubSubKeys, - hardSubKeys, - deriveAddr, - deriveWitnessAddr, - deriveCompatWitnessAddr, - deriveAddrs, - deriveWitnessAddrs, - deriveCompatWitnessAddrs, - deriveMSAddr, - deriveMSAddrs, - cycleIndex, - - -- ** Derivation Paths - DerivPathI (..), - AnyDeriv, - HardDeriv, - SoftDeriv, - HardOrAny, - AnyOrSoft, - DerivPath, - HardPath, - SoftPath, - Bip32PathIndex (..), - derivePath, - derivePubPath, - toHard, - toSoft, - toGeneric, - (++/), - pathToStr, - listToPath, - pathToList, - - -- *** Derivation Path Parser - XKey (..), - ParsedPath (..), - parsePath, - parseHard, - parseSoft, - applyPath, - derivePathAddr, - derivePathAddrs, - derivePathMSAddr, - derivePathMSAddrs, - concatBip32Segments, -) where - -import Control.Applicative -import Control.DeepSeq -import Control.Exception (Exception, throw) -import Control.Monad (guard, mzero, unless, (<=<)) -import Crypto.Secp256k1 -import Data.Aeson as A ( - FromJSON, - ToJSON (..), - Value (String), - parseJSON, - toJSON, - withText, - ) -import Data.Aeson.Encoding (Encoding, text) -import Data.Aeson.Types (Parser) -import Data.Binary (Binary (get, put)) -import Data.Bits (clearBit, setBit, testBit) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Either (fromRight) -import Data.Hashable -import Data.List (foldl') -import Data.List.Split (splitOn) -import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) -import qualified Data.Serialize as S -import Data.String (IsString, fromString) -import Data.String.Conversions (cs) -import qualified Data.Text as Text -import Data.Typeable (Typeable) -import Data.Word (Word32, Word8) -import GHC.Generics (Generic) -import Haskoin.Address -import Haskoin.Crypto.Hash -import Haskoin.Data -import Haskoin.Keys.Common -import Haskoin.Keys.Extended.Internal ( - Fingerprint (..), - fingerprintToText, - textToFingerprint, - ) -import Haskoin.Script -import Haskoin.Util -import Text.Read as R -import Text.Read.Lex - -{- | A derivation exception is thrown in the very unlikely event that a - derivation is invalid. --} -newtype DerivationException = DerivationException String - deriving (Eq, Read, Show, Typeable, Generic, NFData) - -instance Exception DerivationException - --- | Chain code as specified in BIP-32. -type ChainCode = Hash256 - --- | Index of key as specified in BIP-32. -type KeyIndex = Word32 - -{- | Data type representing an extended BIP32 private key. An extended key - is a node in a tree of key derivations. It has a depth in the tree, a - parent node and an index to differentiate it from other siblings. --} -data XPrvKey = XPrvKey - { -- | depth in the tree - xPrvDepth :: !Word8 - , -- | fingerprint of parent - xPrvParent :: !Fingerprint - , -- | derivation index - xPrvIndex :: !KeyIndex - , -- | chain code - xPrvChain :: !ChainCode - , -- | private key of this node - xPrvKey :: !SecKey - } - deriving (Generic, Eq, Show, Read, NFData, Hashable) - -instance Serial XPrvKey where - serialize k = do - putWord8 $ xPrvDepth k - serialize $ xPrvParent k - putWord32be $ xPrvIndex k - serialize $ xPrvChain k - putPadPrvKey $ xPrvKey k - deserialize = - XPrvKey <$> getWord8 - <*> deserialize - <*> getWord32be - <*> deserialize - <*> getPadPrvKey - -instance Binary XPrvKey where - put = serialize - get = deserialize - -instance Serialize XPrvKey where - put = serialize - get = deserialize - -xPrvToJSON :: Network -> XPrvKey -> Value -xPrvToJSON net = A.String . xPrvExport net - -xPrvToEncoding :: Network -> XPrvKey -> Encoding -xPrvToEncoding net = text . xPrvExport net - --- | Decode an extended private key from a JSON string -xPrvFromJSON :: Network -> Value -> Parser XPrvKey -xPrvFromJSON net = - withText "xprv" $ \t -> - case xPrvImport net t of - Nothing -> fail "could not read xprv" - Just x -> return x - --- | Data type representing an extended BIP32 public key. -data XPubKey = XPubKey - { -- | depth in the tree - xPubDepth :: !Word8 - , -- | fingerprint of parent - xPubParent :: !Fingerprint - , -- | derivation index - xPubIndex :: !KeyIndex - , -- | chain code - xPubChain :: !ChainCode - , -- | public key of this node - xPubKey :: !PubKey - } - deriving (Generic, Eq, Show, Read, NFData, Hashable) - -instance Serial XPubKey where - serialize k = do - putWord8 $ xPubDepth k - serialize $ xPubParent k - putWord32be $ xPubIndex k - serialize $ xPubChain k - serialize $ wrapPubKey True (xPubKey k) - deserialize = - XPubKey <$> getWord8 - <*> deserialize - <*> getWord32be - <*> deserialize - <*> (pubKeyPoint <$> deserialize) - -instance Serialize XPubKey where - put = serialize - get = deserialize - -instance Binary XPubKey where - put = serialize - get = deserialize - --- | Decode an extended public key from a JSON string -xPubFromJSON :: Network -> Value -> Parser XPubKey -xPubFromJSON net = - withText "xpub" $ \t -> - case xPubImport net t of - Nothing -> fail "could not read xpub" - Just x -> return x - --- | Get JSON 'Value' from 'XPubKey'. -xPubToJSON :: Network -> XPubKey -> Value -xPubToJSON net = A.String . xPubExport net - -xPubToEncoding :: Network -> XPubKey -> Encoding -xPubToEncoding net = text . xPubExport net - -{- | Build a BIP32 compatible extended private key from a bytestring. This will - produce a root node (@depth=0@ and @parent=0@). --} -makeXPrvKey :: ByteString -> XPrvKey -makeXPrvKey bs = - XPrvKey 0 (Fingerprint 0) 0 c k - where - (p, c) = split512 $ hmac512 "Bitcoin seed" bs - k = fromMaybe err (secKey (runPutS (serialize p))) - err = throw $ DerivationException "Invalid seed" - -{- | Derive an extended public key from an extended private key. This function - will preserve the depth, parent, index and chaincode fields of the extended - private keys. --} -deriveXPubKey :: XPrvKey -> XPubKey -deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k) - -{- | Compute a private, soft child key derivation. A private soft derivation - will allow the equivalent extended public key to derive the public key for - this child. Given a parent key /m/ and a derivation index /i/, this function - will compute /m\/i/. - - Soft derivations allow for more flexibility such as read-only wallets. - However, care must be taken not the leak both the parent extended public key - and one of the extended child private keys as this would compromise the - extended parent private key. --} -prvSubKey :: - -- | extended parent private key - XPrvKey -> - -- | child derivation index - KeyIndex -> - -- | extended child private key - XPrvKey -prvSubKey xkey child - | child >= 0 && child < 0x80000000 = - XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k - | otherwise = error "Invalid child derivation index" - where - pK = xPubKey $ deriveXPubKey xkey - m = B.append (exportPubKey True pK) (runPutS (serialize child)) - (a, c) = split512 $ hmac512 (runPutS $ serialize $ xPrvChain xkey) m - k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a - err = throw $ DerivationException "Invalid prvSubKey derivation" - -{- | Compute a public, soft child key derivation. Given a parent key /M/ - and a derivation index /i/, this function will compute /M\/i/. --} -pubSubKey :: - -- | extended parent public key - XPubKey -> - -- | child derivation index - KeyIndex -> - -- | extended child public key - XPubKey -pubSubKey xKey child - | child >= 0 && child < 0x80000000 = - XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK - | otherwise = error "Invalid child derivation index" - where - m = B.append (exportPubKey True (xPubKey xKey)) (runPutS $ serialize child) - (a, c) = split512 $ hmac512 (runPutS $ serialize $ xPubChain xKey) m - pK = fromMaybe err $ tweakPubKey (xPubKey xKey) a - err = throw $ DerivationException "Invalid pubSubKey derivation" - -{- | Compute a hard child key derivation. Hard derivations can only be computed - for private keys. Hard derivations do not allow the parent public key to - derive the child public keys. However, they are safer as a breach of the - parent public key and child private keys does not lead to a breach of the - parent private key. Given a parent key /m/ and a derivation index /i/, this - function will compute /m\/i'/. --} -hardSubKey :: - -- | extended parent private key - XPrvKey -> - -- | child derivation index - KeyIndex -> - -- | extended child private key - XPrvKey -hardSubKey xkey child - | child >= 0 && child < 0x80000000 = - XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k - | otherwise = error "Invalid child derivation index" - where - i = setBit child 31 - m = B.append (bsPadPrvKey $ xPrvKey xkey) (runPutS $ serialize i) - (a, c) = split512 $ hmac512 (runPutS $ serialize $ xPrvChain xkey) m - k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a - err = throw $ DerivationException "Invalid hardSubKey derivation" - -{- | Returns true if the extended private key was derived through a hard - derivation. --} -xPrvIsHard :: XPrvKey -> Bool -xPrvIsHard k = testBit (xPrvIndex k) 31 - -{- | Returns true if the extended public key was derived through a hard - derivation. --} -xPubIsHard :: XPubKey -> Bool -xPubIsHard k = testBit (xPubIndex k) 31 - -{- | Returns the derivation index of this extended private key without the hard - bit set. --} -xPrvChild :: XPrvKey -> KeyIndex -xPrvChild k = clearBit (xPrvIndex k) 31 - -{- | Returns the derivation index of this extended public key without the hard - bit set. --} -xPubChild :: XPubKey -> KeyIndex -xPubChild k = clearBit (xPubIndex k) 31 - --- | Computes the key identifier of an extended private key. -xPrvID :: XPrvKey -> Hash160 -xPrvID = xPubID . deriveXPubKey - --- | Computes the key identifier of an extended public key. -xPubID :: XPubKey -> Hash160 -xPubID = ripemd160 . runPutS . serialize . sha256 . exportPubKey True . xPubKey - --- | Computes the key fingerprint of an extended private key. -xPrvFP :: XPrvKey -> Fingerprint -xPrvFP = - fromRight err . runGetS deserialize . B.take 4 . runPutS . serialize . xPrvID - where - err = error "Could not decode xPrvFP" - --- | Computes the key fingerprint of an extended public key. -xPubFP :: XPubKey -> Fingerprint -xPubFP = - fromRight err . runGetS deserialize . B.take 4 . runPutS . serialize . xPubID - where - err = error "Could not decode xPubFP" - --- | Compute a standard P2PKH address for an extended public key. -xPubAddr :: XPubKey -> Address -xPubAddr xkey = pubKeyAddr (wrapPubKey True (xPubKey xkey)) - --- | Compute a SegWit P2WPKH address for an extended public key. -xPubWitnessAddr :: XPubKey -> Address -xPubWitnessAddr xkey = pubKeyWitnessAddr (wrapPubKey True (xPubKey xkey)) - -{- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended - public key. --} -xPubCompatWitnessAddr :: XPubKey -> Address -xPubCompatWitnessAddr xkey = - pubKeyCompatWitnessAddr (wrapPubKey True (xPubKey xkey)) - --- | Exports an extended private key to the BIP32 key export format ('Base58'). -xPrvExport :: Network -> XPrvKey -> Base58 -xPrvExport net = encodeBase58Check . runPutS . putXPrvKey net - --- | Exports an extended public key to the BIP32 key export format ('Base58'). -xPubExport :: Network -> XPubKey -> Base58 -xPubExport net = encodeBase58Check . runPutS . putXPubKey net - -{- | Decodes a BIP32 encoded extended private key. This function will fail if - invalid base 58 characters are detected or if the checksum fails. --} -xPrvImport :: Network -> Base58 -> Maybe XPrvKey -xPrvImport net = eitherToMaybe . runGetS (getXPrvKey net) <=< decodeBase58Check - -{- | Decodes a BIP32 encoded extended public key. This function will fail if - invalid base 58 characters are detected or if the checksum fails. --} -xPubImport :: Network -> Base58 -> Maybe XPubKey -xPubImport net = eitherToMaybe . runGetS (getXPubKey net) <=< decodeBase58Check - --- | Export an extended private key to WIF (Wallet Import Format). -xPrvWif :: Network -> XPrvKey -> Base58 -xPrvWif net xkey = toWif net (wrapSecKey True (xPrvKey xkey)) - --- | Parse a binary extended private key. -getXPrvKey :: MonadGet m => Network -> m XPrvKey -getXPrvKey net = do - ver <- getWord32be - unless (ver == getExtSecretPrefix net) $ - fail - "Get: Invalid version for extended private key" - deserialize - --- | Serialize an extended private key. -putXPrvKey :: MonadPut m => Network -> XPrvKey -> m () -putXPrvKey net k = do - putWord32be $ getExtSecretPrefix net - serialize k - --- | Parse a binary extended public key. -getXPubKey :: MonadGet m => Network -> m XPubKey -getXPubKey net = do - ver <- getWord32be - unless (ver == getExtPubKeyPrefix net) $ - fail - "Get: Invalid version for extended public key" - deserialize - --- | Serialize an extended public key. -putXPubKey :: MonadPut m => Network -> XPubKey -> m () -putXPubKey net k = do - putWord32be $ getExtPubKeyPrefix net - serialize k - -{- Derivation helpers -} - -{- | Cyclic list of all private soft child key derivations of a parent key - starting from an offset index. --} -prvSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] -prvSubKeys k = map (\i -> (prvSubKey k i, i)) . cycleIndex - -{- | Cyclic list of all public soft child key derivations of a parent key - starting from an offset index. --} -pubSubKeys :: XPubKey -> KeyIndex -> [(XPubKey, KeyIndex)] -pubSubKeys k = map (\i -> (pubSubKey k i, i)) . cycleIndex - -{- | Cyclic list of all hard child key derivations of a parent key starting - from an offset index. --} -hardSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] -hardSubKeys k = map (\i -> (hardSubKey k i, i)) . cycleIndex - --- | Derive a standard address from an extended public key and an index. -deriveAddr :: XPubKey -> KeyIndex -> (Address, PubKey) -deriveAddr k i = - (xPubAddr key, xPubKey key) - where - key = pubSubKey k i - --- | Derive a SegWit P2WPKH address from an extended public key and an index. -deriveWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) -deriveWitnessAddr k i = - (xPubWitnessAddr key, xPubKey key) - where - key = pubSubKey k i - -{- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended - public key and an index. --} -deriveCompatWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) -deriveCompatWitnessAddr k i = - (xPubCompatWitnessAddr key, xPubKey key) - where - key = pubSubKey k i - -{- | Cyclic list of all addresses derived from a public key starting from an - offset index. --} -deriveAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] -deriveAddrs k = - map f . cycleIndex - where - f i = let (a, key) = deriveAddr k i in (a, key, i) - -{- | Cyclic list of all SegWit P2WPKH addresses derived from a public key - starting from an offset index. --} -deriveWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] -deriveWitnessAddrs k = - map f . cycleIndex - where - f i = let (a, key) = deriveWitnessAddr k i in (a, key, i) - -{- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses - derived from a public key starting from an offset index. --} -deriveCompatWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] -deriveCompatWitnessAddrs k = - map f . cycleIndex - where - f i = let (a, key) = deriveCompatWitnessAddr k i in (a, key, i) - -{- | Derive a multisig address from a list of public keys, the number of - required signatures /m/ and a derivation index. The derivation type is a - public, soft derivation. --} -deriveMSAddr :: [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript) -deriveMSAddr keys m i = (payToScriptAddress rdm, rdm) - where - rdm = sortMulSig $ PayMulSig k m - k = map (wrapPubKey True . xPubKey . flip pubSubKey i) keys - -{- | Cyclic list of all multisig addresses derived from a list of public keys, - a number of required signatures /m/ and starting from an offset index. The - derivation type is a public, soft derivation. --} -deriveMSAddrs :: - [XPubKey] -> - Int -> - KeyIndex -> - [(Address, RedeemScript, KeyIndex)] -deriveMSAddrs keys m = map f . cycleIndex - where - f i = - let (a, rdm) = deriveMSAddr keys m i - in (a, rdm, i) - --- | Helper function to go through derivation indices. -cycleIndex :: KeyIndex -> [KeyIndex] -cycleIndex i - | i == 0 = cycle [0 .. 0x7fffffff] - | i < 0x80000000 = cycle $ [i .. 0x7fffffff] ++ [0 .. (i - 1)] - | otherwise = error $ "cycleIndex: invalid index " ++ show i - -{- Derivation Paths -} - -{- | Phantom type signaling a hardened derivation path that can only be computed - from private extended key. --} -data HardDeriv deriving (Generic, NFData) - --- | Phantom type signaling no knowledge about derivation path: can be hardened or not. -data AnyDeriv deriving (Generic, NFData) - -{- | Phantom type signaling derivation path including only non-hardened paths - that can be computed from an extended public key. --} -data SoftDeriv deriving (Generic, NFData) - --- | Hardened derivation path. Can be computed from extended private key only. -type HardPath = DerivPathI HardDeriv - --- | Any derivation path. -type DerivPath = DerivPathI AnyDeriv - --- | Non-hardened derivation path can be computed from extended public key. -type SoftPath = DerivPathI SoftDeriv - --- | Helper class to perform validations on a hardened derivation path. -class HardOrAny a - -instance HardOrAny HardDeriv -instance HardOrAny AnyDeriv - --- | Helper class to perform validations on a non-hardened derivation path. -class AnyOrSoft a - -instance AnyOrSoft AnyDeriv -instance AnyOrSoft SoftDeriv - -{- | Data type representing a derivation path. Two constructors are provided - for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be - expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type - classes are used to constrain the valid values for the phantom type /t/. If - you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'. - Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv' - if you only have soft derivations. - - Using this type is as easy as writing the required derivation like in these - example: - - > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath - > Deriv :| 0 :| 1 :| 2 :: HardPath - > Deriv :| 0 :/ 1 :/ 2 :: DerivPath --} -data DerivPathI t where - (:|) :: HardOrAny t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t - (:/) :: AnyOrSoft t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t - Deriv :: DerivPathI t - -instance NFData (DerivPathI t) where - rnf (a :| b) = rnf a `seq` rnf b - rnf (a :/ b) = rnf a `seq` rnf b - rnf Deriv = () - -instance Eq (DerivPathI t) where - (nextA :| iA) == (nextB :| iB) = iA == iB && nextA == nextB - (nextA :/ iA) == (nextB :/ iB) = iA == iB && nextA == nextB - Deriv == Deriv = True - _ == _ = False - -instance Ord (DerivPathI t) where - -- Same hardness on each side - (nextA :| iA) `compare` (nextB :| iB) = - if nextA == nextB then iA `compare` iB else nextA `compare` nextB - (nextA :/ iA) `compare` (nextB :/ iB) = - if nextA == nextB then iA `compare` iB else nextA `compare` nextB - -- Different hardness: hard paths are LT soft paths - (nextA :/ _iA) `compare` (nextB :| _iB) = - if nextA == nextB then LT else nextA `compare` nextB - (nextA :| _iA) `compare` (nextB :/ _iB) = - if nextA == nextB then GT else nextA `compare` nextB - Deriv `compare` Deriv = EQ - Deriv `compare` _ = LT - _ `compare` Deriv = GT - -instance Serial DerivPath where - deserialize = listToPath <$> getList getWord32be - serialize = putList putWord32be . pathToList - -instance Serialize DerivPath where - put = serialize - get = deserialize - -instance Binary DerivPath where - put = serialize - get = deserialize - -instance Serial HardPath where - deserialize = - maybe - (fail "Could not decode hard path") - return - . toHard - . listToPath - =<< getList getWord32be - serialize = putList putWord32be . pathToList - -instance Serialize HardPath where - put = serialize - get = deserialize - -instance Binary HardPath where - put = serialize - get = deserialize - -instance Serial SoftPath where - deserialize = - maybe - (fail "Could not decode soft path") - return - . toSoft - . listToPath - =<< getList getWord32be - serialize = putList putWord32be . pathToList - -instance Serialize SoftPath where - put = serialize - get = deserialize - -instance Binary SoftPath where - put = serialize - get = deserialize - --- | Get a list of derivation indices from a derivation path. -pathToList :: DerivPathI t -> [KeyIndex] -pathToList = - reverse . go - where - go (next :| i) = setBit i 31 : go next - go (next :/ i) = i : go next - go _ = [] - --- | Convert a list of derivation indices to a derivation path. -listToPath :: [KeyIndex] -> DerivPath -listToPath = - go . reverse - where - go (i : is) - | testBit i 31 = go is :| clearBit i 31 - | otherwise = go is :/ i - go [] = Deriv - --- | Convert a derivation path to a human-readable string. -pathToStr :: DerivPathI t -> String -pathToStr p = - case p of - next :| i -> concat [pathToStr next, "/", show i, "'"] - next :/ i -> concat [pathToStr next, "/", show i] - Deriv -> "" - -{- | Turn a derivation path into a hard derivation path. Will fail if the path - contains soft derivations. --} -toHard :: DerivPathI t -> Maybe HardPath -toHard p = case p of - next :| i -> (:| i) <$> toHard next - Deriv -> Just Deriv - _ -> Nothing - -{- | Turn a derivation path into a soft derivation path. Will fail if the path - has hard derivations. --} -toSoft :: DerivPathI t -> Maybe SoftPath -toSoft p = case p of - next :/ i -> (:/ i) <$> toSoft next - Deriv -> Just Deriv - _ -> Nothing - --- | Make a derivation path generic. -toGeneric :: DerivPathI t -> DerivPath -toGeneric p = case p of - next :/ i -> toGeneric next :/ i - next :| i -> toGeneric next :| i - Deriv -> Deriv - -{- | Append two derivation paths together. The result will be a mixed - derivation path. --} -(++/) :: DerivPathI t1 -> DerivPathI t2 -> DerivPath -(++/) p1 p2 = - go id (toGeneric p2) $ toGeneric p1 - where - go f p = case p of - next :/ i -> go (f . (:/ i)) $ toGeneric next - next :| i -> go (f . (:| i)) $ toGeneric next - _ -> f - --- | Derive a private key from a derivation path -derivePath :: DerivPathI t -> XPrvKey -> XPrvKey -derivePath = go id - where - -- Build the full derivation function starting from the end - go f p = case p of - next :| i -> go (f . flip hardSubKey i) next - next :/ i -> go (f . flip prvSubKey i) next - _ -> f - --- | Derive a public key from a soft derivation path -derivePubPath :: SoftPath -> XPubKey -> XPubKey -derivePubPath = go id - where - -- Build the full derivation function starting from the end - go f p = case p of - next :/ i -> go (f . flip pubSubKey i) next - _ -> f - -instance Show DerivPath where - showsPrec d p = - showParen (d > 10) $ - showString "DerivPath " . shows (pathToStr p) - -instance Read DerivPath where - readPrec = parens $ do - R.Ident "DerivPath" <- lexP - R.String str <- lexP - maybe pfail return $ getParsedPath <$> parsePath str - -instance Show HardPath where - showsPrec d p = - showParen (d > 10) $ - showString "HardPath " . shows (pathToStr p) - -instance Read HardPath where - readPrec = parens $ do - R.Ident "HardPath" <- lexP - R.String str <- lexP - maybe pfail return $ parseHard str - -instance Show SoftPath where - showsPrec d p = - showParen (d > 10) $ - showString "SoftPath " . shows (pathToStr p) - -instance Read SoftPath where - readPrec = parens $ do - R.Ident "SoftPath" <- lexP - R.String str <- lexP - maybe pfail return $ parseSoft str - -instance IsString ParsedPath where - fromString = - fromMaybe e . parsePath - where - e = error "Could not parse derivation path" - -instance IsString DerivPath where - fromString = - getParsedPath . fromMaybe e . parsePath - where - e = error "Could not parse derivation path" - -instance IsString HardPath where - fromString = - fromMaybe e . parseHard - where - e = error "Could not parse hard derivation path" - -instance IsString SoftPath where - fromString = - fromMaybe e . parseSoft - where - e = error "Could not parse soft derivation path" - -instance FromJSON ParsedPath where - parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of - Just p -> return p - _ -> mzero - -instance FromJSON DerivPath where - parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of - Just p -> return $ getParsedPath p - _ -> mzero - -instance FromJSON HardPath where - parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of - Just p -> return p - _ -> mzero - -instance FromJSON SoftPath where - parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of - Just p -> return p - _ -> mzero - -instance ToJSON (DerivPathI t) where - toJSON = A.String . cs . pathToStr - toEncoding = text . cs . pathToStr - -instance ToJSON ParsedPath where - toJSON (ParsedPrv p) = A.String . cs . ("m" ++) . pathToStr $ p - toJSON (ParsedPub p) = A.String . cs . ("M" ++) . pathToStr $ p - toJSON (ParsedEmpty p) = A.String . cs . ("" ++) . pathToStr $ p - toEncoding (ParsedPrv p) = text . cs . ("m" ++) . pathToStr $ p - toEncoding (ParsedPub p) = text . cs . ("M" ++) . pathToStr $ p - toEncoding (ParsedEmpty p) = text . cs . ("" ++) . pathToStr $ p - -{- Parsing derivation paths of the form m/1/2'/3 or M/1/2'/3 -} - -{- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or - /M\/1\/2'\/3/. --} -data ParsedPath - = ParsedPrv {getParsedPath :: !DerivPath} - | ParsedPub {getParsedPath :: !DerivPath} - | ParsedEmpty {getParsedPath :: !DerivPath} - deriving (Eq, Generic, NFData) - -instance Show ParsedPath where - showsPrec d p = showParen (d > 10) $ showString "ParsedPath " . shows f - where - f = - case p of - ParsedPrv d' -> "m" <> pathToStr d' - ParsedPub d' -> "M" <> pathToStr d' - ParsedEmpty d' -> pathToStr d' - -instance Read ParsedPath where - readPrec = parens $ do - R.Ident "ParsedPath" <- lexP - R.String str <- lexP - maybe pfail return $ parsePath str - -{- | Parse derivation path string for extended key. - Forms: /m\/0'\/2/, /M\/2\/3\/4/. --} -parsePath :: String -> Maybe ParsedPath -parsePath str = do - res <- concatBip32Segments <$> mapM parseBip32PathIndex xs - case x of - "m" -> Just $ ParsedPrv res - "M" -> Just $ ParsedPub res - "" -> Just $ ParsedEmpty res - _ -> Nothing - where - (x : xs) = splitOn "/" str - --- | Concatenate derivation path indices into a derivation path. -concatBip32Segments :: [Bip32PathIndex] -> DerivPath -concatBip32Segments = foldl' appendBip32Segment Deriv - --- | Append an extra derivation path index element into an existing path. -appendBip32Segment :: DerivPath -> Bip32PathIndex -> DerivPath -appendBip32Segment d (Bip32SoftIndex i) = d :/ i -appendBip32Segment d (Bip32HardIndex i) = d :| i - --- | Parse a BIP32 derivation path index element from a string. -parseBip32PathIndex :: String -> Maybe Bip32PathIndex -parseBip32PathIndex segment = case reads segment of - [(i, "")] -> guard (is31Bit i) >> return (Bip32SoftIndex i) - [(i, "'")] -> guard (is31Bit i) >> return (Bip32HardIndex i) - _ -> Nothing - --- | Type for BIP32 path index element. -data Bip32PathIndex - = Bip32HardIndex KeyIndex - | Bip32SoftIndex KeyIndex - deriving (Eq, Generic, NFData) - -instance Show Bip32PathIndex where - showsPrec d (Bip32HardIndex i) = - showParen (d > 10) $ - showString "Bip32HardIndex " . shows i - showsPrec d (Bip32SoftIndex i) = - showParen (d > 10) $ - showString "Bip32SoftIndex " . shows i - -instance Read Bip32PathIndex where - readPrec = h <|> s - where - h = - parens $ do - R.Ident "Bip32HardIndex" <- lexP - R.Number n <- lexP - maybe pfail return $ - Bip32HardIndex . fromIntegral <$> numberToInteger n - s = - parens $ do - R.Ident "Bip32SoftIndex" <- lexP - R.Number n <- lexP - maybe pfail return $ - Bip32SoftIndex . fromIntegral <$> numberToInteger n - --- | Test whether the number could be a valid BIP32 derivation index. -is31Bit :: (Integral a) => a -> Bool -is31Bit i = i >= 0 && i < 0x80000000 - --- | Helper function to parse a hard path. -parseHard :: String -> Maybe HardPath -parseHard = toHard . getParsedPath <=< parsePath - --- | Helper function to parse a soft path. -parseSoft :: String -> Maybe SoftPath -parseSoft = toSoft . getParsedPath <=< parsePath - --- | Data type representing a private or public key with its respective network. -data XKey - = XPrv - { getXKeyPrv :: !XPrvKey - , getXKeyNet :: !Network - } - | XPub - { getXKeyPub :: !XPubKey - , getXKeyNet :: !Network - } - deriving (Eq, Show, Generic, NFData) - -{- | Apply a parsed path to an extended key to derive the new key defined in the - path. If the path starts with /m/, a private key will be returned and if the - path starts with /M/, a public key will be returned. Private derivations on a - public key, and public derivations with a hard segment, return an error - value. --} -applyPath :: ParsedPath -> XKey -> Either String XKey -applyPath path key = - case (path, key) of - (ParsedPrv _, XPrv k n) -> return $ XPrv (derivPrvF k) n - (ParsedPrv _, XPub{}) -> Left "applyPath: Invalid public key" - (ParsedPub _, XPrv k n) -> return $ XPub (deriveXPubKey (derivPrvF k)) n - (ParsedPub _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n - -- For empty parsed paths, we take a hint from the provided key - (ParsedEmpty _, XPrv k n) -> return $ XPrv (derivPrvF k) n - (ParsedEmpty _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n - where - derivPrvF = goPrv id $ getParsedPath path - derivPubFE = goPubE id $ getParsedPath path - -- Build the full private derivation function starting from the end - goPrv f p = - case p of - next :| i -> goPrv (f . flip hardSubKey i) next - next :/ i -> goPrv (f . flip prvSubKey i) next - Deriv -> f - -- Build the full public derivation function starting from the end - goPubE f p = - case p of - next :/ i -> goPubE (f . flip pubSubKey i) next - Deriv -> Right f - _ -> Left "applyPath: Invalid hard derivation" - -{- Helpers for derivation paths and addresses -} - --- | Derive an address from a given parent path. -derivePathAddr :: XPubKey -> SoftPath -> KeyIndex -> (Address, PubKey) -derivePathAddr key path = deriveAddr (derivePubPath path key) - -{- | Cyclic list of all addresses derived from a given parent path and starting - from the given offset index. --} -derivePathAddrs :: - XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKey, KeyIndex)] -derivePathAddrs key path = deriveAddrs (derivePubPath path key) - -{- | Derive a multisig address from a given parent path. The number of required - signatures (m in m of n) is also needed. --} -derivePathMSAddr :: - [XPubKey] -> - SoftPath -> - Int -> - KeyIndex -> - (Address, RedeemScript) -derivePathMSAddr keys path = - deriveMSAddr $ map (derivePubPath path) keys - -{- | Cyclic list of all multisig addresses derived from a given parent path and - starting from the given offset index. The number of required signatures - (m in m of n) is also needed. --} -derivePathMSAddrs :: - [XPubKey] -> - SoftPath -> - Int -> - KeyIndex -> - [(Address, RedeemScript, KeyIndex)] -derivePathMSAddrs keys path = - deriveMSAddrs $ map (derivePubPath path) keys - -{- Utilities for extended keys -} - --- | De-serialize HDW-specific private key. -getPadPrvKey :: MonadGet m => m SecKey -getPadPrvKey = do - pad <- getWord8 - unless (pad == 0x00) $ fail "Private key must be padded with 0x00" - bs <- getByteString 32 - case runGetS S.get bs of - Left e -> fail e - Right x -> return x - --- | Serialize HDW-specific private key. -putPadPrvKey :: MonadPut m => SecKey -> m () -putPadPrvKey p = putWord8 0x00 >> putByteString (runPutS (S.put p)) - -bsPadPrvKey :: SecKey -> ByteString -bsPadPrvKey = runPutS . putPadPrvKey diff --git a/src/Haskoin/Keys/Extended/Internal.hs b/src/Haskoin/Keys/Extended/Internal.hs deleted file mode 100644 index 57d539cb..00000000 --- a/src/Haskoin/Keys/Extended/Internal.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Haskoin.Keys.Extended.Internal ( - Fingerprint (..), - fingerprintToText, - textToFingerprint, -) where - -import Control.DeepSeq (NFData) -import Control.Monad ((>=>)) -import Data.Aeson ( - FromJSON, - ToJSON, - parseJSON, - toJSON, - withText, - ) -import Data.Binary (Binary (..)) -import Data.Bytes.Get (getWord32be) -import Data.Bytes.Put (putWord32be) -import Data.Bytes.Serial (Serial (..)) -import Data.Either (fromRight) -import Data.Hashable (Hashable) -import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) -import qualified Data.Serialize as S -import Data.String (IsString (..)) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Typeable (Typeable) -import Data.Word (Word32) -import GHC.Generics (Generic) -import Haskoin.Util (decodeHex, encodeHex) -import Text.Read (readEither, readPrec) - --- | Fingerprint of parent -newtype Fingerprint = Fingerprint {unFingerprint :: Word32} - deriving (Eq, Ord, Hashable, Typeable, Generic, NFData) - -fingerprintToText :: Fingerprint -> Text -fingerprintToText = encodeHex . S.encode - -textToFingerprint :: Text -> Either String Fingerprint -textToFingerprint = maybe (Left "Fingerprint: invalid hex") Right . decodeHex >=> S.decode - -instance Show Fingerprint where - show = show . Text.unpack . encodeHex . S.encode - -instance Read Fingerprint where - readPrec = - readPrec - >>= maybe (fail "Fingerprint: invalid hex") pure . decodeHex - >>= either (fail . ("Fingerprint: " <>)) pure . S.decode - -instance IsString Fingerprint where - fromString = - fromRight decodeError - . S.decode - . fromMaybe hexError - . decodeHex - . Text.pack - where - decodeError = error "Fingerprint literal: Unable to decode" - hexError = error "Fingerprint literal: Invalid hex" - -instance Serial Fingerprint where - serialize = putWord32be . unFingerprint - deserialize = Fingerprint <$> getWord32be - -instance Binary Fingerprint where - put = serialize - get = deserialize - -instance Serialize Fingerprint where - put = serialize - get = deserialize - -instance FromJSON Fingerprint where - parseJSON = withText "Fingerprint" $ either fail pure . textToFingerprint - -instance ToJSON Fingerprint where - toJSON = toJSON . fingerprintToText diff --git a/src/Haskoin/Keys/Mnemonic.hs b/src/Haskoin/Keys/Mnemonic.hs deleted file mode 100644 index 34ee3929..00000000 --- a/src/Haskoin/Keys/Mnemonic.hs +++ /dev/null @@ -1,2233 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : Haskoin.Keys.Mnemonic -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Mnemonic keys (BIP-39). Only English dictionary. --} -module Haskoin.Keys.Mnemonic ( - -- * Mnemonic Sentences - Entropy, - Mnemonic, - Passphrase, - Seed, - toMnemonic, - fromMnemonic, - mnemonicToSeed, -) where - -import Control.Monad (when) -import Crypto.Hash (SHA256 (..), hashWith) -import Crypto.KDF.PBKDF2 (Parameters (..), fastPBKDF2_SHA512) -import Data.Bits (shiftL, shiftR) -import qualified Data.ByteArray as BA -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.List -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Vector (Vector, (!)) -import qualified Data.Vector as V -import Haskoin.Util - -{- | Random data used to create a mnemonic sentence. Use a good entropy source. - You will get your coins stolen if you don't. You have been warned. --} -type Entropy = ByteString - --- | Human-readable mnemonic sentence. -type Mnemonic = Text - --- | Optional passphrase for mnemnoic sentence. -type Passphrase = Text - --- | Seed for a private key from a mnemonic sentence. -type Seed = ByteString - --- | Mnemonic key checksum. -type Checksum = ByteString - --- | Paremeters for PBKDF2 function. -pbkdfParams :: Parameters -pbkdfParams = Parameters{iterCounts = 2048, outputLength = 64} - -{- | Provide intial 'Entropy' as a 'ByteString' of length multiple of 4 bytes. - Output a 'Mnemonic' sentence. --} -toMnemonic :: Entropy -> Either String Mnemonic -toMnemonic ent = do - when (BS.null ent) $ - Left "toMnemonic: entropy can not be empty" - when (remainder /= 0) $ - Left "toMnemonic: entropy must be multiples of 4 bytes" - when (cs_len > 16) $ - Left "toMnemonic: maximum entropy is 64 bytes (512 bits)" - return ms - where - (cs_len, remainder) = BS.length ent `quotRem` 4 - c = calcCS cs_len ent - indices = bsToIndices $ ent `BS.append` c - ms = T.unwords $ map (wl !) indices - -{- | Revert 'toMnemonic'. Do not use this to generate a 'Seed'. Instead use - 'mnemonicToSeed'. This outputs the original 'Entropy' used to generate a - 'Mnemonic' sentence. --} -fromMnemonic :: Mnemonic -> Either String Entropy -fromMnemonic ms = do - when (T.null ms) $ - Left "fromMnemonic: empty mnemonic" - when (word_count > 48) $ - Left $ "fromMnemonic: too many words: " ++ show word_count - when (word_count `mod` 3 /= 0) $ - Left $ "fromMnemonic: wrong number of words:" ++ show word_count - ms_bs <- indicesToBS =<< getIndices ms_words - let (ms_ent, ms_cs) = BS.splitAt (ent_len * 4) ms_bs - ms_cs_num = numCS cs_len ms_cs - ent_cs_num = numCS cs_len $ calcCS cs_len ms_ent - when (ent_cs_num /= ms_cs_num) $ - Left $ "fromMnemonic: checksum failed: " ++ sh ent_cs_num ms_cs_num - return ms_ent - where - ms_words = T.words ms - word_count = length ms_words - (ent_len, cs_len) = (word_count * 11) `quotRem` 32 - sh cs_a cs_b = show cs_a ++ " /= " ++ show cs_b - --- | Compute 'Checksum'. -calcCS :: Int -> Entropy -> Checksum -calcCS len = getBits len . BA.convert . hashWith SHA256 - -numCS :: Int -> Entropy -> Integer -numCS len = - shiftCS . bsToInteger - where - shiftCS = case 8 - len `mod` 8 of - 8 -> id - x -> flip shiftR x - -{- | Turn an arbitrary sequence of characters into a 512-bit 'Seed'. Use - 'mnemonicToSeed' to get a seed from a 'Mnemonic' sentence. Warning: Does not - perform NFKD normalization. --} -anyToSeed :: Passphrase -> Mnemonic -> Seed -anyToSeed pf ms = - fastPBKDF2_SHA512 - pbkdfParams - (E.encodeUtf8 ms) - ("mnemonic" `mappend` E.encodeUtf8 pf) - -{- | Get a 512-bit 'Seed' from a 'Mnemonic' sentence. Will validate checksum. - 'Passphrase' can be used to protect the 'Mnemonic'. Use an empty string as - 'Passphrase' if none is required. --} -mnemonicToSeed :: Passphrase -> Mnemonic -> Either String Seed -mnemonicToSeed pf ms = do - ent <- fromMnemonic ms - mnm <- toMnemonic ent - return $ anyToSeed pf mnm - --- | Get indices of words in word list. -getIndices :: [Text] -> Either String [Int] -getIndices ws - | null n = return $ catMaybes i - | otherwise = Left $ "getIndices: words not found: " ++ cs w - where - i = map (`M.lookup` wl') ws - n = elemIndices Nothing i - w = T.unwords $ map (ws !!) n - --- | Turn a list of 11-bit numbers into a 'ByteString' -indicesToBS :: [Int] -> Either String ByteString -indicesToBS is = do - when lrg $ Left "indicesToBS: index larger or equal than 2048" - return . pad . integerToBS $ foldl' f 0 is `shiftL` shift_width - where - lrg = isJust $ find (>= 2048) is - (q, r) = (length is * 11) `quotRem` 8 - shift_width = - if r == 0 - then 0 - else 8 - r - bl = - if r == 0 - then q - else q + 1 -- length of resulting ByteString - pad bs = BS.append (BS.replicate (bl - BS.length bs) 0x00) bs - f acc x = (acc `shiftL` 11) + fromIntegral x - --- | Turn a 'ByteString' into a list of 11-bit numbers. -bsToIndices :: ByteString -> [Int] -bsToIndices bs = - reverse . go q $ bsToInteger bs `shiftR` r - where - (q, r) = (BS.length bs * 8) `quotRem` 11 - go 0 _ = [] - go n i = fromIntegral (i `mod` 2048) : go (n - 1) (i `shiftR` 11) - -wl' :: M.Map Text Int -wl' = V.ifoldr' (flip M.insert) M.empty wl - --- | Standard English dictionary from BIP-39 specification. -wl :: Vector Text -wl = - V.fromListN - 2048 - [ "abandon" - , "ability" - , "able" - , "about" - , "above" - , "absent" - , "absorb" - , "abstract" - , "absurd" - , "abuse" - , "access" - , "accident" - , "account" - , "accuse" - , "achieve" - , "acid" - , "acoustic" - , "acquire" - , "across" - , "act" - , "action" - , "actor" - , "actress" - , "actual" - , "adapt" - , "add" - , "addict" - , "address" - , "adjust" - , "admit" - , "adult" - , "advance" - , "advice" - , "aerobic" - , "affair" - , "afford" - , "afraid" - , "again" - , "age" - , "agent" - , "agree" - , "ahead" - , "aim" - , "air" - , "airport" - , "aisle" - , "alarm" - , "album" - , "alcohol" - , "alert" - , "alien" - , "all" - , "alley" - , "allow" - , "almost" - , "alone" - , "alpha" - , "already" - , "also" - , "alter" - , "always" - , "amateur" - , "amazing" - , "among" - , "amount" - , "amused" - , "analyst" - , "anchor" - , "ancient" - , "anger" - , "angle" - , "angry" - , "animal" - , "ankle" - , "announce" - , "annual" - , "another" - , "answer" - , "antenna" - , "antique" - , "anxiety" - , "any" - , "apart" - , "apology" - , "appear" - , "apple" - , "approve" - , "april" - , "arch" - , "arctic" - , "area" - , "arena" - , "argue" - , "arm" - , "armed" - , "armor" - , "army" - , "around" - , "arrange" - , "arrest" - , "arrive" - , "arrow" - , "art" - , "artefact" - , "artist" - , "artwork" - , "ask" - , "aspect" - , "assault" - , "asset" - , "assist" - , "assume" - , "asthma" - , "athlete" - , "atom" - , "attack" - , "attend" - , "attitude" - , "attract" - , "auction" - , "audit" - , "august" - , "aunt" - , "author" - , "auto" - , "autumn" - , "average" - , "avocado" - , "avoid" - , "awake" - , "aware" - , "away" - , "awesome" - , "awful" - , "awkward" - , "axis" - , "baby" - , "bachelor" - , "bacon" - , "badge" - , "bag" - , "balance" - , "balcony" - , "ball" - , "bamboo" - , "banana" - , "banner" - , "bar" - , "barely" - , "bargain" - , "barrel" - , "base" - , "basic" - , "basket" - , "battle" - , "beach" - , "bean" - , "beauty" - , "because" - , "become" - , "beef" - , "before" - , "begin" - , "behave" - , "behind" - , "believe" - , "below" - , "belt" - , "bench" - , "benefit" - , "best" - , "betray" - , "better" - , "between" - , "beyond" - , "bicycle" - , "bid" - , "bike" - , "bind" - , "biology" - , "bird" - , "birth" - , "bitter" - , "black" - , "blade" - , "blame" - , "blanket" - , "blast" - , "bleak" - , "bless" - , "blind" - , "blood" - , "blossom" - , "blouse" - , "blue" - , "blur" - , "blush" - , "board" - , "boat" - , "body" - , "boil" - , "bomb" - , "bone" - , "bonus" - , "book" - , "boost" - , "border" - , "boring" - , "borrow" - , "boss" - , "bottom" - , "bounce" - , "box" - , "boy" - , "bracket" - , "brain" - , "brand" - , "brass" - , "brave" - , "bread" - , "breeze" - , "brick" - , "bridge" - , "brief" - , "bright" - , "bring" - , "brisk" - , "broccoli" - , "broken" - , "bronze" - , "broom" - , "brother" - , "brown" - , "brush" - , "bubble" - , "buddy" - , "budget" - , "buffalo" - , "build" - , "bulb" - , "bulk" - , "bullet" - , "bundle" - , "bunker" - , "burden" - , "burger" - , "burst" - , "bus" - , "business" - , "busy" - , "butter" - , "buyer" - , "buzz" - , "cabbage" - , "cabin" - , "cable" - , "cactus" - , "cage" - , "cake" - , "call" - , "calm" - , "camera" - , "camp" - , "can" - , "canal" - , "cancel" - , "candy" - , "cannon" - , "canoe" - , "canvas" - , "canyon" - , "capable" - , "capital" - , "captain" - , "car" - , "carbon" - , "card" - , "cargo" - , "carpet" - , "carry" - , "cart" - , "case" - , "cash" - , "casino" - , "castle" - , "casual" - , "cat" - , "catalog" - , "catch" - , "category" - , "cattle" - , "caught" - , "cause" - , "caution" - , "cave" - , "ceiling" - , "celery" - , "cement" - , "census" - , "century" - , "cereal" - , "certain" - , "chair" - , "chalk" - , "champion" - , "change" - , "chaos" - , "chapter" - , "charge" - , "chase" - , "chat" - , "cheap" - , "check" - , "cheese" - , "chef" - , "cherry" - , "chest" - , "chicken" - , "chief" - , "child" - , "chimney" - , "choice" - , "choose" - , "chronic" - , "chuckle" - , "chunk" - , "churn" - , "cigar" - , "cinnamon" - , "circle" - , "citizen" - , "city" - , "civil" - , "claim" - , "clap" - , "clarify" - , "claw" - , "clay" - , "clean" - , "clerk" - , "clever" - , "click" - , "client" - , "cliff" - , "climb" - , "clinic" - , "clip" - , "clock" - , "clog" - , "close" - , "cloth" - , "cloud" - , "clown" - , "club" - , "clump" - , "cluster" - , "clutch" - , "coach" - , "coast" - , "coconut" - , "code" - , "coffee" - , "coil" - , "coin" - , "collect" - , "color" - , "column" - , "combine" - , "come" - , "comfort" - , "comic" - , "common" - , "company" - , "concert" - , "conduct" - , "confirm" - , "congress" - , "connect" - , "consider" - , "control" - , "convince" - , "cook" - , "cool" - , "copper" - , "copy" - , "coral" - , "core" - , "corn" - , "correct" - , "cost" - , "cotton" - , "couch" - , "country" - , "couple" - , "course" - , "cousin" - , "cover" - , "coyote" - , "crack" - , "cradle" - , "craft" - , "cram" - , "crane" - , "crash" - , "crater" - , "crawl" - , "crazy" - , "cream" - , "credit" - , "creek" - , "crew" - , "cricket" - , "crime" - , "crisp" - , "critic" - , "crop" - , "cross" - , "crouch" - , "crowd" - , "crucial" - , "cruel" - , "cruise" - , "crumble" - , "crunch" - , "crush" - , "cry" - , "crystal" - , "cube" - , "culture" - , "cup" - , "cupboard" - , "curious" - , "current" - , "curtain" - , "curve" - , "cushion" - , "custom" - , "cute" - , "cycle" - , "dad" - , "damage" - , "damp" - , "dance" - , "danger" - , "daring" - , "dash" - , "daughter" - , "dawn" - , "day" - , "deal" - , "debate" - , "debris" - , "decade" - , "december" - , "decide" - , "decline" - , "decorate" - , "decrease" - , "deer" - , "defense" - , "define" - , "defy" - , "degree" - , "delay" - , "deliver" - , "demand" - , "demise" - , "denial" - , "dentist" - , "deny" - , "depart" - , "depend" - , "deposit" - , "depth" - , "deputy" - , "derive" - , "describe" - , "desert" - , "design" - , "desk" - , "despair" - , "destroy" - , "detail" - , "detect" - , "develop" - , "device" - , "devote" - , "diagram" - , "dial" - , "diamond" - , "diary" - , "dice" - , "diesel" - , "diet" - , "differ" - , "digital" - , "dignity" - , "dilemma" - , "dinner" - , "dinosaur" - , "direct" - , "dirt" - , "disagree" - , "discover" - , "disease" - , "dish" - , "dismiss" - , "disorder" - , "display" - , "distance" - , "divert" - , "divide" - , "divorce" - , "dizzy" - , "doctor" - , "document" - , "dog" - , "doll" - , "dolphin" - , "domain" - , "donate" - , "donkey" - , "donor" - , "door" - , "dose" - , "double" - , "dove" - , "draft" - , "dragon" - , "drama" - , "drastic" - , "draw" - , "dream" - , "dress" - , "drift" - , "drill" - , "drink" - , "drip" - , "drive" - , "drop" - , "drum" - , "dry" - , "duck" - , "dumb" - , "dune" - , "during" - , "dust" - , "dutch" - , "duty" - , "dwarf" - , "dynamic" - , "eager" - , "eagle" - , "early" - , "earn" - , "earth" - , "easily" - , "east" - , "easy" - , "echo" - , "ecology" - , "economy" - , "edge" - , "edit" - , "educate" - , "effort" - , "egg" - , "eight" - , "either" - , "elbow" - , "elder" - , "electric" - , "elegant" - , "element" - , "elephant" - , "elevator" - , "elite" - , "else" - , "embark" - , "embody" - , "embrace" - , "emerge" - , "emotion" - , "employ" - , "empower" - , "empty" - , "enable" - , "enact" - , "end" - , "endless" - , "endorse" - , "enemy" - , "energy" - , "enforce" - , "engage" - , "engine" - , "enhance" - , "enjoy" - , "enlist" - , "enough" - , "enrich" - , "enroll" - , "ensure" - , "enter" - , "entire" - , "entry" - , "envelope" - , "episode" - , "equal" - , "equip" - , "era" - , "erase" - , "erode" - , "erosion" - , "error" - , "erupt" - , "escape" - , "essay" - , "essence" - , "estate" - , "eternal" - , "ethics" - , "evidence" - , "evil" - , "evoke" - , "evolve" - , "exact" - , "example" - , "excess" - , "exchange" - , "excite" - , "exclude" - , "excuse" - , "execute" - , "exercise" - , "exhaust" - , "exhibit" - , "exile" - , "exist" - , "exit" - , "exotic" - , "expand" - , "expect" - , "expire" - , "explain" - , "expose" - , "express" - , "extend" - , "extra" - , "eye" - , "eyebrow" - , "fabric" - , "face" - , "faculty" - , "fade" - , "faint" - , "faith" - , "fall" - , "false" - , "fame" - , "family" - , "famous" - , "fan" - , "fancy" - , "fantasy" - , "farm" - , "fashion" - , "fat" - , "fatal" - , "father" - , "fatigue" - , "fault" - , "favorite" - , "feature" - , "february" - , "federal" - , "fee" - , "feed" - , "feel" - , "female" - , "fence" - , "festival" - , "fetch" - , "fever" - , "few" - , "fiber" - , "fiction" - , "field" - , "figure" - , "file" - , "film" - , "filter" - , "final" - , "find" - , "fine" - , "finger" - , "finish" - , "fire" - , "firm" - , "first" - , "fiscal" - , "fish" - , "fit" - , "fitness" - , "fix" - , "flag" - , "flame" - , "flash" - , "flat" - , "flavor" - , "flee" - , "flight" - , "flip" - , "float" - , "flock" - , "floor" - , "flower" - , "fluid" - , "flush" - , "fly" - , "foam" - , "focus" - , "fog" - , "foil" - , "fold" - , "follow" - , "food" - , "foot" - , "force" - , "forest" - , "forget" - , "fork" - , "fortune" - , "forum" - , "forward" - , "fossil" - , "foster" - , "found" - , "fox" - , "fragile" - , "frame" - , "frequent" - , "fresh" - , "friend" - , "fringe" - , "frog" - , "front" - , "frost" - , "frown" - , "frozen" - , "fruit" - , "fuel" - , "fun" - , "funny" - , "furnace" - , "fury" - , "future" - , "gadget" - , "gain" - , "galaxy" - , "gallery" - , "game" - , "gap" - , "garage" - , "garbage" - , "garden" - , "garlic" - , "garment" - , "gas" - , "gasp" - , "gate" - , "gather" - , "gauge" - , "gaze" - , "general" - , "genius" - , "genre" - , "gentle" - , "genuine" - , "gesture" - , "ghost" - , "giant" - , "gift" - , "giggle" - , "ginger" - , "giraffe" - , "girl" - , "give" - , "glad" - , "glance" - , "glare" - , "glass" - , "glide" - , "glimpse" - , "globe" - , "gloom" - , "glory" - , "glove" - , "glow" - , "glue" - , "goat" - , "goddess" - , "gold" - , "good" - , "goose" - , "gorilla" - , "gospel" - , "gossip" - , "govern" - , "gown" - , "grab" - , "grace" - , "grain" - , "grant" - , "grape" - , "grass" - , "gravity" - , "great" - , "green" - , "grid" - , "grief" - , "grit" - , "grocery" - , "group" - , "grow" - , "grunt" - , "guard" - , "guess" - , "guide" - , "guilt" - , "guitar" - , "gun" - , "gym" - , "habit" - , "hair" - , "half" - , "hammer" - , "hamster" - , "hand" - , "happy" - , "harbor" - , "hard" - , "harsh" - , "harvest" - , "hat" - , "have" - , "hawk" - , "hazard" - , "head" - , "health" - , "heart" - , "heavy" - , "hedgehog" - , "height" - , "hello" - , "helmet" - , "help" - , "hen" - , "hero" - , "hidden" - , "high" - , "hill" - , "hint" - , "hip" - , "hire" - , "history" - , "hobby" - , "hockey" - , "hold" - , "hole" - , "holiday" - , "hollow" - , "home" - , "honey" - , "hood" - , "hope" - , "horn" - , "horror" - , "horse" - , "hospital" - , "host" - , "hotel" - , "hour" - , "hover" - , "hub" - , "huge" - , "human" - , "humble" - , "humor" - , "hundred" - , "hungry" - , "hunt" - , "hurdle" - , "hurry" - , "hurt" - , "husband" - , "hybrid" - , "ice" - , "icon" - , "idea" - , "identify" - , "idle" - , "ignore" - , "ill" - , "illegal" - , "illness" - , "image" - , "imitate" - , "immense" - , "immune" - , "impact" - , "impose" - , "improve" - , "impulse" - , "inch" - , "include" - , "income" - , "increase" - , "index" - , "indicate" - , "indoor" - , "industry" - , "infant" - , "inflict" - , "inform" - , "inhale" - , "inherit" - , "initial" - , "inject" - , "injury" - , "inmate" - , "inner" - , "innocent" - , "input" - , "inquiry" - , "insane" - , "insect" - , "inside" - , "inspire" - , "install" - , "intact" - , "interest" - , "into" - , "invest" - , "invite" - , "involve" - , "iron" - , "island" - , "isolate" - , "issue" - , "item" - , "ivory" - , "jacket" - , "jaguar" - , "jar" - , "jazz" - , "jealous" - , "jeans" - , "jelly" - , "jewel" - , "job" - , "join" - , "joke" - , "journey" - , "joy" - , "judge" - , "juice" - , "jump" - , "jungle" - , "junior" - , "junk" - , "just" - , "kangaroo" - , "keen" - , "keep" - , "ketchup" - , "key" - , "kick" - , "kid" - , "kidney" - , "kind" - , "kingdom" - , "kiss" - , "kit" - , "kitchen" - , "kite" - , "kitten" - , "kiwi" - , "knee" - , "knife" - , "knock" - , "know" - , "lab" - , "label" - , "labor" - , "ladder" - , "lady" - , "lake" - , "lamp" - , "language" - , "laptop" - , "large" - , "later" - , "latin" - , "laugh" - , "laundry" - , "lava" - , "law" - , "lawn" - , "lawsuit" - , "layer" - , "lazy" - , "leader" - , "leaf" - , "learn" - , "leave" - , "lecture" - , "left" - , "leg" - , "legal" - , "legend" - , "leisure" - , "lemon" - , "lend" - , "length" - , "lens" - , "leopard" - , "lesson" - , "letter" - , "level" - , "liar" - , "liberty" - , "library" - , "license" - , "life" - , "lift" - , "light" - , "like" - , "limb" - , "limit" - , "link" - , "lion" - , "liquid" - , "list" - , "little" - , "live" - , "lizard" - , "load" - , "loan" - , "lobster" - , "local" - , "lock" - , "logic" - , "lonely" - , "long" - , "loop" - , "lottery" - , "loud" - , "lounge" - , "love" - , "loyal" - , "lucky" - , "luggage" - , "lumber" - , "lunar" - , "lunch" - , "luxury" - , "lyrics" - , "machine" - , "mad" - , "magic" - , "magnet" - , "maid" - , "mail" - , "main" - , "major" - , "make" - , "mammal" - , "man" - , "manage" - , "mandate" - , "mango" - , "mansion" - , "manual" - , "maple" - , "marble" - , "march" - , "margin" - , "marine" - , "market" - , "marriage" - , "mask" - , "mass" - , "master" - , "match" - , "material" - , "math" - , "matrix" - , "matter" - , "maximum" - , "maze" - , "meadow" - , "mean" - , "measure" - , "meat" - , "mechanic" - , "medal" - , "media" - , "melody" - , "melt" - , "member" - , "memory" - , "mention" - , "menu" - , "mercy" - , "merge" - , "merit" - , "merry" - , "mesh" - , "message" - , "metal" - , "method" - , "middle" - , "midnight" - , "milk" - , "million" - , "mimic" - , "mind" - , "minimum" - , "minor" - , "minute" - , "miracle" - , "mirror" - , "misery" - , "miss" - , "mistake" - , "mix" - , "mixed" - , "mixture" - , "mobile" - , "model" - , "modify" - , "mom" - , "moment" - , "monitor" - , "monkey" - , "monster" - , "month" - , "moon" - , "moral" - , "more" - , "morning" - , "mosquito" - , "mother" - , "motion" - , "motor" - , "mountain" - , "mouse" - , "move" - , "movie" - , "much" - , "muffin" - , "mule" - , "multiply" - , "muscle" - , "museum" - , "mushroom" - , "music" - , "must" - , "mutual" - , "myself" - , "mystery" - , "myth" - , "naive" - , "name" - , "napkin" - , "narrow" - , "nasty" - , "nation" - , "nature" - , "near" - , "neck" - , "need" - , "negative" - , "neglect" - , "neither" - , "nephew" - , "nerve" - , "nest" - , "net" - , "network" - , "neutral" - , "never" - , "news" - , "next" - , "nice" - , "night" - , "noble" - , "noise" - , "nominee" - , "noodle" - , "normal" - , "north" - , "nose" - , "notable" - , "note" - , "nothing" - , "notice" - , "novel" - , "now" - , "nuclear" - , "number" - , "nurse" - , "nut" - , "oak" - , "obey" - , "object" - , "oblige" - , "obscure" - , "observe" - , "obtain" - , "obvious" - , "occur" - , "ocean" - , "october" - , "odor" - , "off" - , "offer" - , "office" - , "often" - , "oil" - , "okay" - , "old" - , "olive" - , "olympic" - , "omit" - , "once" - , "one" - , "onion" - , "online" - , "only" - , "open" - , "opera" - , "opinion" - , "oppose" - , "option" - , "orange" - , "orbit" - , "orchard" - , "order" - , "ordinary" - , "organ" - , "orient" - , "original" - , "orphan" - , "ostrich" - , "other" - , "outdoor" - , "outer" - , "output" - , "outside" - , "oval" - , "oven" - , "over" - , "own" - , "owner" - , "oxygen" - , "oyster" - , "ozone" - , "pact" - , "paddle" - , "page" - , "pair" - , "palace" - , "palm" - , "panda" - , "panel" - , "panic" - , "panther" - , "paper" - , "parade" - , "parent" - , "park" - , "parrot" - , "party" - , "pass" - , "patch" - , "path" - , "patient" - , "patrol" - , "pattern" - , "pause" - , "pave" - , "payment" - , "peace" - , "peanut" - , "pear" - , "peasant" - , "pelican" - , "pen" - , "penalty" - , "pencil" - , "people" - , "pepper" - , "perfect" - , "permit" - , "person" - , "pet" - , "phone" - , "photo" - , "phrase" - , "physical" - , "piano" - , "picnic" - , "picture" - , "piece" - , "pig" - , "pigeon" - , "pill" - , "pilot" - , "pink" - , "pioneer" - , "pipe" - , "pistol" - , "pitch" - , "pizza" - , "place" - , "planet" - , "plastic" - , "plate" - , "play" - , "please" - , "pledge" - , "pluck" - , "plug" - , "plunge" - , "poem" - , "poet" - , "point" - , "polar" - , "pole" - , "police" - , "pond" - , "pony" - , "pool" - , "popular" - , "portion" - , "position" - , "possible" - , "post" - , "potato" - , "pottery" - , "poverty" - , "powder" - , "power" - , "practice" - , "praise" - , "predict" - , "prefer" - , "prepare" - , "present" - , "pretty" - , "prevent" - , "price" - , "pride" - , "primary" - , "print" - , "priority" - , "prison" - , "private" - , "prize" - , "problem" - , "process" - , "produce" - , "profit" - , "program" - , "project" - , "promote" - , "proof" - , "property" - , "prosper" - , "protect" - , "proud" - , "provide" - , "public" - , "pudding" - , "pull" - , "pulp" - , "pulse" - , "pumpkin" - , "punch" - , "pupil" - , "puppy" - , "purchase" - , "purity" - , "purpose" - , "purse" - , "push" - , "put" - , "puzzle" - , "pyramid" - , "quality" - , "quantum" - , "quarter" - , "question" - , "quick" - , "quit" - , "quiz" - , "quote" - , "rabbit" - , "raccoon" - , "race" - , "rack" - , "radar" - , "radio" - , "rail" - , "rain" - , "raise" - , "rally" - , "ramp" - , "ranch" - , "random" - , "range" - , "rapid" - , "rare" - , "rate" - , "rather" - , "raven" - , "raw" - , "razor" - , "ready" - , "real" - , "reason" - , "rebel" - , "rebuild" - , "recall" - , "receive" - , "recipe" - , "record" - , "recycle" - , "reduce" - , "reflect" - , "reform" - , "refuse" - , "region" - , "regret" - , "regular" - , "reject" - , "relax" - , "release" - , "relief" - , "rely" - , "remain" - , "remember" - , "remind" - , "remove" - , "render" - , "renew" - , "rent" - , "reopen" - , "repair" - , "repeat" - , "replace" - , "report" - , "require" - , "rescue" - , "resemble" - , "resist" - , "resource" - , "response" - , "result" - , "retire" - , "retreat" - , "return" - , "reunion" - , "reveal" - , "review" - , "reward" - , "rhythm" - , "rib" - , "ribbon" - , "rice" - , "rich" - , "ride" - , "ridge" - , "rifle" - , "right" - , "rigid" - , "ring" - , "riot" - , "ripple" - , "risk" - , "ritual" - , "rival" - , "river" - , "road" - , "roast" - , "robot" - , "robust" - , "rocket" - , "romance" - , "roof" - , "rookie" - , "room" - , "rose" - , "rotate" - , "rough" - , "round" - , "route" - , "royal" - , "rubber" - , "rude" - , "rug" - , "rule" - , "run" - , "runway" - , "rural" - , "sad" - , "saddle" - , "sadness" - , "safe" - , "sail" - , "salad" - , "salmon" - , "salon" - , "salt" - , "salute" - , "same" - , "sample" - , "sand" - , "satisfy" - , "satoshi" - , "sauce" - , "sausage" - , "save" - , "say" - , "scale" - , "scan" - , "scare" - , "scatter" - , "scene" - , "scheme" - , "school" - , "science" - , "scissors" - , "scorpion" - , "scout" - , "scrap" - , "screen" - , "script" - , "scrub" - , "sea" - , "search" - , "season" - , "seat" - , "second" - , "secret" - , "section" - , "security" - , "seed" - , "seek" - , "segment" - , "select" - , "sell" - , "seminar" - , "senior" - , "sense" - , "sentence" - , "series" - , "service" - , "session" - , "settle" - , "setup" - , "seven" - , "shadow" - , "shaft" - , "shallow" - , "share" - , "shed" - , "shell" - , "sheriff" - , "shield" - , "shift" - , "shine" - , "ship" - , "shiver" - , "shock" - , "shoe" - , "shoot" - , "shop" - , "short" - , "shoulder" - , "shove" - , "shrimp" - , "shrug" - , "shuffle" - , "shy" - , "sibling" - , "sick" - , "side" - , "siege" - , "sight" - , "sign" - , "silent" - , "silk" - , "silly" - , "silver" - , "similar" - , "simple" - , "since" - , "sing" - , "siren" - , "sister" - , "situate" - , "six" - , "size" - , "skate" - , "sketch" - , "ski" - , "skill" - , "skin" - , "skirt" - , "skull" - , "slab" - , "slam" - , "sleep" - , "slender" - , "slice" - , "slide" - , "slight" - , "slim" - , "slogan" - , "slot" - , "slow" - , "slush" - , "small" - , "smart" - , "smile" - , "smoke" - , "smooth" - , "snack" - , "snake" - , "snap" - , "sniff" - , "snow" - , "soap" - , "soccer" - , "social" - , "sock" - , "soda" - , "soft" - , "solar" - , "soldier" - , "solid" - , "solution" - , "solve" - , "someone" - , "song" - , "soon" - , "sorry" - , "sort" - , "soul" - , "sound" - , "soup" - , "source" - , "south" - , "space" - , "spare" - , "spatial" - , "spawn" - , "speak" - , "special" - , "speed" - , "spell" - , "spend" - , "sphere" - , "spice" - , "spider" - , "spike" - , "spin" - , "spirit" - , "split" - , "spoil" - , "sponsor" - , "spoon" - , "sport" - , "spot" - , "spray" - , "spread" - , "spring" - , "spy" - , "square" - , "squeeze" - , "squirrel" - , "stable" - , "stadium" - , "staff" - , "stage" - , "stairs" - , "stamp" - , "stand" - , "start" - , "state" - , "stay" - , "steak" - , "steel" - , "stem" - , "step" - , "stereo" - , "stick" - , "still" - , "sting" - , "stock" - , "stomach" - , "stone" - , "stool" - , "story" - , "stove" - , "strategy" - , "street" - , "strike" - , "strong" - , "struggle" - , "student" - , "stuff" - , "stumble" - , "style" - , "subject" - , "submit" - , "subway" - , "success" - , "such" - , "sudden" - , "suffer" - , "sugar" - , "suggest" - , "suit" - , "summer" - , "sun" - , "sunny" - , "sunset" - , "super" - , "supply" - , "supreme" - , "sure" - , "surface" - , "surge" - , "surprise" - , "surround" - , "survey" - , "suspect" - , "sustain" - , "swallow" - , "swamp" - , "swap" - , "swarm" - , "swear" - , "sweet" - , "swift" - , "swim" - , "swing" - , "switch" - , "sword" - , "symbol" - , "symptom" - , "syrup" - , "system" - , "table" - , "tackle" - , "tag" - , "tail" - , "talent" - , "talk" - , "tank" - , "tape" - , "target" - , "task" - , "taste" - , "tattoo" - , "taxi" - , "teach" - , "team" - , "tell" - , "ten" - , "tenant" - , "tennis" - , "tent" - , "term" - , "test" - , "text" - , "thank" - , "that" - , "theme" - , "then" - , "theory" - , "there" - , "they" - , "thing" - , "this" - , "thought" - , "three" - , "thrive" - , "throw" - , "thumb" - , "thunder" - , "ticket" - , "tide" - , "tiger" - , "tilt" - , "timber" - , "time" - , "tiny" - , "tip" - , "tired" - , "tissue" - , "title" - , "toast" - , "tobacco" - , "today" - , "toddler" - , "toe" - , "together" - , "toilet" - , "token" - , "tomato" - , "tomorrow" - , "tone" - , "tongue" - , "tonight" - , "tool" - , "tooth" - , "top" - , "topic" - , "topple" - , "torch" - , "tornado" - , "tortoise" - , "toss" - , "total" - , "tourist" - , "toward" - , "tower" - , "town" - , "toy" - , "track" - , "trade" - , "traffic" - , "tragic" - , "train" - , "transfer" - , "trap" - , "trash" - , "travel" - , "tray" - , "treat" - , "tree" - , "trend" - , "trial" - , "tribe" - , "trick" - , "trigger" - , "trim" - , "trip" - , "trophy" - , "trouble" - , "truck" - , "true" - , "truly" - , "trumpet" - , "trust" - , "truth" - , "try" - , "tube" - , "tuition" - , "tumble" - , "tuna" - , "tunnel" - , "turkey" - , "turn" - , "turtle" - , "twelve" - , "twenty" - , "twice" - , "twin" - , "twist" - , "two" - , "type" - , "typical" - , "ugly" - , "umbrella" - , "unable" - , "unaware" - , "uncle" - , "uncover" - , "under" - , "undo" - , "unfair" - , "unfold" - , "unhappy" - , "uniform" - , "unique" - , "unit" - , "universe" - , "unknown" - , "unlock" - , "until" - , "unusual" - , "unveil" - , "update" - , "upgrade" - , "uphold" - , "upon" - , "upper" - , "upset" - , "urban" - , "urge" - , "usage" - , "use" - , "used" - , "useful" - , "useless" - , "usual" - , "utility" - , "vacant" - , "vacuum" - , "vague" - , "valid" - , "valley" - , "valve" - , "van" - , "vanish" - , "vapor" - , "various" - , "vast" - , "vault" - , "vehicle" - , "velvet" - , "vendor" - , "venture" - , "venue" - , "verb" - , "verify" - , "version" - , "very" - , "vessel" - , "veteran" - , "viable" - , "vibrant" - , "vicious" - , "victory" - , "video" - , "view" - , "village" - , "vintage" - , "violin" - , "virtual" - , "virus" - , "visa" - , "visit" - , "visual" - , "vital" - , "vivid" - , "vocal" - , "voice" - , "void" - , "volcano" - , "volume" - , "vote" - , "voyage" - , "wage" - , "wagon" - , "wait" - , "walk" - , "wall" - , "walnut" - , "want" - , "warfare" - , "warm" - , "warrior" - , "wash" - , "wasp" - , "waste" - , "water" - , "wave" - , "way" - , "wealth" - , "weapon" - , "wear" - , "weasel" - , "weather" - , "web" - , "wedding" - , "weekend" - , "weird" - , "welcome" - , "west" - , "wet" - , "whale" - , "what" - , "wheat" - , "wheel" - , "when" - , "where" - , "whip" - , "whisper" - , "wide" - , "width" - , "wife" - , "wild" - , "will" - , "win" - , "window" - , "wine" - , "wing" - , "wink" - , "winner" - , "winter" - , "wire" - , "wisdom" - , "wise" - , "wish" - , "witness" - , "wolf" - , "woman" - , "wonder" - , "wood" - , "wool" - , "word" - , "work" - , "world" - , "worry" - , "worth" - , "wrap" - , "wreck" - , "wrestle" - , "wrist" - , "write" - , "wrong" - , "yard" - , "year" - , "yellow" - , "you" - , "young" - , "youth" - , "zebra" - , "zero" - , "zone" - , "zoo" - ] diff --git a/src/Haskoin/Network.hs b/src/Haskoin/Network.hs index fbe1a200..9073cba1 100644 --- a/src/Haskoin/Network.hs +++ b/src/Haskoin/Network.hs @@ -1,21 +1,25 @@ -{- | -Module : Haskoin.Network -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module provides basic types used for the Bitcoin networking protocol -together with 'Data.Serialize' instances for efficiently serializing and -de-serializing them. --} -module Haskoin.Network ( +-- | +-- Module : Haskoin.Network +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- This module provides basic types used for the Bitcoin networking protocol +-- together with 'Data.Serialize' instances for efficiently serializing and +-- de-serializing them. +module Haskoin.Network + ( module Data, + module Constants, module Common, module Message, module Bloom, -) where + ) +where import Haskoin.Network.Bloom as Bloom import Haskoin.Network.Common as Common +import Haskoin.Network.Constants as Constants +import Haskoin.Network.Data as Data import Haskoin.Network.Message as Message diff --git a/src/Haskoin/Network/Bloom.hs b/src/Haskoin/Network/Bloom.hs index 047add34..e6610527 100644 --- a/src/Haskoin/Network/Bloom.hs +++ b/src/Haskoin/Network/Bloom.hs @@ -1,21 +1,27 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Network.Bloom -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Bloom filters are used to reduce data transfer when synchronizing thin cients. -When bloom filters are used a client will obtain filtered blocks that only -contain transactions that pass the bloom filter. Transactions announced via inv -messages also pass the filter. --} -module Haskoin.Network.Bloom ( - -- * Bloom Filters +-- | +-- Module : Haskoin.Network.Bloom +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Bloom filters are used to reduce data transfer when synchronizing thin cients. +-- When bloom filters are used a client will obtain filtered blocks that only +-- contain transactions that pass the bloom filter. Transactions announced via inv +-- messages also pass the filter. +module Haskoin.Network.Bloom + ( -- * Bloom Filters BloomFlags (..), BloomFilter (..), FilterLoad (..), @@ -28,27 +34,30 @@ module Haskoin.Network.Bloom ( isBloomFull, acceptsFilters, bloomRelevantUpdate, -) where + ) +where import Control.DeepSeq import Control.Monad (forM_, replicateM) +import Crypto.Secp256k1 (Ctx) import Data.Binary (Binary (..)) import Data.Bits import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial -import qualified Data.Foldable as F +import Data.Foldable qualified as F import Data.Hash.Murmur (murmur3) import Data.List (foldl') -import qualified Data.Sequence as S +import Data.Sequence qualified as S import Data.Serialize (Serialize (..)) import Data.Word import GHC.Generics (Generic) import Haskoin.Network.Common import Haskoin.Script.Standard import Haskoin.Transaction.Common +import Haskoin.Util.Marshal -- | 20,000 items with fp rate < 0.1% or 10,000 items and <0.0001% maxBloomSize :: Int @@ -66,139 +75,137 @@ ln2 = 0.6931471805599453094172321214581765680755001343602552 bitMask :: [Word8] bitMask = [0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80] -{- | The bloom flags are used to tell the remote peer how to auto-update - the provided bloom filter. --} +-- | The bloom flags are used to tell the remote peer how to auto-update +-- the provided bloom filter. data BloomFlags - = -- | never update - BloomUpdateNone - | -- | auto-update on all outputs - BloomUpdateAll - | -- | auto-update on pay-to-pubkey or pay-to-multisig (default) - BloomUpdateP2PubKeyOnly - deriving (Eq, Show, Read, Generic, NFData) + = -- | never update + BloomUpdateNone + | -- | auto-update on all outputs + BloomUpdateAll + | -- | auto-update on pay-to-pubkey or pay-to-multisig (default) + BloomUpdateP2PubKeyOnly + deriving (Eq, Show, Read, Generic, NFData) instance Serial BloomFlags where - deserialize = go =<< getWord8 - where - go 0 = return BloomUpdateNone - go 1 = return BloomUpdateAll - go 2 = return BloomUpdateP2PubKeyOnly - go _ = fail "BloomFlags get: Invalid bloom flag" + deserialize = go =<< getWord8 + where + go 0 = return BloomUpdateNone + go 1 = return BloomUpdateAll + go 2 = return BloomUpdateP2PubKeyOnly + go _ = fail "BloomFlags get: Invalid bloom flag" - serialize f = putWord8 $ case f of - BloomUpdateNone -> 0 - BloomUpdateAll -> 1 - BloomUpdateP2PubKeyOnly -> 2 + serialize f = putWord8 $ case f of + BloomUpdateNone -> 0 + BloomUpdateAll -> 1 + BloomUpdateP2PubKeyOnly -> 2 instance Binary BloomFlags where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize BloomFlags where - get = deserialize - put = serialize + get = deserialize + put = serialize -{- | A bloom filter is a probabilistic data structure that SPV clients send to - other peers to filter the set of transactions received from them. Bloom - filters can have false positives but not false negatives. Some transactions - that pass the filter may not be relevant to the receiving peer. By - controlling the false positive rate, SPV nodes can trade off bandwidth - versus privacy. --} +-- | A bloom filter is a probabilistic data structure that SPV clients send to +-- other peers to filter the set of transactions received from them. Bloom +-- filters can have false positives but not false negatives. Some transactions +-- that pass the filter may not be relevant to the receiving peer. By +-- controlling the false positive rate, SPV nodes can trade off bandwidth +-- versus privacy. data BloomFilter = BloomFilter - { -- | bloom filter data - bloomData :: !(S.Seq Word8) - , -- | number of hash functions for this filter - bloomHashFuncs :: !Word32 - , -- | hash function random nonce - bloomTweak :: !Word32 - , -- | bloom filter auto-update flags - bloomFlags :: !BloomFlags - } - deriving (Eq, Show, Read, Generic, NFData) + { -- | bloom filter data + array :: !(S.Seq Word8), + -- | number of hash functions for this filter + functions :: !Word32, + -- | hash function random nonce + tweak :: !Word32, + -- | bloom filter auto-update flags + flags :: !BloomFlags + } + deriving (Eq, Show, Read, Generic, NFData) instance Serial BloomFilter where - deserialize = - BloomFilter - <$> (S.fromList <$> (readDat =<< deserialize)) - <*> getWord32le - <*> getWord32le - <*> deserialize - where - readDat (VarInt len) = replicateM (fromIntegral len) getWord8 + deserialize = + BloomFilter + <$> (S.fromList <$> (readDat =<< deserialize)) + <*> getWord32le + <*> getWord32le + <*> deserialize + where + readDat (VarInt len) = replicateM (fromIntegral len) getWord8 - serialize (BloomFilter dat hashFuncs tweak flags) = do - putVarInt $ S.length dat - forM_ (F.toList dat) putWord8 - putWord32le hashFuncs - putWord32le tweak - serialize flags + serialize BloomFilter {..} = do + putVarInt $ S.length array + mapM_ putWord8 (F.toList array) + putWord32le functions + putWord32le tweak + serialize flags instance Binary BloomFilter where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize BloomFilter where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | Set a new bloom filter on the peer connection. -newtype FilterLoad = FilterLoad {filterLoadBloomFilter :: BloomFilter} - deriving (Eq, Show, Read, Generic, NFData) +newtype FilterLoad = FilterLoad {filter :: BloomFilter} + deriving (Eq, Show, Read, Generic) + deriving newtype (NFData) instance Serial FilterLoad where - deserialize = FilterLoad <$> deserialize - serialize (FilterLoad f) = serialize f + deserialize = FilterLoad <$> deserialize + serialize (FilterLoad f) = serialize f instance Binary FilterLoad where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize FilterLoad where - put = serialize - get = deserialize + put = serialize + get = deserialize -{- | Add the given data element to the connections current filter without - requiring a completely new one to be set. --} -newtype FilterAdd = FilterAdd {getFilterData :: ByteString} - deriving (Eq, Show, Read, Generic, NFData) +-- | Add the given data element to the connections current filter without +-- requiring a completely new one to be set. +newtype FilterAdd = FilterAdd {get :: ByteString} + deriving (Eq, Show, Read, Generic) + deriving newtype (NFData) instance Serial FilterAdd where - deserialize = do - (VarInt len) <- deserialize - dat <- getByteString $ fromIntegral len - return $ FilterAdd dat + deserialize = do + (VarInt len) <- deserialize + dat <- getByteString $ fromIntegral len + return $ FilterAdd dat - serialize (FilterAdd bs) = do - putVarInt $ BS.length bs - putByteString bs + serialize (FilterAdd bs) = do + putVarInt $ BS.length bs + putByteString bs instance Binary FilterAdd where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize FilterAdd where - put = serialize - get = deserialize + put = serialize + get = deserialize -{- | Build a bloom filter that will provide the given false positive rate when - the given number of elements have been inserted. --} +-- | Build a bloom filter that will provide the given false positive rate when +-- the given number of elements have been inserted. bloomCreate :: - -- | number of elements - Int -> - -- | false positive rate - Double -> - -- | random nonce (tweak) for the hash function - Word32 -> - -- | bloom filter flags - BloomFlags -> - -- | bloom filter - BloomFilter + -- | number of elements + Int -> + -- | false positive rate + Double -> + -- | random nonce (tweak) for the hash function + Word32 -> + -- | bloom filter flags + BloomFlags -> + -- | bloom filter + BloomFilter bloomCreate numElem fpRate = - BloomFilter (S.replicate bloomSize 0) numHashF + BloomFilter (S.replicate bloomSize 0) numHashF where -- Bloom filter size in bytes bloomSize = truncate $ min a b / 8 @@ -211,117 +218,127 @@ bloomCreate numElem fpRate = c = fromIntegral bloomSize * 8 / fromIntegral numElem * ln2 bloomHash :: BloomFilter -> Word32 -> ByteString -> Word32 -bloomHash bfilter hashNum bs = - murmur3 seed bs `mod` (fromIntegral (S.length (bloomData bfilter)) * 8) +bloomHash b hashNum bs = + murmur3 seed bs `mod` (fromIntegral (S.length (b.array)) * 8) where - seed = hashNum * 0xfba4c795 + bloomTweak bfilter + seed = hashNum * 0xfba4c795 + b.tweak -{- | Insert arbitrary data into a bloom filter. Returns the new bloom filter - containing the new data. --} +-- | Insert arbitrary data into a bloom filter. Returns the new bloom filter +-- containing the new data. bloomInsert :: - -- | Original bloom filter - BloomFilter -> - -- | New data to insert - ByteString -> - -- | Bloom filter containing the new data - BloomFilter -bloomInsert bfilter bs - | isBloomFull bfilter = bfilter - | otherwise = bfilter{bloomData = newData} + -- | Original bloom filter + BloomFilter -> + -- | New data to insert + ByteString -> + -- | Bloom filter containing the new data + BloomFilter +bloomInsert b bs + | isBloomFull b = b + | otherwise = b {array = dat} where - idxs = map (\i -> bloomHash bfilter i bs) [0 .. bloomHashFuncs bfilter - 1] + idxs = map (\i -> bloomHash b i bs) [0 .. b.functions - 1] upd s i = - S.adjust - (.|. bitMask !! fromIntegral (7 .&. i)) - (fromIntegral $ i `shiftR` 3) - s - newData = foldl upd (bloomData bfilter) idxs + S.adjust + (.|. bitMask !! fromIntegral (7 .&. i)) + (fromIntegral $ i `shiftR` 3) + s + dat = foldl upd b.array idxs -{- | Tests if some arbitrary data matches the filter. This can be either because - the data was inserted into the filter or because it is a false positive. --} +-- | Tests if some arbitrary data matches the filter. This can be either because +-- the data was inserted into the filter or because it is a false positive. bloomContains :: - -- | Bloom filter - BloomFilter -> - -- | Data that will be checked against the given bloom filter - ByteString -> - -- | Returns True if the data matches the filter - Bool -bloomContains bfilter bs - | isBloomFull bfilter = True - | isBloomEmpty bfilter = False - | otherwise = all isSet idxs + -- | Bloom filter + BloomFilter -> + -- | Data that will be checked against the given bloom filter + ByteString -> + -- | Returns True if the data matches the filter + Bool +bloomContains b bs + | isBloomFull b = True + | isBloomEmpty b = False + | otherwise = all isSet idxs where - s = bloomData bfilter - idxs = map (\i -> bloomHash bfilter i bs) [0 .. bloomHashFuncs bfilter - 1] + s = b.array + idxs = map (\i -> bloomHash b i bs) [0 .. b.functions - 1] isSet i = - S.index s (fromIntegral $ i `shiftR` 3) - .&. (bitMask !! fromIntegral (7 .&. i)) /= 0 + S.index s (fromIntegral $ i `shiftR` 3) + .&. (bitMask !! fromIntegral (7 .&. i)) + /= 0 -{- | Checks if any of the outputs of a tx is in the current bloom filter. - If it is, add the txid and vout as an outpoint (i.e. so that - a future tx that spends the output won't be missed). --} +-- | Checks if any of the outputs of a tx is in the current bloom filter. +-- If it is, add the txid and vout as an outpoint (i.e. so that +-- a future tx that spends the output won't be missed). bloomRelevantUpdate :: - -- | Bloom filter - BloomFilter -> - -- | Tx that may (or may not) have relevant outputs - Tx -> - -- | Returns an updated bloom filter adding relevant output - Maybe BloomFilter -bloomRelevantUpdate bfilter tx - | isBloomFull bfilter || isBloomEmpty bfilter = Nothing - | bloomFlags bfilter == BloomUpdateNone = Nothing - | not (null matchOuts) = Just $ foldl' addRelevant bfilter matchOuts - | otherwise = Nothing + Ctx -> + -- | Bloom filter + BloomFilter -> + -- | Tx that may (or may not) have relevant outputs + Tx -> + -- | Returns an updated bloom filter adding relevant output + Maybe BloomFilter +bloomRelevantUpdate ctx b tx + | isBloomFull b || isBloomEmpty b = Nothing + | b.flags == BloomUpdateNone = Nothing + | not (null matchOuts) = Just $ foldl' addRelevant b matchOuts + | otherwise = Nothing where -- TxHash if we end up inserting an outpoint h = txHash tx -- Decode the scriptOutpus and add vOuts in case we make them outpoints - decodedOutputScripts = traverse (decodeOutputBS . scriptOutput) $ txOut tx + decodedOutputScripts = traverse (unmarshal ctx . (.script)) tx.outputs err = error "Error Decoding output script" idxOutputScripts = either (const err) (zip [0 ..]) decodedOutputScripts -- Check if any txOuts were contained in the bloom filter matchFilter = - filter (\(_, op) -> bloomContains bfilter $ encodeScriptOut op) + filter (\(_, op) -> any (bloomContains b) (encodeScriptOut op)) matchOuts = matchFilter idxOutputScripts addRelevant :: BloomFilter -> (Word32, ScriptOutput) -> BloomFilter addRelevant bf (id', scriptOut) = - case (bloomFlags bfilter, scriptType) of - -- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig + case (b.flags, scriptType) of + -- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig - (_, True) -> bloomInsert bf outpoint - (BloomUpdateAll, _) -> bloomInsert bf outpoint - _ -> error "Error Updating Bloom Filter with relevant outpoint" + (_, True) -> bloomInsert bf outpoint + (BloomUpdateAll, _) -> bloomInsert bf outpoint + _ -> error "Error Updating Bloom Filter with relevant outpoint" where - outpoint = runPutS $ serialize $ OutPoint{outPointHash = h, outPointIndex = id'} + outpoint = runPutS $ serialize $ OutPoint {hash = h, index = id'} scriptType = (\s -> isPayPK s || isPayMulSig s) scriptOut -- Encodes a scriptOutput so it can be checked agains the Bloom Filter - encodeScriptOut :: ScriptOutput -> ByteString - encodeScriptOut (PayMulSig outputMuSig _) = runPutS $ serialize outputMuSig - encodeScriptOut (PayWitnessScriptHash scriptHash) = runPutS $ serialize scriptHash - encodeScriptOut (DataCarrier getOutputDat) = runPutS $ serialize getOutputDat - encodeScriptOut outputHash = (runPutS . serialize . getOutputHash) outputHash + encodeScriptOut :: ScriptOutput -> [ByteString] + encodeScriptOut (PayPK pk) = + return $ marshal ctx pk + encodeScriptOut (PayPKHash ph) = + return . runPutS $ serialize ph + encodeScriptOut (PayMulSig outputMuSig _) = + map (marshal ctx) outputMuSig + encodeScriptOut (PayScriptHash sh) = + return . runPutS $ serialize sh + encodeScriptOut (PayWitnessPKHash ph) = + return . runPutS $ serialize ph + encodeScriptOut (PayWitnessScriptHash sh) = + return . runPutS $ serialize sh + encodeScriptOut (PayWitness _ wd) = + return wd + encodeScriptOut (DataCarrier dat) = + return dat -- | Returns True if the filter is empty (all bytes set to 0x00) isBloomEmpty :: BloomFilter -> Bool -isBloomEmpty bfilter = all (== 0x00) $ F.toList $ bloomData bfilter +isBloomEmpty b = all (== 0x00) $ F.toList b.array -- | Returns True if the filter is full (all bytes set to 0xff) isBloomFull :: BloomFilter -> Bool -isBloomFull bfilter = all (== 0xff) $ F.toList $ bloomData bfilter +isBloomFull b = all (== 0xff) $ F.toList b.array -- | Tests if a given bloom filter is valid. isBloomValid :: - -- | Bloom filter to test - BloomFilter -> - -- | True if the given filter is valid - Bool -isBloomValid bfilter = - S.length (bloomData bfilter) <= maxBloomSize - && bloomHashFuncs bfilter <= maxHashFuncs + -- | Bloom filter to test + BloomFilter -> + -- | True if the given filter is valid + Bool +isBloomValid BloomFilter {..} = + S.length array <= maxBloomSize && functions <= maxHashFuncs -- | Does the peer with these version services accept bloom filters? acceptsFilters :: Word64 -> Bool diff --git a/src/Haskoin/Network/Common.hs b/src/Haskoin/Network/Common.hs index f1d942bc..5b852a18 100644 --- a/src/Haskoin/Network/Common.hs +++ b/src/Haskoin/Network/Common.hs @@ -1,19 +1,23 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE ImportQualifiedPost #-} -{- | -Module : Haskoin.Network.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common functions and data types related to peer-to-peer network. --} -module Haskoin.Network.Common ( - -- * Network Data Types +-- | +-- Module : Haskoin.Network.Common +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Common functions and data types related to peer-to-peer network. +module Haskoin.Network.Common + ( -- * Network Data Types Addr (..), NetworkAddressTime, Alert (..), @@ -44,14 +48,15 @@ module Haskoin.Network.Common ( commandToString, stringToCommand, putVarInt, -) where + ) +where import Control.DeepSeq import Control.Monad (forM_, liftM2, replicateM, unless) import Data.Binary (Binary (..)) import Data.Bits (shiftL) import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.ByteString.Char8 as C (replicate) import Data.Bytes.Get import Data.Bytes.Put @@ -68,684 +73,682 @@ import Text.Read as R -- | Network address with a timestamp. type NetworkAddressTime = (Word32, NetworkAddress) -{- | Provides information about known nodes in the bitcoin network. An 'Addr' - type is sent inside a 'Message' as a response to a 'GetAddr' message. --} +-- | Provides information about known nodes in the bitcoin network. An 'Addr' +-- type is sent inside a 'Message' as a response to a 'GetAddr' message. newtype Addr = Addr - { -- List of addresses of other nodes on the network with timestamps. - addrList :: [NetworkAddressTime] - } - deriving (Eq, Show, Generic, NFData) + { -- List of addresses of other nodes on the network with timestamps. + list :: [NetworkAddressTime] + } + deriving (Eq, Show, Generic) + deriving newtype (NFData) instance Serial Addr where - deserialize = Addr <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) action - action = liftM2 (,) getWord32le deserialize + deserialize = Addr <$> (repList =<< deserialize) + where + repList (VarInt c) = replicateM (fromIntegral c) action + action = liftM2 (,) getWord32le deserialize - serialize (Addr xs) = do - putVarInt $ length xs - forM_ xs $ \(a, b) -> putWord32le a >> serialize b + serialize (Addr xs) = do + putVarInt $ length xs + forM_ xs $ \(a, b) -> putWord32le a >> serialize b instance Binary Addr where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize Addr where - get = deserialize - put = serialize + get = deserialize + put = serialize -{- | Data type describing signed messages that can be sent between bitcoin - nodes to display important notifications to end users about the health of - the network. --} +-- | Data type describing signed messages that can be sent between bitcoin +-- nodes to display important notifications to end users about the health of +-- the network. data Alert = Alert - { -- | Alert payload. - alertPayload :: !VarString - , -- | ECDSA signature of the payload - alertSignature :: !VarString - } - deriving (Eq, Show, Read, Generic, NFData) + { -- | Alert payload. + payload :: !VarString, + -- | ECDSA signature of the payload + signature :: !VarString + } + deriving (Eq, Show, Read, Generic, NFData) instance Serial Alert where - deserialize = Alert <$> deserialize <*> deserialize - serialize (Alert p s) = serialize p >> serialize s + deserialize = Alert <$> deserialize <*> deserialize + serialize (Alert p s) = serialize p >> serialize s instance Binary Alert where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize Alert where - put = serialize - get = deserialize + put = serialize + get = deserialize -{- | The 'GetData' type is used to retrieve information on a specific object - ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' - request is a list of 'InvVector' which represent all the hashes of objects - that a node wants. The response to a 'GetBlock' message will be either a - 'Block' or a 'Tx' message depending on the type of the object referenced by - the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv' - message that contains unknown object hashes. --} +-- | The 'GetData' type is used to retrieve information on a specific object +-- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' +-- request is a list of 'InvVector' which represent all the hashes of objects +-- that a node wants. The response to a 'GetBlock' message will be either a +-- 'Block' or a 'Tx' message depending on the type of the object referenced by +-- the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv' +-- message that contains unknown object hashes. newtype GetData = GetData - { -- | list of object hashes - getDataList :: [InvVector] - } - deriving (Eq, Show, Generic, NFData) + { -- | list of object hashes + list :: [InvVector] + } + deriving (Eq, Show, Generic) + deriving newtype (NFData) instance Serial GetData where - deserialize = GetData <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + deserialize = GetData <$> (repList =<< deserialize) + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize - serialize (GetData xs) = do - putVarInt $ length xs - forM_ xs serialize + serialize (GetData xs) = do + putVarInt $ length xs + forM_ xs serialize instance Binary GetData where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize GetData where - get = deserialize - put = serialize + get = deserialize + put = serialize -{- | 'Inv' messages are used by nodes to advertise their knowledge of new - objects by publishing a list of hashes to a peer. 'Inv' messages can be sent - unsolicited or in response to a 'GetBlocks' message. --} +-- | 'Inv' messages are used by nodes to advertise their knowledge of new +-- objects by publishing a list of hashes to a peer. 'Inv' messages can be sent +-- unsolicited or in response to a 'GetBlocks' message. newtype Inv = Inv - { -- | inventory - invList :: [InvVector] - } - deriving (Eq, Show, Generic, NFData) + { -- | inventory + list :: [InvVector] + } + deriving (Eq, Show, Generic) + deriving newtype (NFData) instance Serial Inv where - deserialize = Inv <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + deserialize = Inv <$> (repList =<< deserialize) + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize - serialize (Inv xs) = do - putVarInt $ length xs - forM_ xs serialize + serialize (Inv xs) = do + putVarInt $ length xs + forM_ xs serialize instance Binary Inv where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize Inv where - get = deserialize - put = serialize + get = deserialize + put = serialize -{- | Data type identifying the type of an inventory vector. SegWit types are - only used in 'GetData' messages, not 'Inv'. --} +-- | Data type identifying the type of an inventory vector. SegWit types are +-- only used in 'GetData' messages, not 'Inv'. data InvType - = -- | error - InvError - | -- | transaction - InvTx - | -- | block - InvBlock - | -- | filtered block - InvMerkleBlock - | -- | segwit transaction - InvWitnessTx - | -- | segwit block - InvWitnessBlock - | -- | segwit filtered block - InvWitnessMerkleBlock - | -- | unknown inv type - InvType Word32 - deriving (Eq, Show, Read, Generic, NFData) + = -- | error + InvError + | -- | transaction + InvTx + | -- | block + InvBlock + | -- | filtered block + InvMerkleBlock + | -- | segwit transaction + InvWitnessTx + | -- | segwit block + InvWitnessBlock + | -- | segwit filtered block + InvWitnessMerkleBlock + | -- | unknown inv type + InvType Word32 + deriving (Eq, Show, Read, Generic, NFData) instance Serial InvType where - deserialize = go =<< getWord32le - where - go x = - case x of - 0 -> return InvError - 1 -> return InvTx - 2 -> return InvBlock - 3 -> return InvMerkleBlock - _ - | x == 1 `shiftL` 30 + 1 -> return InvWitnessTx - | x == 1 `shiftL` 30 + 2 -> return InvWitnessBlock - | x == 1 `shiftL` 30 + 3 -> return InvWitnessMerkleBlock - | otherwise -> return (InvType x) - serialize x = - putWord32le $ - case x of - InvError -> 0 - InvTx -> 1 - InvBlock -> 2 - InvMerkleBlock -> 3 - InvWitnessTx -> 1 `shiftL` 30 + 1 - InvWitnessBlock -> 1 `shiftL` 30 + 2 - InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3 - InvType w -> w + deserialize = go =<< getWord32le + where + go x = + case x of + 0 -> return InvError + 1 -> return InvTx + 2 -> return InvBlock + 3 -> return InvMerkleBlock + _ + | x == 1 `shiftL` 30 + 1 -> return InvWitnessTx + | x == 1 `shiftL` 30 + 2 -> return InvWitnessBlock + | x == 1 `shiftL` 30 + 3 -> return InvWitnessMerkleBlock + | otherwise -> return (InvType x) + serialize x = + putWord32le $ + case x of + InvError -> 0 + InvTx -> 1 + InvBlock -> 2 + InvMerkleBlock -> 3 + InvWitnessTx -> 1 `shiftL` 30 + 1 + InvWitnessBlock -> 1 `shiftL` 30 + 2 + InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3 + InvType w -> w instance Binary InvType where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize InvType where - get = deserialize - put = serialize + get = deserialize + put = serialize -{- | Invectory vectors represent hashes identifying objects such as a 'Block' or - a 'Tx'. They notify other peers about new data or data they have otherwise - requested. --} +-- | Invectory vectors represent hashes identifying objects such as a 'Block' or +-- a 'Tx'. They notify other peers about new data or data they have otherwise +-- requested. data InvVector = InvVector - { -- | type of object - invType :: !InvType - , -- | 256-bit hash of object - invHash :: !Hash256 - } - deriving (Eq, Show, Generic, NFData) + { -- | type of object + invType :: !InvType, + -- | 256-bit hash of object + invHash :: !Hash256 + } + deriving (Eq, Show, Generic, NFData) instance Serial InvVector where - deserialize = InvVector <$> deserialize <*> deserialize - serialize (InvVector t h) = serialize t >> serialize h + deserialize = InvVector <$> deserialize <*> deserialize + serialize (InvVector t h) = serialize t >> serialize h instance Binary InvVector where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize InvVector where - get = deserialize - put = serialize + get = deserialize + put = serialize newtype HostAddress - = HostAddress ByteString - deriving (Eq, Show, Ord, Generic, NFData) + = HostAddress ByteString + deriving (Eq, Show, Ord, Generic) + deriving newtype (NFData) instance Serial HostAddress where - serialize (HostAddress bs) = putByteString bs - deserialize = HostAddress <$> getByteString 18 + serialize (HostAddress bs) = putByteString bs + deserialize = HostAddress <$> getByteString 18 instance Binary HostAddress where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize HostAddress where - get = deserialize - put = serialize + get = deserialize + put = serialize -{- | Data type describing a bitcoin network address. Addresses are stored in - IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 - addresses: . --} +-- | Data type describing a bitcoin network address. Addresses are stored in +-- IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 +-- addresses: . data NetworkAddress = NetworkAddress - { -- | bitmask of services available for this address - naServices :: !Word64 - , -- | address and port information - naAddress :: !HostAddress - } - deriving (Eq, Show, Generic, NFData) + { -- | bitmask of services available for this address + services :: !Word64, + -- | address and port information + address :: !HostAddress + } + deriving (Eq, Show, Generic, NFData) hostToSockAddr :: HostAddress -> SockAddr hostToSockAddr (HostAddress bs) = - case runGetS getSockAddr bs of - Left e -> error e - Right x -> x + case runGetS getSockAddr bs of + Left e -> error e + Right x -> x sockToHostAddress :: SockAddr -> HostAddress sockToHostAddress = HostAddress . runPutS . putSockAddr -putSockAddr :: MonadPut m => SockAddr -> m () +putSockAddr :: (MonadPut m) => SockAddr -> m () putSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do - putWord32be a - putWord32be b - putWord32be c - putWord32be d - putWord16be (fromIntegral p) + putWord32be a + putWord32be b + putWord32be c + putWord32be d + putWord16be (fromIntegral p) putSockAddr (SockAddrInet p a) = do - putWord32be 0x00000000 - putWord32be 0x00000000 - putWord32be 0x0000ffff - putWord32host a - putWord16be (fromIntegral p) + putWord32be 0x00000000 + putWord32be 0x00000000 + putWord32be 0x0000ffff + putWord32host a + putWord16be (fromIntegral p) putSockAddr _ = error "Invalid address type" -getSockAddr :: MonadGet m => m SockAddr +getSockAddr :: (MonadGet m) => m SockAddr getSockAddr = do - a <- getWord32be - b <- getWord32be - c <- getWord32be - if a == 0x00000000 && b == 0x00000000 && c == 0x0000ffff - then do - d <- getWord32host - p <- getWord16be - return $ SockAddrInet (fromIntegral p) d - else do - d <- getWord32be - p <- getWord16be - return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 + a <- getWord32be + b <- getWord32be + c <- getWord32be + if a == 0x00000000 && b == 0x00000000 && c == 0x0000ffff + then do + d <- getWord32host + p <- getWord16be + return $ SockAddrInet (fromIntegral p) d + else do + d <- getWord32be + p <- getWord16be + return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 instance Serial NetworkAddress where - deserialize = NetworkAddress <$> getWord64le <*> deserialize - serialize (NetworkAddress s a) = putWord64le s >> serialize a + deserialize = NetworkAddress <$> getWord64le <*> deserialize + serialize (NetworkAddress s a) = putWord64le s >> serialize a instance Binary NetworkAddress where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize NetworkAddress where - get = deserialize - put = serialize + get = deserialize + put = serialize -{- | A 'NotFound' message is returned as a response to a 'GetData' message - whe one of the requested objects could not be retrieved. This could happen, - for example, if a tranasaction was requested and was not available in the - memory pool of the receiving node. --} +-- | A 'NotFound' message is returned as a response to a 'GetData' message +-- whe one of the requested objects could not be retrieved. This could happen, +-- for example, if a tranasaction was requested and was not available in the +-- memory pool of the receiving node. newtype NotFound = NotFound - { -- | Inventory vectors related to this request - notFoundList :: [InvVector] - } - deriving (Eq, Show, Generic, NFData) + { -- | Inventory vectors related to this request + list :: [InvVector] + } + deriving (Eq, Show, Generic) + deriving newtype (NFData) instance Serial NotFound where - deserialize = NotFound <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + deserialize = NotFound <$> (repList =<< deserialize) + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize - serialize (NotFound xs) = do - putVarInt $ length xs - forM_ xs serialize + serialize (NotFound xs) = do + putVarInt $ length xs + forM_ xs serialize instance Binary NotFound where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize NotFound where - get = deserialize - put = serialize + get = deserialize + put = serialize -{- | A 'Ping' message is sent to bitcoin peers to check if a connection is still - open. --} +-- | A 'Ping' message is sent to bitcoin peers to check if a connection is still +-- open. newtype Ping = Ping - { -- | A random nonce used to identify the recipient of the ping - -- request once a Pong response is received. - pingNonce :: Word64 - } - deriving (Eq, Show, Read, Generic, NFData) + { -- | A random nonce used to identify the recipient of the ping + -- request once a Pong response is received. + nonce :: Word64 + } + deriving (Eq, Show, Read, Generic) + deriving newtype (NFData) -- | A Pong message is sent as a response to a ping message. newtype Pong = Pong - { -- | nonce from corresponding 'Ping' - pongNonce :: Word64 - } - deriving (Eq, Show, Read, Generic, NFData) + { -- | nonce from corresponding 'Ping' + nonce :: Word64 + } + deriving (Eq, Show, Read, Generic) + deriving newtype (NFData) instance Serial Ping where - deserialize = Ping <$> getWord64le - serialize (Ping n) = putWord64le n + deserialize = Ping <$> getWord64le + serialize (Ping n) = putWord64le n instance Serial Pong where - deserialize = Pong <$> getWord64le - serialize (Pong n) = putWord64le n + deserialize = Pong <$> getWord64le + serialize (Pong n) = putWord64le n instance Binary Ping where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Binary Pong where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize Ping where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize Pong where - get = deserialize - put = serialize + get = deserialize + put = serialize -- | The 'Reject' message is sent when messages are rejected by a peer. data Reject = Reject - { -- | type of message rejected - rejectMessage :: !MessageCommand - , -- | rejection code - rejectCode :: !RejectCode - , -- | text reason for rejection - rejectReason :: !VarString - , -- | extra data such as block or tx hash - rejectData :: !ByteString - } - deriving (Eq, Show, Read, Generic, NFData) + { -- | type of message rejected + message :: !MessageCommand, + -- | rejection code + code :: !RejectCode, + -- | text reason for rejection + reason :: !VarString, + -- | extra data such as block or tx hash + extra :: !ByteString + } + deriving (Eq, Show, Read, Generic, NFData) -- | Rejection code associated to the 'Reject' message. data RejectCode - = RejectMalformed - | RejectInvalid - | RejectObsolete - | RejectDuplicate - | RejectNonStandard - | RejectDust - | RejectInsufficientFee - | RejectCheckpoint - deriving (Eq, Show, Read, Generic, NFData) + = RejectMalformed + | RejectInvalid + | RejectObsolete + | RejectDuplicate + | RejectNonStandard + | RejectDust + | RejectInsufficientFee + | RejectCheckpoint + deriving (Eq, Show, Read, Generic, NFData) instance Serial RejectCode where - deserialize = - getWord8 >>= \code -> case code of - 0x01 -> return RejectMalformed - 0x10 -> return RejectInvalid - 0x11 -> return RejectObsolete - 0x12 -> return RejectDuplicate - 0x40 -> return RejectNonStandard - 0x41 -> return RejectDust - 0x42 -> return RejectInsufficientFee - 0x43 -> return RejectCheckpoint - _ -> - fail $ - unwords - [ "Reject get: Invalid code" - , show code - ] + deserialize = + getWord8 >>= \code -> case code of + 0x01 -> return RejectMalformed + 0x10 -> return RejectInvalid + 0x11 -> return RejectObsolete + 0x12 -> return RejectDuplicate + 0x40 -> return RejectNonStandard + 0x41 -> return RejectDust + 0x42 -> return RejectInsufficientFee + 0x43 -> return RejectCheckpoint + _ -> + fail $ + unwords + [ "Reject get: Invalid code", + show code + ] - serialize code = putWord8 $ case code of - RejectMalformed -> 0x01 - RejectInvalid -> 0x10 - RejectObsolete -> 0x11 - RejectDuplicate -> 0x12 - RejectNonStandard -> 0x40 - RejectDust -> 0x41 - RejectInsufficientFee -> 0x42 - RejectCheckpoint -> 0x43 + serialize code = putWord8 $ case code of + RejectMalformed -> 0x01 + RejectInvalid -> 0x10 + RejectObsolete -> 0x11 + RejectDuplicate -> 0x12 + RejectNonStandard -> 0x40 + RejectDust -> 0x41 + RejectInsufficientFee -> 0x42 + RejectCheckpoint -> 0x43 instance Binary RejectCode where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize RejectCode where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | Convenience function to build a 'Reject' message. reject :: MessageCommand -> RejectCode -> ByteString -> Reject reject cmd code reason = - Reject cmd code (VarString reason) B.empty + Reject cmd code (VarString reason) B.empty instance Serial Reject where - deserialize = - deserialize >>= \(VarString bs) -> - Reject (stringToCommand bs) - <$> deserialize - <*> deserialize - <*> maybeData - where - maybeData = - isEmpty >>= \done -> - if done - then return B.empty - else getByteString 32 - serialize (Reject cmd code reason dat) = do - serialize $ VarString $ commandToString cmd - serialize code - serialize reason - unless (B.null dat) $ putByteString dat + deserialize = + deserialize >>= \(VarString bs) -> + Reject (stringToCommand bs) + <$> deserialize + <*> deserialize + <*> maybeData + where + maybeData = + isEmpty >>= \done -> + if done + then return B.empty + else getByteString 32 + serialize (Reject cmd code reason dat) = do + serialize $ VarString $ commandToString cmd + serialize code + serialize reason + unless (B.null dat) $ putByteString dat instance Binary Reject where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize Reject where - put = serialize - get = deserialize + put = serialize + get = deserialize -{- | Data type representing a variable-length integer. The 'VarInt' type - usually precedes an array or a string that can vary in length. --} -newtype VarInt = VarInt {getVarInt :: Word64} - deriving (Eq, Show, Read, Generic, NFData) +-- | Data type representing a variable-length integer. The 'VarInt' type +-- usually precedes an array or a string that can vary in length. +newtype VarInt = VarInt {get :: Word64} + deriving (Eq, Show, Read, Generic) + deriving newtype (NFData) instance Serial VarInt where - deserialize = VarInt <$> (getWord8 >>= go) - where - go 0xff = getWord64le - go 0xfe = fromIntegral <$> getWord32le - go 0xfd = fromIntegral <$> getWord16le - go x = return $ fromIntegral x + deserialize = VarInt <$> (getWord8 >>= go) + where + go 0xff = getWord64le + go 0xfe = fromIntegral <$> getWord32le + go 0xfd = fromIntegral <$> getWord16le + go x = return $ fromIntegral x - serialize (VarInt x) - | x < 0xfd = - putWord8 $ fromIntegral x - | x <= 0xffff = do - putWord8 0xfd - putWord16le $ fromIntegral x - | x <= 0xffffffff = do - putWord8 0xfe - putWord32le $ fromIntegral x - | otherwise = do - putWord8 0xff - putWord64le x + serialize (VarInt x) + | x < 0xfd = + putWord8 $ fromIntegral x + | x <= 0xffff = do + putWord8 0xfd + putWord16le $ fromIntegral x + | x <= 0xffffffff = do + putWord8 0xfe + putWord32le $ fromIntegral x + | otherwise = do + putWord8 0xff + putWord64le x instance Binary VarInt where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize VarInt where - put = serialize - get = deserialize + put = serialize + get = deserialize putVarInt :: (MonadPut m, Integral a) => a -> m () putVarInt = serialize . VarInt . fromIntegral -- | Data type for serialization of variable-length strings. -newtype VarString = VarString {getVarString :: ByteString} - deriving (Eq, Show, Read, Generic, NFData) +newtype VarString = VarString {get :: ByteString} + deriving (Eq, Show, Read, Generic) + deriving newtype (NFData) instance Serial VarString where - deserialize = VarString <$> (readBS =<< deserialize) - where - readBS (VarInt len) = getByteString (fromIntegral len) + deserialize = VarString <$> (readBS =<< deserialize) + where + readBS (VarInt len) = getByteString (fromIntegral len) - serialize (VarString bs) = do - putVarInt $ B.length bs - putByteString bs + serialize (VarString bs) = do + putVarInt $ B.length bs + putByteString bs instance Binary VarString where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize VarString where - put = serialize - get = deserialize + put = serialize + get = deserialize -{- | When a bitcoin node creates an outgoing connection to another node, - the first message it will send is a 'Version' message. The other node - will similarly respond with it's own 'Version' message. --} +-- | When a bitcoin node creates an outgoing connection to another node, +-- the first message it will send is a 'Version' message. The other node +-- will similarly respond with it's own 'Version' message. data Version = Version - { -- | protocol version - version :: !Word32 - , -- | features supported by this connection - services :: !Word64 - , -- | unix timestamp - timestamp :: !Word64 - , -- | network address of remote node - addrRecv :: !NetworkAddress - , -- | network address of sending node - addrSend :: !NetworkAddress - , -- | random nonce to detect connection to self - verNonce :: !Word64 - , -- | user agent string - userAgent :: !VarString - , -- | height of the last block in sending node - startHeight :: !Word32 - , -- | relay transactions flag (BIP-37) - relay :: !Bool - } - deriving (Eq, Show, Generic, NFData) + { -- | protocol version + version :: !Word32, + -- | features supported by this connection + services :: !Word64, + -- | unix timestamp + timestamp :: !Word64, + -- | network address of remote node + addrRecv :: !NetworkAddress, + -- | network address of sending node + addrSend :: !NetworkAddress, + -- | random nonce to detect connection to self + nonce :: !Word64, + -- | user agent string + userAgent :: !VarString, + -- | height of the last block in sending node + startHeight :: !Word32, + -- | relay transactions flag (BIP-37) + relay :: !Bool + } + deriving (Eq, Show, Generic, NFData) instance Serial Version where - deserialize = - Version <$> getWord32le - <*> getWord64le - <*> getWord64le - <*> deserialize - <*> deserialize - <*> getWord64le - <*> deserialize - <*> getWord32le - <*> (go =<< isEmpty) - where - go True = return True - go False = getBool + deserialize = + Version + <$> getWord32le + <*> getWord64le + <*> getWord64le + <*> deserialize + <*> deserialize + <*> getWord64le + <*> deserialize + <*> getWord32le + <*> (go =<< isEmpty) + where + go True = return True + go False = getBool - serialize (Version v s t ar as n ua sh r) = do - putWord32le v - putWord64le s - putWord64le t - serialize ar - serialize as - putWord64le n - serialize ua - putWord32le sh - putBool r + serialize (Version v s t ar as n ua sh r) = do + putWord32le v + putWord64le s + putWord64le t + serialize ar + serialize as + putWord64le n + serialize ua + putWord32le sh + putBool r instance Binary Version where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize Version where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | 0x00 is 'False', anything else is 'True'. -getBool :: MonadGet m => m Bool +getBool :: (MonadGet m) => m Bool getBool = go =<< getWord8 where go 0 = return False go _ = return True -putBool :: MonadPut m => Bool -> m () +putBool :: (MonadPut m) => Bool -> m () putBool True = putWord8 1 putBool False = putWord8 0 -{- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify - the type of message present in the payload. This allows the message - de-serialization code to know how to decode a particular message payload. - Every valid 'Message' constructor has a corresponding 'MessageCommand' - constructor. --} +-- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify +-- the type of message present in the payload. This allows the message +-- de-serialization code to know how to decode a particular message payload. +-- Every valid 'Message' constructor has a corresponding 'MessageCommand' +-- constructor. data MessageCommand - = MCVersion - | MCVerAck - | MCAddr - | MCInv - | MCGetData - | MCNotFound - | MCGetBlocks - | MCGetHeaders - | MCTx - | MCBlock - | MCMerkleBlock - | MCHeaders - | MCGetAddr - | MCFilterLoad - | MCFilterAdd - | MCFilterClear - | MCPing - | MCPong - | MCAlert - | MCMempool - | MCReject - | MCSendHeaders - | MCOther ByteString - deriving (Eq, Generic, NFData) + = MCVersion + | MCVerAck + | MCAddr + | MCInv + | MCGetData + | MCNotFound + | MCGetBlocks + | MCGetHeaders + | MCTx + | MCBlock + | MCMerkleBlock + | MCHeaders + | MCGetAddr + | MCFilterLoad + | MCFilterAdd + | MCFilterClear + | MCPing + | MCPong + | MCAlert + | MCMempool + | MCReject + | MCSendHeaders + | MCOther ByteString + deriving (Eq, Generic, NFData) instance Show MessageCommand where - showsPrec _ = shows . commandToString + showsPrec _ = shows . commandToString instance Read MessageCommand where - readPrec = do - String str <- lexP - return (stringToCommand (cs str)) + readPrec = do + String str <- lexP + return (stringToCommand (cs str)) instance Serial MessageCommand where - deserialize = go <$> getByteString 12 - where - go bs = - let str = unpackCommand bs - in stringToCommand str - serialize mc = putByteString $ packCommand $ commandToString mc + deserialize = go <$> getByteString 12 + where + go bs = + let str = unpackCommand bs + in stringToCommand str + serialize mc = putByteString $ packCommand $ commandToString mc instance Binary MessageCommand where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize MessageCommand where - put = serialize - get = deserialize + put = serialize + get = deserialize instance IsString MessageCommand where - fromString str = stringToCommand (cs str) + fromString str = stringToCommand (cs str) -- | Read a 'MessageCommand' from its string representation. stringToCommand :: ByteString -> MessageCommand stringToCommand str = case str of - "version" -> MCVersion - "verack" -> MCVerAck - "addr" -> MCAddr - "inv" -> MCInv - "getdata" -> MCGetData - "notfound" -> MCNotFound - "getblocks" -> MCGetBlocks - "getheaders" -> MCGetHeaders - "tx" -> MCTx - "block" -> MCBlock - "merkleblock" -> MCMerkleBlock - "headers" -> MCHeaders - "getaddr" -> MCGetAddr - "filterload" -> MCFilterLoad - "filteradd" -> MCFilterAdd - "filterclear" -> MCFilterClear - "ping" -> MCPing - "pong" -> MCPong - "alert" -> MCAlert - "mempool" -> MCMempool - "reject" -> MCReject - "sendheaders" -> MCSendHeaders - _ -> MCOther str + "version" -> MCVersion + "verack" -> MCVerAck + "addr" -> MCAddr + "inv" -> MCInv + "getdata" -> MCGetData + "notfound" -> MCNotFound + "getblocks" -> MCGetBlocks + "getheaders" -> MCGetHeaders + "tx" -> MCTx + "block" -> MCBlock + "merkleblock" -> MCMerkleBlock + "headers" -> MCHeaders + "getaddr" -> MCGetAddr + "filterload" -> MCFilterLoad + "filteradd" -> MCFilterAdd + "filterclear" -> MCFilterClear + "ping" -> MCPing + "pong" -> MCPong + "alert" -> MCAlert + "mempool" -> MCMempool + "reject" -> MCReject + "sendheaders" -> MCSendHeaders + _ -> MCOther str -- | Convert a 'MessageCommand' to its string representation. commandToString :: MessageCommand -> ByteString commandToString mc = case mc of - MCVersion -> "version" - MCVerAck -> "verack" - MCAddr -> "addr" - MCInv -> "inv" - MCGetData -> "getdata" - MCNotFound -> "notfound" - MCGetBlocks -> "getblocks" - MCGetHeaders -> "getheaders" - MCTx -> "tx" - MCBlock -> "block" - MCMerkleBlock -> "merkleblock" - MCHeaders -> "headers" - MCGetAddr -> "getaddr" - MCFilterLoad -> "filterload" - MCFilterAdd -> "filteradd" - MCFilterClear -> "filterclear" - MCPing -> "ping" - MCPong -> "pong" - MCAlert -> "alert" - MCMempool -> "mempool" - MCReject -> "reject" - MCSendHeaders -> "sendheaders" - MCOther c -> c + MCVersion -> "version" + MCVerAck -> "verack" + MCAddr -> "addr" + MCInv -> "inv" + MCGetData -> "getdata" + MCNotFound -> "notfound" + MCGetBlocks -> "getblocks" + MCGetHeaders -> "getheaders" + MCTx -> "tx" + MCBlock -> "block" + MCMerkleBlock -> "merkleblock" + MCHeaders -> "headers" + MCGetAddr -> "getaddr" + MCFilterLoad -> "filterload" + MCFilterAdd -> "filteradd" + MCFilterClear -> "filterclear" + MCPing -> "ping" + MCPong -> "pong" + MCAlert -> "alert" + MCMempool -> "mempool" + MCReject -> "reject" + MCSendHeaders -> "sendheaders" + MCOther c -> c -- | Pack a string 'MessageCommand' so that it is exactly 12-bytes long. packCommand :: ByteString -> ByteString packCommand s = - B.take 12 $ - s `mappend` C.replicate 12 '\NUL' + B.take 12 $ + s `mappend` C.replicate 12 '\NUL' -- | Undo packing done by 'packCommand'. unpackCommand :: ByteString -> ByteString diff --git a/src/Haskoin/Network/Constants.hs b/src/Haskoin/Network/Constants.hs new file mode 100644 index 00000000..ec8807ff --- /dev/null +++ b/src/Haskoin/Network/Constants.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +-- | +-- Module : Haskoin.Constants +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Network constants for various networks, including Bitcoin SegWit (BTC), Bitcoin +-- Cash (BCH), and corresponding public test and private regression test networks. +module Haskoin.Network.Constants + ( -- * Constants + btc, + btcTest, + btcRegTest, + bch, + bchTest, + bchTest4, + bchRegTest, + allNets, + netByName, + ) +where + +import Control.DeepSeq +import Data.Binary (Binary (..)) +import Data.ByteString (ByteString) +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.List +import Data.Maybe +import Data.Serialize (Serialize (..)) +import Data.String +import Data.Text (Text) +import Data.Word (Word32, Word64, Word8) +import GHC.Generics (Generic) +import Haskoin.Block +import Haskoin.Network.Common +import Haskoin.Network.Data +import Haskoin.Transaction +import Text.Read + +-- | Version of Haskoin Core package. +versionString :: (IsString a) => a + +#ifdef CURRENT_PACKAGE_VERSION +versionString = CURRENT_PACKAGE_VERSION +#else +versionString = "Unavailable" +#endif + +-- | Query known networks by name. +netByName :: String -> Maybe Network +netByName str = find ((== str) . (.name)) allNets + +-- | Bitcoin SegWit network. Symbol: BTC. +btc :: Network +btc = + Network + { name = "btc", + addrPrefix = 0, + scriptPrefix = 5, + secretPrefix = 128, + xPubPrefix = 0x0488b21e, + xPrvPrefix = 0x0488ade4, + magic = 0xf9beb4d9, + genesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1231006505 + 0x1d00ffff + 2083236893, + -- Hash 000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f + maxBlockSize = 1000000, + maxSatoshi = 2100000000000000, + userAgent = + "/haskoin-btc:" <> versionString <> "/", + defaultPort = 8333, + minDiffBlocks = False, + powNoRetarget = False, + powLimit = + 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff, + bip34Block = + ( 227931, + "000000000000024b89b42a942fe0d9fea3bb44ab7bd1b19115dd6a759c0808b8" + ), + bip65Height = 388381, + bip66Height = 363725, + targetTimespan = 14 * 24 * 60 * 60, + targetSpacing = 10 * 60, + checkpoints = + [ ( 11111, + "0000000069e244f73d78e8fd29ba2fd2ed618bd6fa2ee92559f542fdb26e7c1d" + ), + ( 33333, + "000000002dd5588a74784eaa7ab0507a18ad16a236e7b1ce69f00d7ddfb5d0a6" + ), + ( 74000, + "0000000000573993a3c9e41ce34471c079dcf5f52a0e824a81e7f953b8661a20" + ), + ( 105000, + "00000000000291ce28027faea320c8d2b054b2e0fe44a773f3eefb151d6bdc97" + ), + ( 134444, + "00000000000005b12ffd4cd315cd34ffd4a594f430ac814c91184a0d42d2b0fe" + ), + ( 168000, + "000000000000099e61ea72015e79632f216fe6cb33d7899acb35b75c8303b763" + ), + ( 193000, + "000000000000059f452a5f7340de6682a977387c17010ff6e6c3bd83ca8b1317" + ), + ( 210000, + "000000000000048b95347e83192f69cf0366076336c639f9b7228e9ba171342e" + ), + ( 216116, + "00000000000001b4f4b433e81ee46494af945cf96014816a4e2370f11b23df4e" + ), + ( 225430, + "00000000000001c108384350f74090433e7fcf79a606b8e797f065b130575932" + ), + ( 250000, + "000000000000003887df1f29024b06fc2200b55f8af8f35453d7be294df2d214" + ), + ( 279000, + "0000000000000001ae8c72a0b0c301f67e3afca10e819efa9041e458e9bd7e40" + ), + ( 295000, + "00000000000000004d9b4ef50f0f9d686fd69db2e03af35a100370c64632a983" + ) + ], + seeds = + [ "seed.bitcoin.sipa.be", -- Pieter Wuille + "dnsseed.bluematt.me", -- Matt Corallo + "dnsseed.bitcoin.dashjr.org", -- Luke Dashjr + "seed.bitcoinstats.com", -- Chris Decker + "seed.bitcoin.jonasschnelli.ch", -- Jonas Schnelli + "seed.btc.petertodd.org", -- Peter Todd + "seed.bitcoin.sprovoost.nl", -- Sjors Provoost + "dnsseed.emzy.de", -- Stephan Oeste + "seed.bitcoin.wiz.biz" -- Jason Maurice + ], + bip44Coin = 0, + sigHashForkId = Nothing, + edaHeight = Nothing, + daaHeight = Nothing, + asertActivationTime = Nothing, + asertHalfLife = 0, + segWit = True, + cashAddrPrefix = Nothing, + bech32Prefix = Just "bc", + replaceByFee = True, + halvingInterval = 210000 + } + +-- | Testnet for Bitcoin SegWit network. +btcTest :: Network +btcTest = + Network + { name = "btctest", + addrPrefix = 111, + scriptPrefix = 196, + secretPrefix = 239, + xPubPrefix = 0x043587cf, + xPrvPrefix = 0x04358394, + magic = 0x0b110907, + genesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1296688602 + 486604799 + 414098458, + -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 + maxBlockSize = 1000000, + maxSatoshi = 2100000000000000, + userAgent = "/haskoin-btc-test:" <> versionString <> "/", + defaultPort = 18333, + minDiffBlocks = True, + powNoRetarget = False, + powLimit = + 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff, + bip34Block = + ( 21111, + "0000000023b3a96d3484e5abb3755c413e7d41500f8e2a5c3f0dd01299cd8ef8" + ), + bip65Height = 581885, + bip66Height = 330776, + targetTimespan = 14 * 24 * 60 * 60, + targetSpacing = 10 * 60, + checkpoints = + [ ( 546, + "000000002a936ca763904c3c35fce2f3556c559c0214345d31b1bcebf76acb70" + ) + ], + seeds = + [ "testnet-seed.bitcoin.jonasschnelli.ch", + "seed.tbtc.petertodd.org", + "seed.testnet.bitcoin.sprovoost.nl", + "testnet-seed.bluematt.me" + ], + bip44Coin = 1, + sigHashForkId = Nothing, + edaHeight = Nothing, + daaHeight = Nothing, + asertActivationTime = Nothing, + asertHalfLife = 0, + segWit = True, + cashAddrPrefix = Nothing, + bech32Prefix = Just "tb", + replaceByFee = True, + halvingInterval = 210000 + } + +-- | RegTest for Bitcoin SegWit network. +btcRegTest :: Network +btcRegTest = + Network + { name = "btcreg", + addrPrefix = 111, + scriptPrefix = 196, + secretPrefix = 239, + xPubPrefix = 0x043587cf, + xPrvPrefix = 0x04358394, + magic = 0xfabfb5da, + genesisHeader = + BlockHeader + -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1296688602 + 0x207fffff + 2, + maxBlockSize = 1000000, + maxSatoshi = 2100000000000000, + userAgent = "/haskoin-btc-regtest:" <> versionString <> "/", + defaultPort = 18444, + minDiffBlocks = True, + powNoRetarget = True, + powLimit = + 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff, + bip34Block = + ( 100000000, + "0000000000000000000000000000000000000000000000000000000000000000" + ), + bip65Height = 1351, + bip66Height = 1251, + targetTimespan = 14 * 24 * 60 * 60, + targetSpacing = 10 * 60, + checkpoints = [], + seeds = ["localhost"], + bip44Coin = 1, + sigHashForkId = Nothing, + edaHeight = Nothing, + daaHeight = Nothing, + asertActivationTime = Nothing, + asertHalfLife = 0, + segWit = True, + cashAddrPrefix = Nothing, + bech32Prefix = Just "bcrt", + replaceByFee = True, + halvingInterval = 150 + } + +-- | Bitcoin Cash network. Symbol: BCH. +bch :: Network +bch = + Network + { name = "bch", + addrPrefix = 0, + scriptPrefix = 5, + secretPrefix = 128, + xPubPrefix = 0x0488b21e, + xPrvPrefix = 0x0488ade4, + magic = 0xe3e1f3e8, + genesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1231006505 + 0x1d00ffff + 2083236893, + -- Hash 000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f + maxBlockSize = 32000000, + maxSatoshi = 2100000000000000, + userAgent = "/haskoin-bch:" <> versionString <> "/", + defaultPort = 8333, + minDiffBlocks = False, + powNoRetarget = False, + powLimit = + 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff, + bip34Block = + ( 227931, + "000000000000024b89b42a942fe0d9fea3bb44ab7bd1b19115dd6a759c0808b8" + ), + bip65Height = 388381, + bip66Height = 363725, + targetTimespan = 14 * 24 * 60 * 60, + targetSpacing = 10 * 60, + checkpoints = + [ ( 11111, + "0000000069e244f73d78e8fd29ba2fd2ed618bd6fa2ee92559f542fdb26e7c1d" + ), + ( 33333, + "000000002dd5588a74784eaa7ab0507a18ad16a236e7b1ce69f00d7ddfb5d0a6" + ), + ( 74000, + "0000000000573993a3c9e41ce34471c079dcf5f52a0e824a81e7f953b8661a20" + ), + ( 105000, + "00000000000291ce28027faea320c8d2b054b2e0fe44a773f3eefb151d6bdc97" + ), + ( 134444, + "00000000000005b12ffd4cd315cd34ffd4a594f430ac814c91184a0d42d2b0fe" + ), + ( 168000, + "000000000000099e61ea72015e79632f216fe6cb33d7899acb35b75c8303b763" + ), + ( 193000, + "000000000000059f452a5f7340de6682a977387c17010ff6e6c3bd83ca8b1317" + ), + ( 210000, + "000000000000048b95347e83192f69cf0366076336c639f9b7228e9ba171342e" + ), + ( 216116, + "00000000000001b4f4b433e81ee46494af945cf96014816a4e2370f11b23df4e" + ), + ( 225430, + "00000000000001c108384350f74090433e7fcf79a606b8e797f065b130575932" + ), + ( 250000, + "000000000000003887df1f29024b06fc2200b55f8af8f35453d7be294df2d214" + ), + ( 279000, + "0000000000000001ae8c72a0b0c301f67e3afca10e819efa9041e458e9bd7e40" + ), + ( 295000, + "00000000000000004d9b4ef50f0f9d686fd69db2e03af35a100370c64632a983" + ), + -- UAHF fork block. + + ( 478559, + "000000000000000000651ef99cb9fcbe0dadde1d424bd9f15ff20136191a5eec" + ), + -- Nov, 13 DAA activation block. + + ( 504031, + "0000000000000000011ebf65b60d0a3de80b8175be709d653b4c1a1beeb6ab9c" + ) + ], + seeds = + [ "seed.bitcoinabc.org", + "seed-bch.bitcoinforks.org", + "btccash-seeder.bitcoinunlimited.info", + "seed.bchd.cash", + "seed.bch.loping.net", + "dnsseed.electroncash.de" + ], + bip44Coin = 145, + sigHashForkId = Just 0, + edaHeight = Just 478559, + daaHeight = Just 404031, + asertActivationTime = Just 1605441600, + asertHalfLife = 60 * 60 * 10, + segWit = False, + cashAddrPrefix = Just "bitcoincash", + bech32Prefix = Nothing, + replaceByFee = False, + halvingInterval = 210000 + } + +-- | Testnet for Bitcoin Cash network. +bchTest4 :: Network +bchTest4 = + Network + { name = "bchtest4", + addrPrefix = 111, + scriptPrefix = 196, + secretPrefix = 239, + xPubPrefix = 0x043587cf, + xPrvPrefix = 0x04358394, + magic = 0xe2b7daaf, + genesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1597811185 + 0x1d00ffff + 114152193, + -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 + maxBlockSize = 2000000, + maxSatoshi = 2100000000000000, + userAgent = "/haskoin-bch-test4:" <> versionString <> "/", + defaultPort = 28333, + minDiffBlocks = True, + powNoRetarget = False, + powLimit = + 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff, + bip34Block = + ( 2, + "00000000b0c65b1e03baace7d5c093db0d6aac224df01484985ffd5e86a1a20c" + ), + bip65Height = 3, + bip66Height = 4, + targetTimespan = 14 * 24 * 60 * 60, + targetSpacing = 10 * 60, + checkpoints = + [ ( 5000, + "000000009f092d074574a216faec682040a853c4f079c33dfd2c3ef1fd8108c4" + ), + -- Axion activation + + ( 16845, + "00000000fb325b8f34fe80c96a5f708a08699a68bbab82dba4474d86bd743077" + ), + ( 38000, + "000000000015197537e59f339e3b1bbf81a66f691bd3d7aa08560fc7bf5113fb" + ), + ( 54700, + "00000000009af4379d87f17d0f172ee4769b48839a5a3a3e81d69da4322518b8" + ) + ], + seeds = + [ "testnet4-seed-bch.bitcoinforks.org", + "testnet4-seed-bch.toom.im", + "seed.tbch4.loping.net", + "testnet4-seed.flowee.cash" + ], + bip44Coin = 1, + sigHashForkId = Just 0, + edaHeight = Just 7, + daaHeight = Just 3000, + asertActivationTime = Just 1605441600, + asertHalfLife = 60 * 60, + segWit = False, + cashAddrPrefix = Just "bchtest", + bech32Prefix = Nothing, + replaceByFee = False, + halvingInterval = 210000 + } + +-- | Testnet for Bitcoin Cash network. +bchTest :: Network +bchTest = + Network + { name = "bchtest", + addrPrefix = 111, + scriptPrefix = 196, + secretPrefix = 239, + xPubPrefix = 0x043587cf, + xPrvPrefix = 0x04358394, + magic = 0xf4e5f3f4, + genesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1296688602 + 486604799 + 414098458, + -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 + maxBlockSize = 32000000, + maxSatoshi = 2100000000000000, + userAgent = "/haskoin-bch-test:" <> versionString <> "/", + defaultPort = 18333, + minDiffBlocks = True, + powNoRetarget = False, + powLimit = + 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff, + bip34Block = + ( 21111, + "0000000023b3a96d3484e5abb3755c413e7d41500f8e2a5c3f0dd01299cd8ef8" + ), + bip65Height = 581885, + bip66Height = 330776, + targetTimespan = 14 * 24 * 60 * 60, + targetSpacing = 10 * 60, + checkpoints = + [ ( 546, + "000000002a936ca763904c3c35fce2f3556c559c0214345d31b1bcebf76acb70" + ), + -- UAHF fork block. + + ( 1155876, + "00000000000e38fef93ed9582a7df43815d5c2ba9fd37ef70c9a0ea4a285b8f5" + ), + -- Nov, 13. DAA activation block. + + ( 1188697, + "0000000000170ed0918077bde7b4d36cc4c91be69fa09211f748240dabe047fb" + ) + ], + seeds = + [ "testnet-seed.bitcoinabc.org", + "testnet-seed-bch.bitcoinforks.org", + "testnet-seed.bchd.cash", + "seed.tbch.loping.net" + ], + bip44Coin = 1, + sigHashForkId = Just 0, + edaHeight = Just 1155876, + daaHeight = Just 1188697, + asertActivationTime = Just 1605441600, + asertHalfLife = 60 * 60, + segWit = False, + cashAddrPrefix = Just "bchtest", + bech32Prefix = Nothing, + replaceByFee = False, + halvingInterval = 210000 + } + +-- | RegTest for Bitcoin Cash network. +bchRegTest :: Network +bchRegTest = + Network + { name = "bchreg", + addrPrefix = 111, + scriptPrefix = 196, + secretPrefix = 239, + xPubPrefix = 0x043587cf, + xPrvPrefix = 0x04358394, + magic = 0xdab5bffa, + genesisHeader = + BlockHeader + -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1296688602 + 0x207fffff + 2, + maxBlockSize = 1000000, + maxSatoshi = 2100000000000000, + userAgent = "/haskoin-bch-regtest:" <> versionString <> "/", + defaultPort = 18444, + minDiffBlocks = True, + powNoRetarget = True, + powLimit = + 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff, + bip34Block = + ( 100000000, + "0000000000000000000000000000000000000000000000000000000000000000" + ), + bip65Height = 1351, + bip66Height = 1251, + targetTimespan = 14 * 24 * 60 * 60, + targetSpacing = 10 * 60, + checkpoints = + [ ( 0, + "0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206" + ) + ], + seeds = ["localhost"], + bip44Coin = 1, + sigHashForkId = Just 0, + edaHeight = Nothing, + daaHeight = Just 0, + asertActivationTime = Just 1605441600, + asertHalfLife = 2 * 24 * 60 * 60, + segWit = False, + cashAddrPrefix = Just "bchreg", + bech32Prefix = Nothing, + replaceByFee = False, + halvingInterval = 150 + } + +-- | List of all networks supported by this library. +allNets :: [Network] +allNets = [btc, bch, btcTest, bchTest4, bchTest, btcRegTest, bchRegTest] diff --git a/src/Haskoin/Network/Data.hs b/src/Haskoin/Network/Data.hs new file mode 100644 index 00000000..361849c8 --- /dev/null +++ b/src/Haskoin/Network/Data.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Haskoin.Network.Data + ( Network (..), + ) +where + +import Control.DeepSeq +import Data.Binary (Binary (..)) +import Data.ByteString (ByteString) +import Data.Serialize (Serialize (..)) +import Data.Text (Text) +import Data.Word (Word32, Word64, Word8) +import GHC.Generics (Generic) +import Haskoin.Block.Common + +-- | Network definition. +data Network = Network + { -- | lowercase alphanumeric and dashes + name :: !String, + -- | prefix for 'Base58' P2PKH addresses + addrPrefix :: !Word8, + -- | prefix for 'Base58' P2SH addresses + scriptPrefix :: !Word8, + -- | prefix for WIF private key + secretPrefix :: !Word8, + -- | prefix for extended public key + xPubPrefix :: !Word32, + -- | prefix for extended private key + xPrvPrefix :: !Word32, + -- | network magic + magic :: !Word32, + -- | genesis block header + genesisHeader :: !BlockHeader, + -- | maximum block size in bytes + maxBlockSize :: !Int, + -- | maximum amount of satoshi + maxSatoshi :: !Word64, + -- | user agent string + userAgent :: !ByteString, + -- | default port for P2P connections + defaultPort :: !Int, + -- | allow min difficulty blocks (testnet) + minDiffBlocks :: !Bool, + -- | do not retarget difficulty (regtest) + powNoRetarget :: !Bool, + -- | proof-of-work target higest possible value + powLimit :: !Integer, + -- | block at which BIP34 activates + bip34Block :: !(BlockHeight, BlockHash), + -- | block at which BIP65 activates + bip65Height :: !BlockHeight, + -- | block at which BIP66 activates + bip66Height :: !BlockHeight, + -- | time between difficulty retargets + targetTimespan :: !Word32, + -- | time between blocks + targetSpacing :: !Word32, + -- | checkpoints + checkpoints :: ![(BlockHeight, BlockHash)], + -- | BIP44 derivation path root + bip44Coin :: !Word32, + -- | peer-to-peer network seeds + seeds :: ![String], + -- | fork id for replay protection + sigHashForkId :: !(Maybe Word32), + -- | EDA start block height + edaHeight :: !(Maybe Word32), + -- | DAA start block height + daaHeight :: !(Maybe Word32), + -- | asert3-2d algorithm activation time + -- TODO: Replace with block height after fork + asertActivationTime :: !(Maybe Word32), + -- | asert3-2d algorithm halflife (not used for non-BCH networks) + asertHalfLife :: !Integer, + -- | segregated witness active + segWit :: !Bool, + -- | 'CashAddr' prefix (for Bitcoin Cash) + cashAddrPrefix :: !(Maybe Text), + -- | 'Bech32' prefix (for SegWit network) + bech32Prefix :: !(Maybe Text), + -- | Replace-By-Fee (BIP-125) + replaceByFee :: !Bool, + -- | Subsidy halving interval + halvingInterval :: !Word32 + } + deriving (Eq, Show, Read, Generic, NFData) diff --git a/src/Haskoin/Network/Message.hs b/src/Haskoin/Network/Message.hs index ba26b84c..d58e512f 100644 --- a/src/Haskoin/Network/Message.hs +++ b/src/Haskoin/Network/Message.hs @@ -1,30 +1,34 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Network.Message -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Peer-to-peer network message serialization. --} -module Haskoin.Network.Message ( - -- * Network Message +-- | +-- Module : Haskoin.Network.Message +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Peer-to-peer network message serialization. +module Haskoin.Network.Message + ( -- * Network Message Message (..), MessageHeader (..), msgType, putMessage, getMessage, -) where + ) +where import Control.DeepSeq import Control.Monad (unless) import Data.Binary (Binary (..)) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as B import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -34,80 +38,78 @@ import GHC.Generics (Generic) import Haskoin.Block.Common import Haskoin.Block.Merkle import Haskoin.Crypto.Hash -import Haskoin.Data import Haskoin.Network.Bloom import Haskoin.Network.Common +import Haskoin.Network.Data import Haskoin.Transaction.Common -{- | Data type representing the header of a 'Message'. All messages sent between - nodes contain a message header. --} +-- | Data type representing the header of a 'Message'. All messages sent between +-- nodes contain a message header. data MessageHeader = MessageHeader - { -- | magic bytes identify network - headMagic :: !Word32 - , -- | message type - headCmd :: !MessageCommand - , -- | length of payload - headPayloadSize :: !Word32 - , -- | checksum of payload - headChecksum :: !CheckSum32 - } - deriving (Eq, Show, Generic, NFData) + { -- | magic bytes identify network + magic :: !Word32, + -- | message type + cmd :: !MessageCommand, + -- | length of payload + size :: !Word32, + -- | checksum of payload + checksum :: !CheckSum32 + } + deriving (Eq, Show, Generic, NFData) instance Serial MessageHeader where - deserialize = - MessageHeader - <$> getWord32be - <*> deserialize - <*> getWord32le - <*> deserialize + deserialize = + MessageHeader + <$> getWord32be + <*> deserialize + <*> getWord32le + <*> deserialize - serialize (MessageHeader m c l chk) = do - putWord32be m - serialize c - putWord32le l - serialize chk + serialize (MessageHeader m c l chk) = do + putWord32be m + serialize c + putWord32le l + serialize chk instance Binary MessageHeader where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize MessageHeader where - put = serialize - get = deserialize + put = serialize + get = deserialize -{- | The 'Message' type is used to identify all the valid messages that can be - sent between bitcoin peers. Only values of type 'Message' will be accepted - by other bitcoin peers as bitcoin protocol messages need to be correctly - serialized with message headers. Serializing a 'Message' value will - include the 'MessageHeader' with the correct checksum value automatically. - No need to add the 'MessageHeader' separately. --} +-- | The 'Message' type is used to identify all the valid messages that can be +-- sent between bitcoin peers. Only values of type 'Message' will be accepted +-- by other bitcoin peers as bitcoin protocol messages need to be correctly +-- serialized with message headers. Serializing a 'Message' value will +-- include the 'MessageHeader' with the correct checksum value automatically. +-- No need to add the 'MessageHeader' separately. data Message - = MVersion !Version - | MVerAck - | MAddr !Addr - | MInv !Inv - | MGetData !GetData - | MNotFound !NotFound - | MGetBlocks !GetBlocks - | MGetHeaders !GetHeaders - | MTx !Tx - | MBlock !Block - | MMerkleBlock !MerkleBlock - | MHeaders !Headers - | MGetAddr - | MFilterLoad !FilterLoad - | MFilterAdd !FilterAdd - | MFilterClear - | MPing !Ping - | MPong !Pong - | MAlert !Alert - | MMempool - | MReject !Reject - | MSendHeaders - | MOther !ByteString !ByteString - deriving (Eq, Show, Generic, NFData) + = MVersion !Version + | MVerAck + | MAddr !Addr + | MInv !Inv + | MGetData !GetData + | MNotFound !NotFound + | MGetBlocks !GetBlocks + | MGetHeaders !GetHeaders + | MTx !Tx + | MBlock !Block + | MMerkleBlock !MerkleBlock + | MHeaders !Headers + | MGetAddr + | MFilterLoad !FilterLoad + | MFilterAdd !FilterAdd + | MFilterClear + | MPing !Ping + | MPong !Pong + | MAlert !Alert + | MMempool + | MReject !Reject + | MSendHeaders + | MOther !ByteString !ByteString + deriving (Eq, Show, Generic, NFData) -- | Get 'MessageCommand' assocated with a message. msgType :: Message -> MessageCommand @@ -136,85 +138,87 @@ msgType MGetAddr = MCGetAddr msgType (MOther c _) = MCOther c -- | Deserializer for network messages. -getMessage :: MonadGet m => Network -> m Message +getMessage :: (MonadGet m) => Network -> m Message getMessage net = do - (MessageHeader mgc cmd len chk) <- deserialize - bs <- lookAhead $ getByteString $ fromIntegral len - unless - (mgc == getNetworkMagic net) - (fail $ "get: Invalid network magic bytes: " ++ show mgc) - unless - (checkSum32 bs == chk) - (fail $ "get: Invalid message checksum: " ++ show chk) - if len > 0 - then do - bs <- ensure (fromIntegral len) - let f = case cmd of - MCVersion -> MVersion <$> deserialize - MCAddr -> MAddr <$> deserialize - MCInv -> MInv <$> deserialize - MCGetData -> MGetData <$> deserialize - MCNotFound -> MNotFound <$> deserialize - MCGetBlocks -> MGetBlocks <$> deserialize - MCGetHeaders -> MGetHeaders <$> deserialize - MCTx -> MTx <$> deserialize - MCBlock -> MBlock <$> deserialize - MCMerkleBlock -> MMerkleBlock <$> deserialize - MCHeaders -> MHeaders <$> deserialize - MCFilterLoad -> MFilterLoad <$> deserialize - MCFilterAdd -> MFilterAdd <$> deserialize - MCPing -> MPing <$> deserialize - MCPong -> MPong <$> deserialize - MCAlert -> MAlert <$> deserialize - MCReject -> MReject <$> deserialize - MCOther c -> MOther c <$> getByteString (fromIntegral len) - _ -> - fail $ - "get: command " ++ show cmd - ++ " should not carry a payload" - either fail return (runGetS f bs) - else case cmd of - MCGetAddr -> return MGetAddr - MCVerAck -> return MVerAck - MCFilterClear -> return MFilterClear - MCMempool -> return MMempool - MCSendHeaders -> return MSendHeaders - MCOther c -> return (MOther c BS.empty) + (MessageHeader mgc cmd len chk) <- deserialize + bs <- lookAhead $ getByteString $ fromIntegral len + unless + (mgc == net.magic) + (fail $ "get: Invalid network magic bytes: " ++ show mgc) + unless + (checkSum32 bs == chk) + (fail $ "get: Invalid message checksum: " ++ show chk) + if len > 0 + then do + bs <- ensure (fromIntegral len) + let f = case cmd of + MCVersion -> MVersion <$> deserialize + MCAddr -> MAddr <$> deserialize + MCInv -> MInv <$> deserialize + MCGetData -> MGetData <$> deserialize + MCNotFound -> MNotFound <$> deserialize + MCGetBlocks -> MGetBlocks <$> deserialize + MCGetHeaders -> MGetHeaders <$> deserialize + MCTx -> MTx <$> deserialize + MCBlock -> MBlock <$> deserialize + MCMerkleBlock -> MMerkleBlock <$> deserialize + MCHeaders -> MHeaders <$> deserialize + MCFilterLoad -> MFilterLoad <$> deserialize + MCFilterAdd -> MFilterAdd <$> deserialize + MCPing -> MPing <$> deserialize + MCPong -> MPong <$> deserialize + MCAlert -> MAlert <$> deserialize + MCReject -> MReject <$> deserialize + MCOther c -> MOther c <$> getByteString (fromIntegral len) _ -> - fail $ - "get: command " ++ show cmd - ++ " is expected to carry a payload" + fail $ + "get: command " + ++ show cmd + ++ " should not carry a payload" + either fail return (runGetS f bs) + else case cmd of + MCGetAddr -> return MGetAddr + MCVerAck -> return MVerAck + MCFilterClear -> return MFilterClear + MCMempool -> return MMempool + MCSendHeaders -> return MSendHeaders + MCOther c -> return (MOther c B.empty) + _ -> + fail $ + "get: command " + ++ show cmd + ++ " is expected to carry a payload" -- | Serializer for network messages. -putMessage :: MonadPut m => Network -> Message -> m () +putMessage :: (MonadPut m) => Network -> Message -> m () putMessage net msg = do - let (cmd, payload) = - case msg of - MVersion m -> (MCVersion, runPutS $ serialize m) - MVerAck -> (MCVerAck, BS.empty) - MAddr m -> (MCAddr, runPutS $ serialize m) - MInv m -> (MCInv, runPutS $ serialize m) - MGetData m -> (MCGetData, runPutS $ serialize m) - MNotFound m -> (MCNotFound, runPutS $ serialize m) - MGetBlocks m -> (MCGetBlocks, runPutS $ serialize m) - MGetHeaders m -> (MCGetHeaders, runPutS $ serialize m) - MTx m -> (MCTx, runPutS $ serialize m) - MBlock m -> (MCBlock, runPutS $ serialize m) - MMerkleBlock m -> (MCMerkleBlock, runPutS $ serialize m) - MHeaders m -> (MCHeaders, runPutS $ serialize m) - MGetAddr -> (MCGetAddr, BS.empty) - MFilterLoad m -> (MCFilterLoad, runPutS $ serialize m) - MFilterAdd m -> (MCFilterAdd, runPutS $ serialize m) - MFilterClear -> (MCFilterClear, BS.empty) - MPing m -> (MCPing, runPutS $ serialize m) - MPong m -> (MCPong, runPutS $ serialize m) - MAlert m -> (MCAlert, runPutS $ serialize m) - MMempool -> (MCMempool, BS.empty) - MReject m -> (MCReject, runPutS $ serialize m) - MSendHeaders -> (MCSendHeaders, BS.empty) - MOther c p -> (MCOther c, p) - chk = checkSum32 payload - len = fromIntegral $ BS.length payload - header = MessageHeader (getNetworkMagic net) cmd len chk - serialize header - putByteString payload + let (cmd, payload) = + case msg of + MVersion m -> (MCVersion, runPutS $ serialize m) + MVerAck -> (MCVerAck, B.empty) + MAddr m -> (MCAddr, runPutS $ serialize m) + MInv m -> (MCInv, runPutS $ serialize m) + MGetData m -> (MCGetData, runPutS $ serialize m) + MNotFound m -> (MCNotFound, runPutS $ serialize m) + MGetBlocks m -> (MCGetBlocks, runPutS $ serialize m) + MGetHeaders m -> (MCGetHeaders, runPutS $ serialize m) + MTx m -> (MCTx, runPutS $ serialize m) + MBlock m -> (MCBlock, runPutS $ serialize m) + MMerkleBlock m -> (MCMerkleBlock, runPutS $ serialize m) + MHeaders m -> (MCHeaders, runPutS $ serialize m) + MGetAddr -> (MCGetAddr, B.empty) + MFilterLoad m -> (MCFilterLoad, runPutS $ serialize m) + MFilterAdd m -> (MCFilterAdd, runPutS $ serialize m) + MFilterClear -> (MCFilterClear, B.empty) + MPing m -> (MCPing, runPutS $ serialize m) + MPong m -> (MCPong, runPutS $ serialize m) + MAlert m -> (MCAlert, runPutS $ serialize m) + MMempool -> (MCMempool, B.empty) + MReject m -> (MCReject, runPutS $ serialize m) + MSendHeaders -> (MCSendHeaders, B.empty) + MOther c p -> (MCOther c, p) + chk = checkSum32 payload + len = fromIntegral $ B.length payload + header = MessageHeader net.magic cmd len chk + serialize header + putByteString payload diff --git a/src/Haskoin/Script.hs b/src/Haskoin/Script.hs index ebda3302..f15932d1 100644 --- a/src/Haskoin/Script.hs +++ b/src/Haskoin/Script.hs @@ -1,20 +1,20 @@ -{- | -Module : Haskoin.Script -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module provides functions for parsing and evaluating bitcoin -transaction scripts. Data types are provided for building and -deconstructing all of the standard input and output script types. --} -module Haskoin.Script ( - module Common, +-- | +-- Module : Haskoin.Script +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- This module provides functions for parsing and evaluating bitcoin +-- transaction scripts. Data types are provided for building and +-- deconstructing all of the standard input and output script types. +module Haskoin.Script + ( module Common, module Standard, module SigHash, -) where + ) +where import Haskoin.Script.Common as Common import Haskoin.Script.SigHash as SigHash diff --git a/src/Haskoin/Script/Common.hs b/src/Haskoin/Script/Common.hs index 9e3b0cb5..42d7c3b0 100644 --- a/src/Haskoin/Script/Common.hs +++ b/src/Haskoin/Script/Common.hs @@ -1,19 +1,22 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Script.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common script-related functions and data types. --} -module Haskoin.Script.Common ( - -- * Scripts +-- | +-- Module : Haskoin.Script.Common +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Common script-related functions and data types. +module Haskoin.Script.Common + ( -- * Scripts ScriptOp (..), Script (..), PushDataType (..), @@ -21,13 +24,17 @@ module Haskoin.Script.Common ( opPushData, intToScriptOp, scriptOpToInt, -) where + ) +where import Control.DeepSeq import Control.Monad +import Data.Aeson +import Data.Aeson.Encoding import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B +import Data.ByteString.Builder (char7) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -36,546 +43,556 @@ import Data.Hashable import Data.Serialize (Serialize (..)) import Data.Word (Word8) import GHC.Generics (Generic) +import Haskoin.Util (hexBuilder) +import Haskoin.Util.Helpers (decodeHex, encodeHex, hexEncoding) -{- | Data type representing a transaction script. Scripts are defined as lists - of script operators 'ScriptOp'. Scripts are used to: - - * Define the spending conditions in the output of a transaction. - * Provide signatures in the input of a transaction (except SegWit). - - SigWit only: the segregated witness data structure, and not the input script, - contains signatures and redeem script for pay-to-witness-script and - pay-to-witness-public-key-hash transactions. --} +-- | Data type representing a transaction script. Scripts are defined as lists +-- of script operators 'ScriptOp'. Scripts are used to: +-- +-- * Define the spending conditions in the output of a transaction. +-- * Provide signatures in the input of a transaction (except SegWit). +-- +-- SigWit only: the segregated witness data structure, and not the input script, +-- contains signatures and redeem script for pay-to-witness-script and +-- pay-to-witness-public-key-hash transactions. newtype Script = Script - { -- | script operators defining this script - scriptOps :: [ScriptOp] - } - deriving (Eq, Show, Read, Generic, Hashable, NFData) + { -- | script operators defining this script + ops :: [ScriptOp] + } + deriving (Eq, Show, Read, Generic) + deriving newtype (Hashable, NFData) + +instance FromJSON Script where + parseJSON = withText "script" $ \t -> do + bs <- maybe mzero return (decodeHex t) + either fail return (runGetS deserialize bs) + +instance ToJSON Script where + toJSON = String . encodeHex . runPutS . serialize + toEncoding = hexEncoding . runPutL . serialize instance Serial Script where - deserialize = - Script <$> getScriptOps - where - getScriptOps = do - empty <- isEmpty - if empty - then return [] - else (:) <$> deserialize <*> getScriptOps + deserialize = + Script <$> getScriptOps + where + getScriptOps = do + empty <- isEmpty + if empty + then return [] + else (:) <$> deserialize <*> getScriptOps - serialize (Script ops) = forM_ ops serialize + serialize (Script ops) = forM_ ops serialize instance Binary Script where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize Script where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | Data type representing the type of an OP_PUSHDATA opcode. data PushDataType - = -- | next opcode bytes is data to be pushed - OPCODE - | -- | next byte contains number of bytes of data to be pushed - OPDATA1 - | -- | next two bytes contains number of bytes to be pushed - OPDATA2 - | -- | next four bytes contains the number of bytes to be pushed - OPDATA4 - deriving (Show, Read, Eq, Generic, Hashable, NFData) + = -- | next opcode bytes is data to be pushed + OPCODE + | -- | next byte contains number of bytes of data to be pushed + OPDATA1 + | -- | next two bytes contains number of bytes to be pushed + OPDATA2 + | -- | next four bytes contains the number of bytes to be pushed + OPDATA4 + deriving (Show, Read, Eq, Generic, Hashable, NFData) -- | Data type representing an operator allowed inside a 'Script'. data ScriptOp - = -- Pushing Data - OP_PUSHDATA - !ByteString - !PushDataType - | OP_0 - | OP_1NEGATE - | OP_RESERVED - | OP_1 - | OP_2 - | OP_3 - | OP_4 - | OP_5 - | OP_6 - | OP_7 - | OP_8 - | OP_9 - | OP_10 - | OP_11 - | OP_12 - | OP_13 - | OP_14 - | OP_15 - | OP_16 - | -- Flow control - OP_NOP - | OP_VER -- reserved - | OP_IF - | OP_NOTIF - | OP_VERIF -- resreved - | OP_VERNOTIF -- reserved - | OP_ELSE - | OP_ENDIF - | OP_VERIFY - | OP_RETURN - | -- Stack operations - OP_TOALTSTACK - | OP_FROMALTSTACK - | OP_IFDUP - | OP_DEPTH - | OP_DROP - | OP_DUP - | OP_NIP - | OP_OVER - | OP_PICK - | OP_ROLL - | OP_ROT - | OP_SWAP - | OP_TUCK - | OP_2DROP - | OP_2DUP - | OP_3DUP - | OP_2OVER - | OP_2ROT - | OP_2SWAP - | -- Splice - OP_CAT - | OP_SUBSTR - | OP_LEFT - | OP_RIGHT - | OP_SIZE - | -- Bitwise logic - OP_INVERT - | OP_AND - | OP_OR - | OP_XOR - | OP_EQUAL - | OP_EQUALVERIFY - | OP_RESERVED1 - | OP_RESERVED2 - | -- Arithmetic - OP_1ADD - | OP_1SUB - | OP_2MUL - | OP_2DIV - | OP_NEGATE - | OP_ABS - | OP_NOT - | OP_0NOTEQUAL - | OP_ADD - | OP_SUB - | OP_MUL - | OP_DIV - | OP_MOD - | OP_LSHIFT - | OP_RSHIFT - | OP_BOOLAND - | OP_BOOLOR - | OP_NUMEQUAL - | OP_NUMEQUALVERIFY - | OP_NUMNOTEQUAL - | OP_LESSTHAN - | OP_GREATERTHAN - | OP_LESSTHANOREQUAL - | OP_GREATERTHANOREQUAL - | OP_MIN - | OP_MAX - | OP_WITHIN - | -- Crypto - OP_RIPEMD160 - | OP_SHA1 - | OP_SHA256 - | OP_HASH160 - | OP_HASH256 - | OP_CODESEPARATOR - | OP_CHECKSIG - | OP_CHECKSIGVERIFY - | OP_CHECKMULTISIG - | OP_CHECKMULTISIGVERIFY - | -- Expansion - OP_NOP1 - | OP_CHECKLOCKTIMEVERIFY - | OP_CHECKSEQUENCEVERIFY - | OP_NOP4 - | OP_NOP5 - | OP_NOP6 - | OP_NOP7 - | OP_NOP8 - | OP_NOP9 - | OP_NOP10 - | -- Bitcoin Cash Nov 2018 hard fork - OP_CHECKDATASIG - | OP_CHECKDATASIGVERIFY - | -- Bitcoin Cash May 2020 hard fork - OP_REVERSEBYTES - | -- Other - OP_PUBKEYHASH - | OP_PUBKEY - | OP_INVALIDOPCODE !Word8 - deriving (Show, Read, Eq, Generic, Hashable, NFData) + = -- Pushing Data + OP_PUSHDATA + !ByteString + !PushDataType + | OP_0 + | OP_1NEGATE + | OP_RESERVED + | OP_1 + | OP_2 + | OP_3 + | OP_4 + | OP_5 + | OP_6 + | OP_7 + | OP_8 + | OP_9 + | OP_10 + | OP_11 + | OP_12 + | OP_13 + | OP_14 + | OP_15 + | OP_16 + | -- Flow control + OP_NOP + | OP_VER -- reserved + | OP_IF + | OP_NOTIF + | OP_VERIF -- resreved + | OP_VERNOTIF -- reserved + | OP_ELSE + | OP_ENDIF + | OP_VERIFY + | OP_RETURN + | -- Stack operations + OP_TOALTSTACK + | OP_FROMALTSTACK + | OP_IFDUP + | OP_DEPTH + | OP_DROP + | OP_DUP + | OP_NIP + | OP_OVER + | OP_PICK + | OP_ROLL + | OP_ROT + | OP_SWAP + | OP_TUCK + | OP_2DROP + | OP_2DUP + | OP_3DUP + | OP_2OVER + | OP_2ROT + | OP_2SWAP + | -- Splice + OP_CAT + | OP_SUBSTR + | OP_LEFT + | OP_RIGHT + | OP_SIZE + | -- Bitwise logic + OP_INVERT + | OP_AND + | OP_OR + | OP_XOR + | OP_EQUAL + | OP_EQUALVERIFY + | OP_RESERVED1 + | OP_RESERVED2 + | -- Arithmetic + OP_1ADD + | OP_1SUB + | OP_2MUL + | OP_2DIV + | OP_NEGATE + | OP_ABS + | OP_NOT + | OP_0NOTEQUAL + | OP_ADD + | OP_SUB + | OP_MUL + | OP_DIV + | OP_MOD + | OP_LSHIFT + | OP_RSHIFT + | OP_BOOLAND + | OP_BOOLOR + | OP_NUMEQUAL + | OP_NUMEQUALVERIFY + | OP_NUMNOTEQUAL + | OP_LESSTHAN + | OP_GREATERTHAN + | OP_LESSTHANOREQUAL + | OP_GREATERTHANOREQUAL + | OP_MIN + | OP_MAX + | OP_WITHIN + | -- Crypto + OP_RIPEMD160 + | OP_SHA1 + | OP_SHA256 + | OP_HASH160 + | OP_HASH256 + | OP_CODESEPARATOR + | OP_CHECKSIG + | OP_CHECKSIGVERIFY + | OP_CHECKMULTISIG + | OP_CHECKMULTISIGVERIFY + | -- Expansion + OP_NOP1 + | OP_CHECKLOCKTIMEVERIFY + | OP_CHECKSEQUENCEVERIFY + | OP_NOP4 + | OP_NOP5 + | OP_NOP6 + | OP_NOP7 + | OP_NOP8 + | OP_NOP9 + | OP_NOP10 + | -- Bitcoin Cash Nov 2018 hard fork + OP_CHECKDATASIG + | OP_CHECKDATASIGVERIFY + | -- Bitcoin Cash May 2020 hard fork + OP_REVERSEBYTES + | -- Other + OP_PUBKEYHASH + | OP_PUBKEY + | OP_INVALIDOPCODE !Word8 + deriving (Show, Read, Eq, Generic, Hashable, NFData) instance Serial ScriptOp where - deserialize = go . fromIntegral =<< getWord8 - where - go op - | op == 0x00 = return OP_0 - | op <= 0x4b = do - payload <- getByteString (fromIntegral op) - return $ OP_PUSHDATA payload OPCODE - | op == 0x4c = do - len <- getWord8 - payload <- getByteString (fromIntegral len) - return $ OP_PUSHDATA payload OPDATA1 - | op == 0x4d = do - len <- getWord16le - payload <- getByteString (fromIntegral len) - return $ OP_PUSHDATA payload OPDATA2 - | op == 0x4e = do - len <- getWord32le - payload <- getByteString (fromIntegral len) - return $ OP_PUSHDATA payload OPDATA4 - | op == 0x4f = return OP_1NEGATE - | op == 0x50 = return OP_RESERVED - | op == 0x51 = return OP_1 - | op == 0x52 = return OP_2 - | op == 0x53 = return OP_3 - | op == 0x54 = return OP_4 - | op == 0x55 = return OP_5 - | op == 0x56 = return OP_6 - | op == 0x57 = return OP_7 - | op == 0x58 = return OP_8 - | op == 0x59 = return OP_9 - | op == 0x5a = return OP_10 - | op == 0x5b = return OP_11 - | op == 0x5c = return OP_12 - | op == 0x5d = return OP_13 - | op == 0x5e = return OP_14 - | op == 0x5f = return OP_15 - | op == 0x60 = return OP_16 - -- Flow control - | op == 0x61 = return OP_NOP - | op == 0x62 = return OP_VER -- reserved - | op == 0x63 = return OP_IF - | op == 0x64 = return OP_NOTIF - | op == 0x65 = return OP_VERIF -- reserved - | op == 0x66 = return OP_VERNOTIF -- reserved - | op == 0x67 = return OP_ELSE - | op == 0x68 = return OP_ENDIF - | op == 0x69 = return OP_VERIFY - | op == 0x6a = return OP_RETURN - -- Stack - | op == 0x6b = return OP_TOALTSTACK - | op == 0x6c = return OP_FROMALTSTACK - | op == 0x6d = return OP_2DROP - | op == 0x6e = return OP_2DUP - | op == 0x6f = return OP_3DUP - | op == 0x70 = return OP_2OVER - | op == 0x71 = return OP_2ROT - | op == 0x72 = return OP_2SWAP - | op == 0x73 = return OP_IFDUP - | op == 0x74 = return OP_DEPTH - | op == 0x75 = return OP_DROP - | op == 0x76 = return OP_DUP - | op == 0x77 = return OP_NIP - | op == 0x78 = return OP_OVER - | op == 0x79 = return OP_PICK - | op == 0x7a = return OP_ROLL - | op == 0x7b = return OP_ROT - | op == 0x7c = return OP_SWAP - | op == 0x7d = return OP_TUCK - -- Splice - | op == 0x7e = return OP_CAT - | op == 0x7f = return OP_SUBSTR - | op == 0x80 = return OP_LEFT - | op == 0x81 = return OP_RIGHT - | op == 0x82 = return OP_SIZE - -- Bitwise logic - | op == 0x83 = return OP_INVERT - | op == 0x84 = return OP_AND - | op == 0x85 = return OP_OR - | op == 0x86 = return OP_XOR - | op == 0x87 = return OP_EQUAL - | op == 0x88 = return OP_EQUALVERIFY - | op == 0x89 = return OP_RESERVED1 - | op == 0x8a = return OP_RESERVED2 - -- Arithmetic - | op == 0x8b = return OP_1ADD - | op == 0x8c = return OP_1SUB - | op == 0x8d = return OP_2MUL - | op == 0x8e = return OP_2DIV - | op == 0x8f = return OP_NEGATE - | op == 0x90 = return OP_ABS - | op == 0x91 = return OP_NOT - | op == 0x92 = return OP_0NOTEQUAL - | op == 0x93 = return OP_ADD - | op == 0x94 = return OP_SUB - | op == 0x95 = return OP_MUL - | op == 0x96 = return OP_DIV - | op == 0x97 = return OP_MOD - | op == 0x98 = return OP_LSHIFT - | op == 0x99 = return OP_RSHIFT - | op == 0x9a = return OP_BOOLAND - | op == 0x9b = return OP_BOOLOR - | op == 0x9c = return OP_NUMEQUAL - | op == 0x9d = return OP_NUMEQUALVERIFY - | op == 0x9e = return OP_NUMNOTEQUAL - | op == 0x9f = return OP_LESSTHAN - | op == 0xa0 = return OP_GREATERTHAN - | op == 0xa1 = return OP_LESSTHANOREQUAL - | op == 0xa2 = return OP_GREATERTHANOREQUAL - | op == 0xa3 = return OP_MIN - | op == 0xa4 = return OP_MAX - | op == 0xa5 = return OP_WITHIN - -- Crypto - | op == 0xa6 = return OP_RIPEMD160 - | op == 0xa7 = return OP_SHA1 - | op == 0xa8 = return OP_SHA256 - | op == 0xa9 = return OP_HASH160 - | op == 0xaa = return OP_HASH256 - | op == 0xab = return OP_CODESEPARATOR - | op == 0xac = return OP_CHECKSIG - | op == 0xad = return OP_CHECKSIGVERIFY - | op == 0xae = return OP_CHECKMULTISIG - | op == 0xaf = return OP_CHECKMULTISIGVERIFY - -- More NOPs - | op == 0xb0 = return OP_NOP1 - | op == 0xb1 = return OP_CHECKLOCKTIMEVERIFY - | op == 0xb2 = return OP_CHECKSEQUENCEVERIFY - | op == 0xb3 = return OP_NOP4 - | op == 0xb4 = return OP_NOP5 - | op == 0xb5 = return OP_NOP6 - | op == 0xb6 = return OP_NOP7 - | op == 0xb7 = return OP_NOP8 - | op == 0xb8 = return OP_NOP9 - | op == 0xb9 = return OP_NOP10 - -- Bitcoin Cash Nov 2018 hard fork - | op == 0xba = return OP_CHECKDATASIG - | op == 0xbb = return OP_CHECKDATASIGVERIFY - -- Bitcoin Cash May 2020 hard fork - | op == 0xbc = return OP_REVERSEBYTES - -- Constants - | op == 0xfd = return OP_PUBKEYHASH - | op == 0xfe = return OP_PUBKEY - | otherwise = return $ OP_INVALIDOPCODE op - - serialize op = case op of - (OP_PUSHDATA payload optype) -> do - let len = B.length payload - case optype of - OPCODE -> do - unless (len <= 0x4b) $ - error "OP_PUSHDATA OPCODE: Payload size too big" - putWord8 $ fromIntegral len - OPDATA1 -> do - unless (len <= 0xff) $ - error "OP_PUSHDATA OPDATA1: Payload size too big" - putWord8 0x4c - putWord8 $ fromIntegral len - OPDATA2 -> do - unless (len <= 0xffff) $ - error "OP_PUSHDATA OPDATA2: Payload size too big" - putWord8 0x4d - putWord16le $ fromIntegral len - OPDATA4 -> do - unless (len <= 0x7fffffff) $ - error "OP_PUSHDATA OPDATA4: Payload size too big" - putWord8 0x4e - putWord32le $ fromIntegral len - putByteString payload - - -- Constants - OP_0 -> putWord8 0x00 - OP_1NEGATE -> putWord8 0x4f - OP_RESERVED -> putWord8 0x50 - OP_1 -> putWord8 0x51 - OP_2 -> putWord8 0x52 - OP_3 -> putWord8 0x53 - OP_4 -> putWord8 0x54 - OP_5 -> putWord8 0x55 - OP_6 -> putWord8 0x56 - OP_7 -> putWord8 0x57 - OP_8 -> putWord8 0x58 - OP_9 -> putWord8 0x59 - OP_10 -> putWord8 0x5a - OP_11 -> putWord8 0x5b - OP_12 -> putWord8 0x5c - OP_13 -> putWord8 0x5d - OP_14 -> putWord8 0x5e - OP_15 -> putWord8 0x5f - OP_16 -> putWord8 0x60 - -- Crypto Constants - OP_PUBKEY -> putWord8 0xfe - OP_PUBKEYHASH -> putWord8 0xfd - -- Invalid Opcodes - (OP_INVALIDOPCODE x) -> putWord8 x - -- Flow Control - OP_NOP -> putWord8 0x61 - OP_VER -> putWord8 0x62 - OP_IF -> putWord8 0x63 - OP_NOTIF -> putWord8 0x64 - OP_VERIF -> putWord8 0x65 - OP_VERNOTIF -> putWord8 0x66 - OP_ELSE -> putWord8 0x67 - OP_ENDIF -> putWord8 0x68 - OP_VERIFY -> putWord8 0x69 - OP_RETURN -> putWord8 0x6a - -- Stack Operations - OP_TOALTSTACK -> putWord8 0x6b - OP_FROMALTSTACK -> putWord8 0x6c - OP_2DROP -> putWord8 0x6d - OP_2DUP -> putWord8 0x6e - OP_3DUP -> putWord8 0x6f - OP_2OVER -> putWord8 0x70 - OP_2ROT -> putWord8 0x71 - OP_2SWAP -> putWord8 0x72 - OP_IFDUP -> putWord8 0x73 - OP_DEPTH -> putWord8 0x74 - OP_DROP -> putWord8 0x75 - OP_DUP -> putWord8 0x76 - OP_NIP -> putWord8 0x77 - OP_OVER -> putWord8 0x78 - OP_PICK -> putWord8 0x79 - OP_ROLL -> putWord8 0x7a - OP_ROT -> putWord8 0x7b - OP_SWAP -> putWord8 0x7c - OP_TUCK -> putWord8 0x7d + deserialize = go . fromIntegral =<< getWord8 + where + go op + | op == 0x00 = return OP_0 + | op <= 0x4b = do + payload <- getByteString (fromIntegral op) + return $ OP_PUSHDATA payload OPCODE + | op == 0x4c = do + len <- getWord8 + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload OPDATA1 + | op == 0x4d = do + len <- getWord16le + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload OPDATA2 + | op == 0x4e = do + len <- getWord32le + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload OPDATA4 + | op == 0x4f = return OP_1NEGATE + | op == 0x50 = return OP_RESERVED + | op == 0x51 = return OP_1 + | op == 0x52 = return OP_2 + | op == 0x53 = return OP_3 + | op == 0x54 = return OP_4 + | op == 0x55 = return OP_5 + | op == 0x56 = return OP_6 + | op == 0x57 = return OP_7 + | op == 0x58 = return OP_8 + | op == 0x59 = return OP_9 + | op == 0x5a = return OP_10 + | op == 0x5b = return OP_11 + | op == 0x5c = return OP_12 + | op == 0x5d = return OP_13 + | op == 0x5e = return OP_14 + | op == 0x5f = return OP_15 + | op == 0x60 = return OP_16 + -- Flow control + | op == 0x61 = return OP_NOP + | op == 0x62 = return OP_VER -- reserved + | op == 0x63 = return OP_IF + | op == 0x64 = return OP_NOTIF + | op == 0x65 = return OP_VERIF -- reserved + | op == 0x66 = return OP_VERNOTIF -- reserved + | op == 0x67 = return OP_ELSE + | op == 0x68 = return OP_ENDIF + | op == 0x69 = return OP_VERIFY + | op == 0x6a = return OP_RETURN + -- Stack + | op == 0x6b = return OP_TOALTSTACK + | op == 0x6c = return OP_FROMALTSTACK + | op == 0x6d = return OP_2DROP + | op == 0x6e = return OP_2DUP + | op == 0x6f = return OP_3DUP + | op == 0x70 = return OP_2OVER + | op == 0x71 = return OP_2ROT + | op == 0x72 = return OP_2SWAP + | op == 0x73 = return OP_IFDUP + | op == 0x74 = return OP_DEPTH + | op == 0x75 = return OP_DROP + | op == 0x76 = return OP_DUP + | op == 0x77 = return OP_NIP + | op == 0x78 = return OP_OVER + | op == 0x79 = return OP_PICK + | op == 0x7a = return OP_ROLL + | op == 0x7b = return OP_ROT + | op == 0x7c = return OP_SWAP + | op == 0x7d = return OP_TUCK -- Splice - OP_CAT -> putWord8 0x7e - OP_SUBSTR -> putWord8 0x7f - OP_LEFT -> putWord8 0x80 - OP_RIGHT -> putWord8 0x81 - OP_SIZE -> putWord8 0x82 - -- Bitwise Logic - OP_INVERT -> putWord8 0x83 - OP_AND -> putWord8 0x84 - OP_OR -> putWord8 0x85 - OP_XOR -> putWord8 0x86 - OP_EQUAL -> putWord8 0x87 - OP_EQUALVERIFY -> putWord8 0x88 - OP_RESERVED1 -> putWord8 0x89 - OP_RESERVED2 -> putWord8 0x8a + | op == 0x7e = return OP_CAT + | op == 0x7f = return OP_SUBSTR + | op == 0x80 = return OP_LEFT + | op == 0x81 = return OP_RIGHT + | op == 0x82 = return OP_SIZE + -- Bitwise logic + | op == 0x83 = return OP_INVERT + | op == 0x84 = return OP_AND + | op == 0x85 = return OP_OR + | op == 0x86 = return OP_XOR + | op == 0x87 = return OP_EQUAL + | op == 0x88 = return OP_EQUALVERIFY + | op == 0x89 = return OP_RESERVED1 + | op == 0x8a = return OP_RESERVED2 -- Arithmetic - OP_1ADD -> putWord8 0x8b - OP_1SUB -> putWord8 0x8c - OP_2MUL -> putWord8 0x8d - OP_2DIV -> putWord8 0x8e - OP_NEGATE -> putWord8 0x8f - OP_ABS -> putWord8 0x90 - OP_NOT -> putWord8 0x91 - OP_0NOTEQUAL -> putWord8 0x92 - OP_ADD -> putWord8 0x93 - OP_SUB -> putWord8 0x94 - OP_MUL -> putWord8 0x95 - OP_DIV -> putWord8 0x96 - OP_MOD -> putWord8 0x97 - OP_LSHIFT -> putWord8 0x98 - OP_RSHIFT -> putWord8 0x99 - OP_BOOLAND -> putWord8 0x9a - OP_BOOLOR -> putWord8 0x9b - OP_NUMEQUAL -> putWord8 0x9c - OP_NUMEQUALVERIFY -> putWord8 0x9d - OP_NUMNOTEQUAL -> putWord8 0x9e - OP_LESSTHAN -> putWord8 0x9f - OP_GREATERTHAN -> putWord8 0xa0 - OP_LESSTHANOREQUAL -> putWord8 0xa1 - OP_GREATERTHANOREQUAL -> putWord8 0xa2 - OP_MIN -> putWord8 0xa3 - OP_MAX -> putWord8 0xa4 - OP_WITHIN -> putWord8 0xa5 + | op == 0x8b = return OP_1ADD + | op == 0x8c = return OP_1SUB + | op == 0x8d = return OP_2MUL + | op == 0x8e = return OP_2DIV + | op == 0x8f = return OP_NEGATE + | op == 0x90 = return OP_ABS + | op == 0x91 = return OP_NOT + | op == 0x92 = return OP_0NOTEQUAL + | op == 0x93 = return OP_ADD + | op == 0x94 = return OP_SUB + | op == 0x95 = return OP_MUL + | op == 0x96 = return OP_DIV + | op == 0x97 = return OP_MOD + | op == 0x98 = return OP_LSHIFT + | op == 0x99 = return OP_RSHIFT + | op == 0x9a = return OP_BOOLAND + | op == 0x9b = return OP_BOOLOR + | op == 0x9c = return OP_NUMEQUAL + | op == 0x9d = return OP_NUMEQUALVERIFY + | op == 0x9e = return OP_NUMNOTEQUAL + | op == 0x9f = return OP_LESSTHAN + | op == 0xa0 = return OP_GREATERTHAN + | op == 0xa1 = return OP_LESSTHANOREQUAL + | op == 0xa2 = return OP_GREATERTHANOREQUAL + | op == 0xa3 = return OP_MIN + | op == 0xa4 = return OP_MAX + | op == 0xa5 = return OP_WITHIN -- Crypto - OP_RIPEMD160 -> putWord8 0xa6 - OP_SHA1 -> putWord8 0xa7 - OP_SHA256 -> putWord8 0xa8 - OP_HASH160 -> putWord8 0xa9 - OP_HASH256 -> putWord8 0xaa - OP_CODESEPARATOR -> putWord8 0xab - OP_CHECKSIG -> putWord8 0xac - OP_CHECKSIGVERIFY -> putWord8 0xad - OP_CHECKMULTISIG -> putWord8 0xae - OP_CHECKMULTISIGVERIFY -> putWord8 0xaf + | op == 0xa6 = return OP_RIPEMD160 + | op == 0xa7 = return OP_SHA1 + | op == 0xa8 = return OP_SHA256 + | op == 0xa9 = return OP_HASH160 + | op == 0xaa = return OP_HASH256 + | op == 0xab = return OP_CODESEPARATOR + | op == 0xac = return OP_CHECKSIG + | op == 0xad = return OP_CHECKSIGVERIFY + | op == 0xae = return OP_CHECKMULTISIG + | op == 0xaf = return OP_CHECKMULTISIGVERIFY -- More NOPs - OP_NOP1 -> putWord8 0xb0 - OP_CHECKLOCKTIMEVERIFY -> putWord8 0xb1 - OP_CHECKSEQUENCEVERIFY -> putWord8 0xb2 - OP_NOP4 -> putWord8 0xb3 - OP_NOP5 -> putWord8 0xb4 - OP_NOP6 -> putWord8 0xb5 - OP_NOP7 -> putWord8 0xb6 - OP_NOP8 -> putWord8 0xb7 - OP_NOP9 -> putWord8 0xb8 - OP_NOP10 -> putWord8 0xb9 + | op == 0xb0 = return OP_NOP1 + | op == 0xb1 = return OP_CHECKLOCKTIMEVERIFY + | op == 0xb2 = return OP_CHECKSEQUENCEVERIFY + | op == 0xb3 = return OP_NOP4 + | op == 0xb4 = return OP_NOP5 + | op == 0xb5 = return OP_NOP6 + | op == 0xb6 = return OP_NOP7 + | op == 0xb7 = return OP_NOP8 + | op == 0xb8 = return OP_NOP9 + | op == 0xb9 = return OP_NOP10 -- Bitcoin Cash Nov 2018 hard fork - OP_CHECKDATASIG -> putWord8 0xba - OP_CHECKDATASIGVERIFY -> putWord8 0xbb + | op == 0xba = return OP_CHECKDATASIG + | op == 0xbb = return OP_CHECKDATASIGVERIFY -- Bitcoin Cash May 2020 hard fork - OP_REVERSEBYTES -> putWord8 0xbc + | op == 0xbc = return OP_REVERSEBYTES + -- Constants + | op == 0xfd = return OP_PUBKEYHASH + | op == 0xfe = return OP_PUBKEY + | otherwise = return $ OP_INVALIDOPCODE op + + serialize op = case op of + (OP_PUSHDATA payload optype) -> do + let len = B.length payload + case optype of + OPCODE -> do + unless (len <= 0x4b) $ + error "OP_PUSHDATA OPCODE: Payload size too big" + putWord8 $ fromIntegral len + OPDATA1 -> do + unless (len <= 0xff) $ + error "OP_PUSHDATA OPDATA1: Payload size too big" + putWord8 0x4c + putWord8 $ fromIntegral len + OPDATA2 -> do + unless (len <= 0xffff) $ + error "OP_PUSHDATA OPDATA2: Payload size too big" + putWord8 0x4d + putWord16le $ fromIntegral len + OPDATA4 -> do + unless (len <= 0x7fffffff) $ + error "OP_PUSHDATA OPDATA4: Payload size too big" + putWord8 0x4e + putWord32le $ fromIntegral len + putByteString payload + + -- Constants + OP_0 -> putWord8 0x00 + OP_1NEGATE -> putWord8 0x4f + OP_RESERVED -> putWord8 0x50 + OP_1 -> putWord8 0x51 + OP_2 -> putWord8 0x52 + OP_3 -> putWord8 0x53 + OP_4 -> putWord8 0x54 + OP_5 -> putWord8 0x55 + OP_6 -> putWord8 0x56 + OP_7 -> putWord8 0x57 + OP_8 -> putWord8 0x58 + OP_9 -> putWord8 0x59 + OP_10 -> putWord8 0x5a + OP_11 -> putWord8 0x5b + OP_12 -> putWord8 0x5c + OP_13 -> putWord8 0x5d + OP_14 -> putWord8 0x5e + OP_15 -> putWord8 0x5f + OP_16 -> putWord8 0x60 + -- Crypto Constants + OP_PUBKEY -> putWord8 0xfe + OP_PUBKEYHASH -> putWord8 0xfd + -- Invalid Opcodes + (OP_INVALIDOPCODE x) -> putWord8 x + -- Flow Control + OP_NOP -> putWord8 0x61 + OP_VER -> putWord8 0x62 + OP_IF -> putWord8 0x63 + OP_NOTIF -> putWord8 0x64 + OP_VERIF -> putWord8 0x65 + OP_VERNOTIF -> putWord8 0x66 + OP_ELSE -> putWord8 0x67 + OP_ENDIF -> putWord8 0x68 + OP_VERIFY -> putWord8 0x69 + OP_RETURN -> putWord8 0x6a + -- Stack Operations + OP_TOALTSTACK -> putWord8 0x6b + OP_FROMALTSTACK -> putWord8 0x6c + OP_2DROP -> putWord8 0x6d + OP_2DUP -> putWord8 0x6e + OP_3DUP -> putWord8 0x6f + OP_2OVER -> putWord8 0x70 + OP_2ROT -> putWord8 0x71 + OP_2SWAP -> putWord8 0x72 + OP_IFDUP -> putWord8 0x73 + OP_DEPTH -> putWord8 0x74 + OP_DROP -> putWord8 0x75 + OP_DUP -> putWord8 0x76 + OP_NIP -> putWord8 0x77 + OP_OVER -> putWord8 0x78 + OP_PICK -> putWord8 0x79 + OP_ROLL -> putWord8 0x7a + OP_ROT -> putWord8 0x7b + OP_SWAP -> putWord8 0x7c + OP_TUCK -> putWord8 0x7d + -- Splice + OP_CAT -> putWord8 0x7e + OP_SUBSTR -> putWord8 0x7f + OP_LEFT -> putWord8 0x80 + OP_RIGHT -> putWord8 0x81 + OP_SIZE -> putWord8 0x82 + -- Bitwise Logic + OP_INVERT -> putWord8 0x83 + OP_AND -> putWord8 0x84 + OP_OR -> putWord8 0x85 + OP_XOR -> putWord8 0x86 + OP_EQUAL -> putWord8 0x87 + OP_EQUALVERIFY -> putWord8 0x88 + OP_RESERVED1 -> putWord8 0x89 + OP_RESERVED2 -> putWord8 0x8a + -- Arithmetic + OP_1ADD -> putWord8 0x8b + OP_1SUB -> putWord8 0x8c + OP_2MUL -> putWord8 0x8d + OP_2DIV -> putWord8 0x8e + OP_NEGATE -> putWord8 0x8f + OP_ABS -> putWord8 0x90 + OP_NOT -> putWord8 0x91 + OP_0NOTEQUAL -> putWord8 0x92 + OP_ADD -> putWord8 0x93 + OP_SUB -> putWord8 0x94 + OP_MUL -> putWord8 0x95 + OP_DIV -> putWord8 0x96 + OP_MOD -> putWord8 0x97 + OP_LSHIFT -> putWord8 0x98 + OP_RSHIFT -> putWord8 0x99 + OP_BOOLAND -> putWord8 0x9a + OP_BOOLOR -> putWord8 0x9b + OP_NUMEQUAL -> putWord8 0x9c + OP_NUMEQUALVERIFY -> putWord8 0x9d + OP_NUMNOTEQUAL -> putWord8 0x9e + OP_LESSTHAN -> putWord8 0x9f + OP_GREATERTHAN -> putWord8 0xa0 + OP_LESSTHANOREQUAL -> putWord8 0xa1 + OP_GREATERTHANOREQUAL -> putWord8 0xa2 + OP_MIN -> putWord8 0xa3 + OP_MAX -> putWord8 0xa4 + OP_WITHIN -> putWord8 0xa5 + -- Crypto + OP_RIPEMD160 -> putWord8 0xa6 + OP_SHA1 -> putWord8 0xa7 + OP_SHA256 -> putWord8 0xa8 + OP_HASH160 -> putWord8 0xa9 + OP_HASH256 -> putWord8 0xaa + OP_CODESEPARATOR -> putWord8 0xab + OP_CHECKSIG -> putWord8 0xac + OP_CHECKSIGVERIFY -> putWord8 0xad + OP_CHECKMULTISIG -> putWord8 0xae + OP_CHECKMULTISIGVERIFY -> putWord8 0xaf + -- More NOPs + OP_NOP1 -> putWord8 0xb0 + OP_CHECKLOCKTIMEVERIFY -> putWord8 0xb1 + OP_CHECKSEQUENCEVERIFY -> putWord8 0xb2 + OP_NOP4 -> putWord8 0xb3 + OP_NOP5 -> putWord8 0xb4 + OP_NOP6 -> putWord8 0xb5 + OP_NOP7 -> putWord8 0xb6 + OP_NOP8 -> putWord8 0xb7 + OP_NOP9 -> putWord8 0xb8 + OP_NOP10 -> putWord8 0xb9 + -- Bitcoin Cash Nov 2018 hard fork + OP_CHECKDATASIG -> putWord8 0xba + OP_CHECKDATASIGVERIFY -> putWord8 0xbb + -- Bitcoin Cash May 2020 hard fork + OP_REVERSEBYTES -> putWord8 0xbc instance Binary ScriptOp where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize ScriptOp where - put = serialize - get = deserialize + put = serialize + get = deserialize -- | Check whether opcode is only data. isPushOp :: ScriptOp -> Bool isPushOp op = case op of - OP_PUSHDATA _ _ -> True - OP_0 -> True - OP_1NEGATE -> True - OP_1 -> True - OP_2 -> True - OP_3 -> True - OP_4 -> True - OP_5 -> True - OP_6 -> True - OP_7 -> True - OP_8 -> True - OP_9 -> True - OP_10 -> True - OP_11 -> True - OP_12 -> True - OP_13 -> True - OP_14 -> True - OP_15 -> True - OP_16 -> True - _ -> False + OP_PUSHDATA _ _ -> True + OP_0 -> True + OP_1NEGATE -> True + OP_1 -> True + OP_2 -> True + OP_3 -> True + OP_4 -> True + OP_5 -> True + OP_6 -> True + OP_7 -> True + OP_8 -> True + OP_9 -> True + OP_10 -> True + OP_11 -> True + OP_12 -> True + OP_13 -> True + OP_14 -> True + OP_15 -> True + OP_16 -> True + _ -> False -- | Optimally encode data using one of the 4 types of data pushing opcodes. opPushData :: ByteString -> ScriptOp opPushData bs - | len <= 0x4b = OP_PUSHDATA bs OPCODE - | len <= 0xff = OP_PUSHDATA bs OPDATA1 - | len <= 0xffff = OP_PUSHDATA bs OPDATA2 - | len <= 0xffffffff = OP_PUSHDATA bs OPDATA4 - | otherwise = error "opPushData: payload size too big" + | len <= 0x4b = OP_PUSHDATA bs OPCODE + | len <= 0xff = OP_PUSHDATA bs OPDATA1 + | len <= 0xffff = OP_PUSHDATA bs OPDATA2 + | len <= 0xffffffff = OP_PUSHDATA bs OPDATA4 + | otherwise = error "opPushData: payload size too big" where len = B.length bs -- | Transforms integers @[1 .. 16]@ to 'ScriptOp' @[OP_1 .. OP_16]@. intToScriptOp :: Int -> ScriptOp intToScriptOp i - | i `elem` [1 .. 16] = op - | otherwise = err + | i `elem` [1 .. 16] = op + | otherwise = err where op = - fromRight err - . runGetS deserialize - . B.singleton - . fromIntegral - $ i + 0x50 + fromRight err + . runGetS deserialize + . B.singleton + . fromIntegral + $ i + 0x50 err = error $ "intToScriptOp: Invalid integer " ++ show i -{- | Decode 'ScriptOp' @[OP_1 .. OP_16]@ to integers @[1 .. 16]@. This functions - fails for other values of 'ScriptOp' --} +-- | Decode 'ScriptOp' @[OP_1 .. OP_16]@ to integers @[1 .. 16]@. This functions +-- fails for other values of 'ScriptOp' scriptOpToInt :: ScriptOp -> Either String Int scriptOpToInt s - | res `elem` [1 .. 16] = return res - | otherwise = Left $ "scriptOpToInt: invalid opcode " ++ show s + | res `elem` [1 .. 16] = return res + | otherwise = Left $ "scriptOpToInt: invalid opcode " ++ show s where res = fromIntegral (B.head $ runPutS $ serialize s) - 0x50 diff --git a/src/Haskoin/Script/SigHash.hs b/src/Haskoin/Script/SigHash.hs index 867a5a92..180cb587 100644 --- a/src/Haskoin/Script/SigHash.hs +++ b/src/Haskoin/Script/SigHash.hs @@ -1,27 +1,35 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Script.SigHash -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Transaction signatures and related functions. --} -module Haskoin.Script.SigHash ( - -- * Script Signatures +-- | +-- Module : Haskoin.Script.SigHash +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Transaction signatures and related functions. +module Haskoin.Script.SigHash + ( -- * Script Signatures SigHash (..), SigHashFlag (..), sigHashAll, sigHashNone, sigHashSingle, - hasAnyoneCanPayFlag, + anyoneCanPay, hasForkIdFlag, - setAnyoneCanPayFlag, + setAnyoneCanPay, setForkIdFlag, isSigHashAll, isSigHashNone, @@ -33,15 +41,19 @@ module Haskoin.Script.SigHash ( txSigHash, txSigHashForkId, TxSignature (..), - encodeTxSig, decodeTxSig, -) where + encodeTxSig, + ) +where import Control.DeepSeq import Control.Monad -import qualified Data.Aeson as J +import Crypto.Secp256k1 +import Data.Aeson import Data.Bits -import qualified Data.ByteString as BS +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -50,82 +62,69 @@ import Data.Maybe import Data.Scientific import Data.Word import GHC.Generics (Generic) -import Haskoin.Crypto import Haskoin.Crypto.Hash -import Haskoin.Data +import Haskoin.Crypto.Signature import Haskoin.Network.Common +import Haskoin.Network.Data import Haskoin.Script.Common import Haskoin.Transaction.Common import Haskoin.Util -- | Constant representing a SIGHASH flag that controls what is being signed. data SigHashFlag - = -- | sign all outputs - SIGHASH_ALL - | -- | sign no outputs - SIGHASH_NONE - | -- | sign the output index corresponding to the input - SIGHASH_SINGLE - | -- | replay protection for Bitcoin Cash transactions - SIGHASH_FORKID - | -- | new inputs can be added - SIGHASH_ANYONECANPAY - deriving (Eq, Ord, Show, Read, Generic) + = -- | sign all outputs + SIGHASH_ALL + | -- | sign no outputs + SIGHASH_NONE + | -- | sign the output index corresponding to the input + SIGHASH_SINGLE + | -- | replay protection for Bitcoin Cash transactions + SIGHASH_FORKID + | -- | new inputs can be added + SIGHASH_ANYONECANPAY + deriving (Eq, Ord, Show, Read, Generic) instance NFData SigHashFlag instance Hashable SigHashFlag instance Enum SigHashFlag where - fromEnum SIGHASH_ALL = 0x01 - fromEnum SIGHASH_NONE = 0x02 - fromEnum SIGHASH_SINGLE = 0x03 - fromEnum SIGHASH_FORKID = 0x40 - fromEnum SIGHASH_ANYONECANPAY = 0x80 - toEnum 0x01 = SIGHASH_ALL - toEnum 0x02 = SIGHASH_NONE - toEnum 0x03 = SIGHASH_SINGLE - toEnum 0x40 = SIGHASH_FORKID - toEnum 0x80 = SIGHASH_ANYONECANPAY - toEnum _ = error "Not a valid sighash flag" + fromEnum SIGHASH_ALL = 0x01 + fromEnum SIGHASH_NONE = 0x02 + fromEnum SIGHASH_SINGLE = 0x03 + fromEnum SIGHASH_FORKID = 0x40 + fromEnum SIGHASH_ANYONECANPAY = 0x80 + toEnum 0x01 = SIGHASH_ALL + toEnum 0x02 = SIGHASH_NONE + toEnum 0x03 = SIGHASH_SINGLE + toEnum 0x40 = SIGHASH_FORKID + toEnum 0x80 = SIGHASH_ANYONECANPAY + toEnum _ = error "Not a valid sighash flag" -{- | Data type representing the different ways a transaction can be signed. - When producing a signature, a hash of the transaction is used as the message - to be signed. The 'SigHash' parameter controls which parts of the - transaction are used or ignored to produce the transaction hash. The idea is - that if some part of a transaction is not used to produce the transaction - hash, then you can change that part of the transaction after producing a - signature without invalidating that signature. - - If the 'SIGHASH_ANYONECANPAY' flag is set (true), then only the current input - is signed. Otherwise, all of the inputs of a transaction are signed. The - default value for 'SIGHASH_ANYONECANPAY' is unset (false). --} +-- | Data type representing the different ways a transaction can be signed. +-- When producing a signature, a hash of the transaction is used as the message +-- to be signed. The 'SigHash' parameter controls which parts of the +-- transaction are used or ignored to produce the transaction hash. The idea is +-- that if some part of a transaction is not used to produce the transaction +-- hash, then you can change that part of the transaction after producing a +-- signature without invalidating that signature. +-- +-- If the 'SIGHASH_ANYONECANPAY' flag is set (true), then only the current input +-- is signed. Otherwise, all of the inputs of a transaction are signed. The +-- default value for 'SIGHASH_ANYONECANPAY' is unset (false). newtype SigHash - = SigHash Word32 - deriving - ( Eq - , Ord - , Bits - , Enum - , Integral - , Num - , Real - , Show - , Read - , Generic - , Hashable - , NFData - ) + = SigHash Word32 + deriving (Eq, Ord, Enum, Show, Read, Generic) + deriving newtype (Bits, Integral, Num, Real, Hashable, NFData) -instance J.FromJSON SigHash where - parseJSON = - J.withScientific "sighash" $ - maybe mzero (return . SigHash) . toBoundedInteger +instance FromJSON SigHash where + parseJSON = + withScientific "sighash" $ + maybe mzero (return . SigHash) . toBoundedInteger -instance J.ToJSON SigHash where - toJSON = J.Number . fromIntegral - toEncoding (SigHash n) = J.toEncoding n +instance ToJSON SigHash where + toJSON = Number . fromIntegral + toEncoding (SigHash n) = toEncoding n -- | SIGHASH_NONE as a byte. sigHashNone :: SigHash @@ -152,16 +151,16 @@ setForkIdFlag :: SigHash -> SigHash setForkIdFlag = (.|. sigHashForkId) -- | Set SIGHASH_ANYONECANPAY flag. -setAnyoneCanPayFlag :: SigHash -> SigHash -setAnyoneCanPayFlag = (.|. sigHashAnyoneCanPay) +setAnyoneCanPay :: SigHash -> SigHash +setAnyoneCanPay = (.|. sigHashAnyoneCanPay) -- | Is the SIGHASH_FORKID flag set? hasForkIdFlag :: SigHash -> Bool hasForkIdFlag = (/= 0) . (.&. sigHashForkId) -- | Is the SIGHASH_ANYONECANPAY flag set? -hasAnyoneCanPayFlag :: SigHash -> Bool -hasAnyoneCanPayFlag = (/= 0) . (.&. sigHashAnyoneCanPay) +anyoneCanPay :: SigHash -> Bool +anyoneCanPay = (/= 0) . (.&. sigHashAnyoneCanPay) -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_ALL'. isSigHashAll :: SigHash -> Bool @@ -178,7 +177,7 @@ isSigHashSingle = (== sigHashSingle) . (.&. 0x1f) -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_UNKNOWN'. isSigHashUnknown :: SigHash -> Bool isSigHashUnknown = - (`notElem` [sigHashAll, sigHashNone, sigHashSingle]) . (.&. 0x1f) + (`notElem` [sigHashAll, sigHashNone, sigHashSingle]) . (.&. 0x1f) -- | Add a fork id to a 'SigHash'. sigHashAddForkId :: SigHash -> Word32 -> SigHash @@ -187,7 +186,7 @@ sigHashAddForkId sh w = (fromIntegral w `shiftL` 8) .|. (sh .&. 0x000000ff) -- | Add fork id of a particular network to a 'SigHash'. sigHashAddNetworkId :: Network -> SigHash -> SigHash sigHashAddNetworkId net = - (`sigHashAddForkId` fromMaybe 0 (getSigHashForkId net)) + (`sigHashAddForkId` fromMaybe 0 net.sigHashForkId) -- | Get fork id from 'SigHash'. sigHashGetForkId :: SigHash -> Word32 @@ -195,146 +194,157 @@ sigHashGetForkId (SigHash n) = fromIntegral $ n `shiftR` 8 -- | Computes the hash that will be used for signing a transaction. txSigHash :: - Network -> - -- | transaction to sign - Tx -> - -- | script from output being spent - Script -> - -- | value of output being spent - Word64 -> - -- | index of input being signed - Int -> - -- | what to sign - SigHash -> - -- | hash to be signed - Hash256 + Network -> + -- | transaction to sign + Tx -> + -- | script from output being spent + Script -> + -- | value of output being spent + Word64 -> + -- | index of input being signed + Int -> + -- | what to sign + SigHash -> + -- | hash to be signed + Hash256 txSigHash net tx out v i sh - | hasForkIdFlag sh && isJust (getSigHashForkId net) = - txSigHashForkId net tx out v i sh - | otherwise = do - let newIn = buildInputs (txIn tx) fout i sh - -- When SigSingle and input index > outputs, then sign integer 1 - fromMaybe one $ do - newOut <- buildOutputs (txOut tx) i sh - let newTx = Tx (txVersion tx) newIn newOut [] (txLockTime tx) - return $ - doubleSHA256 $ - runPutS $ do - serialize newTx - putWord32le $ fromIntegral sh + | hasForkIdFlag sh && isJust net.sigHashForkId = + txSigHashForkId net tx out v i sh + | otherwise = do + let newIn = buildInputs tx.inputs fout i sh + -- When SigSingle and input index > outputs, then sign integer 1 + fromMaybe one $ do + newOut <- buildOutputs tx.outputs i sh + let newTx = Tx tx.version newIn newOut [] tx.locktime + return . doubleSHA256 . runPutS $ do + serialize newTx + putWord32le $ fromIntegral sh where - fout = Script $ filter (/= OP_CODESEPARATOR) $ scriptOps out + fout = Script $ filter (/= OP_CODESEPARATOR) out.ops one = "0100000000000000000000000000000000000000000000000000000000000000" -- | Build transaction inputs for computing sighashes. buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn] buildInputs txins out i sh - | hasAnyoneCanPayFlag sh = - [(txins !! i){scriptInput = runPutS $ serialize out}] - | isSigHashAll sh || isSigHashUnknown sh = single - | otherwise = zipWith noSeq single [0 ..] + | anyoneCanPay sh = [serialOut (txins !! i)] + | isSigHashAll sh || isSigHashUnknown sh = single + | otherwise = zipWith noSeq single [0 ..] where - emptyIn = map (\ti -> ti{scriptInput = BS.empty}) txins - single = - updateIndex i emptyIn $ \ti -> ti{scriptInput = runPutS $ serialize out} - noSeq ti j = - if i == j - then ti - else ti{txInSequence = 0} + serialOut TxIn {..} = TxIn {script = runPutS $ serialize out, ..} + emptyIn TxIn {..} = TxIn {script = B.empty, ..} + emptyIns = map emptyIn txins + single = updateIndex i emptyIns serialOut + noSeq TxIn {..} j = TxIn {sequence = if i == j then sequence else 0, ..} -- | Build transaction outputs for computing sighashes. buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut] buildOutputs txos i sh - | isSigHashAll sh || isSigHashUnknown sh = return txos - | isSigHashNone sh = return [] - | i >= length txos = Nothing - | otherwise = return $ buffer ++ [txos !! i] + | isSigHashAll sh || isSigHashUnknown sh = return txos + | isSigHashNone sh = return [] + | i >= length txos = Nothing + | otherwise = return $ buffer ++ [txos !! i] where - buffer = replicate i $ TxOut maxBound BS.empty + buffer = replicate i $ TxOut maxBound B.empty -{- | Compute the hash that will be used for signing a transaction. This - function is used when the 'SIGHASH_FORKID' flag is set. --} +-- | Compute the hash that will be used for signing a transaction. This +-- function is used when the 'SIGHASH_FORKID' flag is set. txSigHashForkId :: - Network -> - -- | transaction to sign - Tx -> - -- | script from output being spent - Script -> - -- | value of output being spent - Word64 -> - -- | index of input being signed - Int -> - -- | what to sign - SigHash -> - -- | hash to be signed - Hash256 + Network -> + -- | transaction to sign + Tx -> + -- | script from output being spent + Script -> + -- | value of output being spent + Word64 -> + -- | index of input being signed + Int -> + -- | what to sign + SigHash -> + -- | hash to be signed + Hash256 txSigHashForkId net tx out v i sh = - doubleSHA256 . runPutS $ do - putWord32le $ txVersion tx - serialize hashPrevouts - serialize hashSequence - serialize $ prevOutput $ txIn tx !! i - putScript out - putWord64le v - putWord32le $ txInSequence $ txIn tx !! i - serialize hashOutputs - putWord32le $ txLockTime tx - putWord32le $ fromIntegral $ sigHashAddNetworkId net sh + doubleSHA256 . runPutS $ do + putWord32le tx.version + serialize hashPrevouts + serialize hashSequence + serialize (tx.inputs !! i).outpoint + putScript out + putWord64le v + putWord32le (tx.inputs !! i).sequence + serialize hashOutputs + putWord32le tx.locktime + putWord32le $ fromIntegral $ sigHashAddNetworkId net sh where hashPrevouts - | not $ hasAnyoneCanPayFlag sh = - doubleSHA256 $ runPutS $ mapM_ (serialize . prevOutput) $ txIn tx - | otherwise = zeros + | not (anyoneCanPay sh) = + doubleSHA256 . runPutS $ mapM_ (serialize . (.outpoint)) tx.inputs + | otherwise = zeros hashSequence - | not (hasAnyoneCanPayFlag sh) - && not (isSigHashSingle sh) - && not (isSigHashNone sh) = - doubleSHA256 $ runPutS $ mapM_ (putWord32le . txInSequence) $ txIn tx - | otherwise = zeros + | not (anyoneCanPay sh || isSigHashSingle sh || isSigHashNone sh) = + doubleSHA256 . runPutS $ mapM_ (putWord32le . (.sequence)) tx.inputs + | otherwise = zeros hashOutputs - | not (isSigHashSingle sh) && not (isSigHashNone sh) = - doubleSHA256 $ runPutS $ mapM_ serialize $ txOut tx - | isSigHashSingle sh && i < length (txOut tx) = - doubleSHA256 $ runPutS $ serialize $ txOut tx !! i - | otherwise = zeros + | not (isSigHashSingle sh || isSigHashNone sh) = + doubleSHA256 . runPutS $ mapM_ serialize tx.outputs + | isSigHashSingle sh && i < length tx.outputs = + doubleSHA256 . runPutS $ serialize $ tx.outputs !! i + | otherwise = zeros putScript s = do - let encodedScript = runPutS $ serialize s - putVarInt $ BS.length encodedScript - putByteString encodedScript + let encodedScript = runPutS $ serialize s + putVarInt $ B.length encodedScript + putByteString encodedScript zeros :: Hash256 zeros = "0000000000000000000000000000000000000000000000000000000000000000" -{- | Data type representing a signature together with a 'SigHash'. The 'SigHash' - is serialized as one byte at the end of an ECDSA 'Sig'. All signatures in - transaction inputs are of type 'TxSignature'. --} +-- | Data type representing a signature together with a 'SigHash'. The 'SigHash' +-- is serialized as one byte at the end of an ECDSA 'Sig'. All signatures in +-- transaction inputs are of type 'TxSignature'. data TxSignature - = TxSignature - { txSignature :: !Sig - , txSignatureSigHash :: !SigHash - } - | TxSignatureEmpty - deriving (Eq, Show, Generic) + = TxSignature + { sig :: !Sig, + hash :: !SigHash + } + | TxSignatureEmpty + deriving (Eq, Show, Read, Generic, NFData) -instance NFData TxSignature +instance Marshal (Network, Ctx) TxSignature where + marshalPut (net, ctx) TxSignatureEmpty = return () + marshalPut (net, ctx) (TxSignature sig (SigHash n)) = do + marshalPut ctx sig + putWord8 (fromIntegral n) --- | Serialize a 'TxSignature'. -encodeTxSig :: TxSignature -> BS.ByteString -encodeTxSig TxSignatureEmpty = error "Can not encode an empty signature" -encodeTxSig (TxSignature sig (SigHash n)) = - runPutS $ putSig sig >> putWord8 (fromIntegral n) + marshalGet (net, ctx) = + bool decode empty =<< isEmpty + where + empty = return TxSignatureEmpty + decode = do + sig <- marshalGet ctx + sh <- fromIntegral <$> getWord8 + when (isSigHashUnknown sh) $ + fail "Non-canonical signature: unknown hashtype byte" + when (isNothing net.sigHashForkId && hasForkIdFlag sh) $ + fail "Non-canonical signature: invalid network for forkId" + return $ TxSignature sig sh --- | Deserialize a 'TxSignature'. -decodeTxSig :: Network -> BS.ByteString -> Either String TxSignature -decodeTxSig _ bs | BS.null bs = Left "Empty signature candidate" -decodeTxSig net bs = - case decodeStrictSig $ BS.init bs of - Just sig -> do - let sh = fromIntegral $ BS.last bs - when (isSigHashUnknown sh) $ - Left "Non-canonical signature: unknown hashtype byte" - when (isNothing (getSigHashForkId net) && hasForkIdFlag sh) $ - Left "Non-canonical signature: invalid network for forkId" - return $ TxSignature sig sh - Nothing -> Left "Non-canonical signature: could not parse signature" +instance MarshalJSON (Network, Ctx) TxSignature where + marshalValue (net, ctx) = String . encodeHex . encodeTxSig net ctx + marshalEncoding s = hexEncoding . runPutL . marshalPut s + unmarshalValue (net, ctx) = + withText "TxSignature" $ \t -> + case decodeHex t of + Nothing -> fail "Cannot decode hex signature" + Just b -> case decodeTxSig net ctx b of + Left e -> fail e + Right s -> return s + +encodeTxSig :: Network -> Ctx -> TxSignature -> ByteString +encodeTxSig net ctx = runPutS . marshalPut (net, ctx) + +decodeTxSig :: Network -> Ctx -> ByteString -> Either String TxSignature +decodeTxSig net ctx = + runGetS $ do + sig <- marshalGet (net, ctx) + e <- isEmpty + unless e $ + fail "Non-canonical signature: multiple hashtype bytes" + return sig diff --git a/src/Haskoin/Script/Standard.hs b/src/Haskoin/Script/Standard.hs index cf093ad2..9e4c2040 100644 --- a/src/Haskoin/Script/Standard.hs +++ b/src/Haskoin/Script/Standard.hs @@ -1,20 +1,26 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Script.Standard -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Standard scripts like pay-to-public-key, pay-to-public-key-hash, -pay-to-script-hash, pay-to-multisig and corresponding SegWit variants. --} -module Haskoin.Script.Standard ( - -- * Standard Script Outputs +-- | +-- Module : Haskoin.Script.Standard +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Standard scripts like pay-to-public-key, pay-to-public-key-hash, +-- pay-to-script-hash, pay-to-multisig and corresponding SegWit variants. +module Haskoin.Script.Standard + ( -- * Standard Script Outputs ScriptOutput (..), RedeemScript, isPayPK, @@ -26,9 +32,7 @@ module Haskoin.Script.Standard ( isPayWitnessScriptHash, isDataCarrier, encodeOutput, - encodeOutputBS, decodeOutput, - decodeOutputBS, toP2SH, toP2WSH, sortMulSig, @@ -37,22 +41,23 @@ module Haskoin.Script.Standard ( ScriptInput (..), SimpleInput (..), encodeInput, - encodeInputBS, decodeInput, - decodeInputBS, isSpendPK, isSpendPKHash, isSpendMulSig, isScriptHashInput, -) where + ) +where import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Monad (guard, liftM2, (<=<)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as A +import Crypto.Secp256k1 +import Data.Aeson (ToJSON (..), Value (..), withText) +import Data.Aeson.Encoding (Encoding, text) +import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as B import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -62,52 +67,51 @@ import Data.List (sortBy) import Data.Maybe (fromJust, isJust) import Data.Word (Word8) import GHC.Generics (Generic) -import Haskoin.Crypto -import Haskoin.Data -import Haskoin.Keys.Common +import Haskoin.Crypto.Hash +import Haskoin.Crypto.Keys.Common +import Haskoin.Network.Data import Haskoin.Script.Common import Haskoin.Script.SigHash import Haskoin.Util -{- | Data type describing standard transaction output scripts. Output scripts - provide the conditions that must be fulfilled for someone to spend the funds - in a transaction output. --} +-- | Data type describing standard transaction output scripts. Output scripts +-- provide the conditions that must be fulfilled for someone to spend the funds +-- in a transaction output. data ScriptOutput - = -- | pay to public key - PayPK {getOutputPubKey :: !PubKeyI} - | -- | pay to public key hash - PayPKHash {getOutputHash :: !Hash160} - | -- | multisig - PayMulSig - { getOutputMulSigKeys :: ![PubKeyI] - , getOutputMulSigRequired :: !Int - } - | -- | pay to a script hash - PayScriptHash {getOutputHash :: !Hash160} - | -- | pay to witness public key hash - PayWitnessPKHash {getOutputHash :: !Hash160} - | -- | pay to witness script hash - PayWitnessScriptHash {getScriptHash :: !Hash256} - | -- | another pay to witness address - PayWitness - { getWitnessVersion :: !Word8 - , getWitnessData :: !ByteString - } - | -- | provably unspendable data carrier - DataCarrier {getOutputData :: !ByteString} - deriving (Eq, Show, Read, Generic, Hashable, NFData) + = -- | pay to public key + PayPK {key :: !PublicKey} + | -- | pay to public key hash + PayPKHash {hash160 :: !Hash160} + | -- | multisig + PayMulSig + { keys :: ![PublicKey], + required :: !Int + } + | -- | pay to a script hash + PayScriptHash {hash160 :: !Hash160} + | -- | pay to witness public key hash + PayWitnessPKHash {hash160 :: !Hash160} + | -- | pay to witness script hash + PayWitnessScriptHash {hash256 :: !Hash256} + | -- | another pay to witness address + PayWitness + { version :: !Word8, + bytes :: !ByteString + } + | -- | provably unspendable data carrier + DataCarrier {bytes :: !ByteString} + deriving (Eq, Show, Read, Generic, NFData) -instance A.FromJSON ScriptOutput where - parseJSON = - A.withText "scriptoutput" $ \t -> - either fail return $ - maybeToEither "scriptoutput not hex" (decodeHex t) - >>= decodeOutputBS +instance MarshalJSON Ctx ScriptOutput where + unmarshalValue ctx = + withText "ScriptOutput" $ \t -> + case decodeHex t of + Nothing -> fail "Could not decode hex script" + Just bs -> either fail return $ unmarshal ctx bs -instance A.ToJSON ScriptOutput where - toJSON = A.String . encodeHex . encodeOutputBS - toEncoding = A.text . encodeHex . encodeOutputBS + marshalValue ctx = String . encodeHex . marshal ctx + + marshalEncoding ctx = hexEncoding . runPutL . marshalPut ctx -- | Is script a pay-to-public-key output? isPayPK :: ScriptOutput -> Bool @@ -149,35 +153,39 @@ isDataCarrier :: ScriptOutput -> Bool isDataCarrier (DataCarrier _) = True isDataCarrier _ = False -{- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the - script is not recognized as any of the standard output types. --} -decodeOutput :: Script -> Either String ScriptOutput -decodeOutput s = case scriptOps s of - -- Pay to PubKey - [OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> runGetS deserialize bs - -- Pay to PubKey Hash - [OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] -> - PayPKHash <$> runGetS deserialize bs - -- Pay to Script Hash - [OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] -> - PayScriptHash <$> runGetS deserialize bs - -- Pay to Witness - [OP_0, OP_PUSHDATA bs OPCODE] - | BS.length bs == 20 -> PayWitnessPKHash <$> runGetS deserialize bs - | BS.length bs == 32 -> PayWitnessScriptHash <$> runGetS deserialize bs - | BS.length bs /= 20 && BS.length bs /= 32 -> - Left "Version 0 segwit program must be 20 or 32 bytes long" - -- Other Witness - [ver, OP_PUSHDATA bs _] - | isJust (opWitnessVersion ver) - && BS.length bs >= 2 - && BS.length bs <= 40 -> - Right $ PayWitness (fromJust (opWitnessVersion ver)) bs - -- Provably unspendable data carrier output - [OP_RETURN, OP_PUSHDATA bs _] -> Right $ DataCarrier bs - -- Pay to MultiSig Keys - _ -> matchPayMulSig s +-- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the +-- script is not recognized as any of the standard output types. +decodeOutput :: Ctx -> Script -> Either String ScriptOutput +decodeOutput ctx s = case s.ops of + -- Pay to PubKey + [OP_PUSHDATA bs _, OP_CHECKSIG] -> + PayPK <$> unmarshal ctx bs + -- Pay to PubKey Hash + [OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] -> + PayPKHash <$> runGetS deserialize bs + -- Pay to Script Hash + [OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] -> + PayScriptHash <$> runGetS deserialize bs + -- Pay to Witness + [OP_0, OP_PUSHDATA bs OPCODE] + | B.length bs == 20 -> + PayWitnessPKHash <$> runGetS deserialize bs + | B.length bs == 32 -> + PayWitnessScriptHash <$> runGetS deserialize bs + | B.length bs /= 20 && B.length bs /= 32 -> + Left + "decodeOutput: invalid version 0 segwit \ + \(must be 20 or 32 bytes)" + -- Other Witness + [ver, OP_PUSHDATA bs _] + | Just wv <- opWitnessVersion ver, + B.length bs >= 2, + B.length bs <= 40 -> + Right $ PayWitness wv bs + -- Provably unspendable data carrier output + [OP_RETURN, OP_PUSHDATA bs _] -> Right $ DataCarrier bs + -- Pay to MultiSig Keys + _ -> matchPayMulSig ctx s <|> Left "decodeOutput: Non-standard output" witnessVersionOp :: Word8 -> Maybe ScriptOp witnessVersionOp 0 = Just OP_0 @@ -219,51 +227,51 @@ opWitnessVersion OP_15 = Just 15 opWitnessVersion OP_16 = Just 16 opWitnessVersion _ = Nothing --- | Similar to 'decodeOutput' but decodes from a 'ByteString'. -decodeOutputBS :: ByteString -> Either String ScriptOutput -decodeOutputBS = decodeOutput <=< runGetS deserialize - -- | Computes a 'Script' from a standard 'ScriptOutput'. -encodeOutput :: ScriptOutput -> Script -encodeOutput s = Script $ case s of - -- Pay to PubKey - (PayPK k) -> [opPushData $ runPutS $ serialize k, OP_CHECKSIG] - -- Pay to PubKey Hash Address - (PayPKHash h) -> - [ OP_DUP - , OP_HASH160 - , opPushData $ runPutS $ serialize h - , OP_EQUALVERIFY - , OP_CHECKSIG - ] - -- Pay to MultiSig Keys - (PayMulSig ps r) - | r <= length ps -> - let opM = intToScriptOp r - opN = intToScriptOp $ length ps - keys = map (opPushData . runPutS . serialize) ps - in opM : keys ++ [opN, OP_CHECKMULTISIG] - | otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys" - -- Pay to Script Hash Address - (PayScriptHash h) -> - [OP_HASH160, opPushData $ runPutS $ serialize h, OP_EQUAL] - -- Pay to Witness PubKey Hash Address - (PayWitnessPKHash h) -> - [OP_0, opPushData $ runPutS $ serialize h] - (PayWitnessScriptHash h) -> - [OP_0, opPushData $ runPutS $ serialize h] - (PayWitness v h) -> - [ case witnessVersionOp v of - Nothing -> error "encodeOutput: invalid witness version" - Just c -> c - , opPushData h - ] - -- Provably unspendable output - (DataCarrier d) -> [OP_RETURN, opPushData d] +encodeOutput :: Ctx -> ScriptOutput -> Script +encodeOutput ctx s = Script $ case s of + -- Pay to PubKey + (PayPK k) -> [opPushData $ marshal ctx k, OP_CHECKSIG] + -- Pay to PubKey Hash Address + (PayPKHash h) -> + [ OP_DUP, + OP_HASH160, + opPushData $ runPutS $ serialize h, + OP_EQUALVERIFY, + OP_CHECKSIG + ] + -- Pay to MultiSig Keys + (PayMulSig ps r) + | r <= length ps -> + let opM = intToScriptOp r + opN = intToScriptOp $ length ps + keys = map (opPushData . marshal ctx) ps + in opM : keys ++ [opN, OP_CHECKMULTISIG] + | otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys" + -- Pay to Script Hash Address + (PayScriptHash h) -> + [OP_HASH160, opPushData $ runPutS $ serialize h, OP_EQUAL] + -- Pay to Witness PubKey Hash Address + (PayWitnessPKHash h) -> + [OP_0, opPushData $ runPutS $ serialize h] + (PayWitnessScriptHash h) -> + [OP_0, opPushData $ runPutS $ serialize h] + (PayWitness v h) -> + [ case witnessVersionOp v of + Nothing -> error "encodeOutput: invalid witness version" + Just c -> c, + opPushData h + ] + -- Provably unspendable output + (DataCarrier d) -> [OP_RETURN, opPushData d] --- | Similar to 'encodeOutput' but encodes to a ByteString -encodeOutputBS :: ScriptOutput -> ByteString -encodeOutputBS = runPutS . serialize . encodeOutput +instance Marshal Ctx ScriptOutput where + marshalGet ctx = do + script <- deserialize + case decodeOutput ctx script of + Left e -> fail e + Right o -> return o + marshalPut ctx = serialize . encodeOutput ctx -- | Encode script as pay-to-script-hash script toP2SH :: Script -> ScriptOutput @@ -274,59 +282,61 @@ toP2WSH :: Script -> ScriptOutput toP2WSH = PayWitnessScriptHash . sha256 . runPutS . serialize -- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@ -matchPayMulSig :: Script -> Either String ScriptOutput -matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of - (m : xs, [n, OP_CHECKMULTISIG]) -> do - (intM, intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n) - if intM <= intN && length xs == intN - then liftM2 PayMulSig (go xs) (return intM) - else Left "matchPayMulSig: Invalid M or N parameters" - _ -> Left "matchPayMulSig: script did not match output template" +matchPayMulSig :: Ctx -> Script -> Either String ScriptOutput +matchPayMulSig ctx (Script ops) = case splitAt (length ops - 2) ops of + (m : xs, [n, OP_CHECKMULTISIG]) -> do + (intM, intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n) + if intM <= intN && length xs == intN + then liftM2 PayMulSig (go xs) (return intM) + else Left "matchPayMulSig: Invalid M or N parameters" + _ -> Left "matchPayMulSig: script did not match output template" where - go (OP_PUSHDATA bs _ : xs) = liftM2 (:) (runGetS deserialize bs) (go xs) - go [] = return [] - go _ = Left "matchPayMulSig: invalid multisig opcode" + go (OP_PUSHDATA bs _ : xs) = + liftM2 (:) (unmarshal ctx bs) (go xs) + go [] = + Right [] + go _ = + Left "matchPayMulSig: invalid multisig opcode" -{- | Sort the public keys of a multisig output in ascending order by comparing - their compressed serialized representations. Refer to BIP-67. --} -sortMulSig :: ScriptOutput -> ScriptOutput -sortMulSig out = case out of - PayMulSig keys r -> PayMulSig (sortBy (compare `on` (runPutS . serialize)) keys) r - _ -> error "Can only call orderMulSig on PayMulSig scripts" +-- | Sort the public keys of a multisig output in ascending order by comparing +-- their compressed serialized representations. Refer to BIP-67. +sortMulSig :: Ctx -> ScriptOutput -> ScriptOutput +sortMulSig ctx out = case out of + PayMulSig keys r -> + PayMulSig + (sortBy (compare `on` marshal ctx) keys) + r + _ -> error "Can only call orderMulSig on PayMulSig scripts" -{- | Data type describing standard transaction input scripts. Input scripts - provide the signing data required to unlock the coins of the output they are - trying to spend, except in pay-to-witness-public-key-hash and - pay-to-script-hash transactions. --} +-- | Data type describing standard transaction input scripts. Input scripts +-- provide the signing data required to unlock the coins of the output they are +-- trying to spend, except in pay-to-witness-public-key-hash and +-- pay-to-script-hash transactions. data SimpleInput - = SpendPK - { -- | transaction signature - getInputSig :: !TxSignature - } - | SpendPKHash - { -- | embedded signature - getInputSig :: !TxSignature - , -- | public key - getInputKey :: !PubKeyI - } - | SpendMulSig - { -- | list of signatures - getInputMulSigKeys :: ![TxSignature] - } - deriving (Eq, Show, Generic, NFData) + = SpendPK + { -- | transaction signature + signature :: !TxSignature + } + | SpendPKHash + { -- | embedded signature + signature :: !TxSignature, + -- | public key + key :: !PublicKey + } + | SpendMulSig + { -- | list of signatures + signatures :: ![TxSignature] + } + deriving (Eq, Show, Read, Generic, NFData) -{- | Returns true if the input script is spending from a pay-to-public-key - output. --} +-- | Returns true if the input script is spending from a pay-to-public-key +-- output. isSpendPK :: ScriptInput -> Bool isSpendPK (RegularInput (SpendPK _)) = True isSpendPK _ = False -{- | Returns true if the input script is spending from a pay-to-public-key-hash - output. --} +-- | Returns true if the input script is spending from a pay-to-public-key-hash +-- output. isSpendPKHash :: ScriptInput -> Bool isSpendPKHash (RegularInput (SpendPKHash _ _)) = True isSpendPKHash _ = False @@ -341,91 +351,83 @@ isScriptHashInput :: ScriptInput -> Bool isScriptHashInput (ScriptHashInput _ _) = True isScriptHashInput _ = False -{- | A redeem script is the output script serialized into the spending input - script. It must be included in inputs that spend pay-to-script-hash outputs. --} +-- | A redeem script is the output script serialized into the spending input +-- script. It must be included in inputs that spend pay-to-script-hash outputs. type RedeemScript = ScriptOutput -- | Standard input script high-level representation. data ScriptInput - = RegularInput - { -- | get wrapped simple input - getRegularInput :: !SimpleInput - } - | ScriptHashInput - { -- | get simple input associated with redeem script - getScriptHashInput :: !SimpleInput - , -- | redeem script - getScriptHashRedeem :: !RedeemScript - } - deriving (Eq, Show, Generic, NFData) + = RegularInput + { -- | get wrapped simple input + get :: !SimpleInput + } + | ScriptHashInput + { -- | get simple input associated with redeem script + get :: !SimpleInput, + -- | redeem script + redeem :: !RedeemScript + } + deriving (Show, Read, Eq, Generic, NFData) -- | Heuristic to decode an input script into one of the standard types. -decodeSimpleInput :: Network -> Script -> Either String SimpleInput -decodeSimpleInput net (Script ops) = - maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops +decodeSimpleInput :: Network -> Ctx -> Script -> Either String SimpleInput +decodeSimpleInput net ctx (Script ops) = + maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops where matchPK [op] = SpendPK <$> f op matchPK _ = Nothing matchPKHash [op, OP_PUSHDATA pub _] = - SpendPKHash <$> f op <*> eitherToMaybe (runGetS deserialize pub) + SpendPKHash <$> f op <*> eitherToMaybe (unmarshal ctx pub) matchPKHash _ = Nothing matchMulSig (x : xs) = do - guard $ x == OP_0 - SpendMulSig <$> mapM f xs + guard $ x == OP_0 + SpendMulSig <$> mapM f xs matchMulSig _ = Nothing f OP_0 = return TxSignatureEmpty f (OP_PUSHDATA "" OPCODE) = f OP_0 - f (OP_PUSHDATA bs _) = eitherToMaybe $ decodeTxSig net bs + f (OP_PUSHDATA bs _) = eitherToMaybe $ decodeTxSig net ctx bs f _ = Nothing errMsg = "decodeInput: Could not decode script input" -{- | Heuristic to decode a 'ScriptInput' from a 'Script'. This function fails if - the script can not be parsed as a standard script input. --} -decodeInput :: Network -> Script -> Either String ScriptInput -decodeInput net s@(Script ops) = - maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash +-- | Heuristic to decode a 'ScriptInput' from a 'Script'. This function fails if +-- the script can not be parsed as a standard script input. +decodeInput :: Network -> Ctx -> Script -> Either String ScriptInput +decodeInput net ctx s@(Script ops) = + maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash where matchSimpleInput = - RegularInput <$> eitherToMaybe (decodeSimpleInput net s) + RegularInput <$> eitherToMaybe (decodeSimpleInput net ctx s) matchPayScriptHash = - case splitAt (length (scriptOps s) - 1) ops of - (is, [OP_PUSHDATA bs _]) -> do - rdm <- eitherToMaybe $ decodeOutputBS bs - inp <- eitherToMaybe $ decodeSimpleInput net $ Script is - return $ ScriptHashInput inp rdm - _ -> Nothing + case splitAt (length s.ops - 1) ops of + (is, [OP_PUSHDATA bs _]) -> do + rdm <- eitherToMaybe $ unmarshal ctx bs + inp <- eitherToMaybe $ decodeSimpleInput net ctx $ Script is + return $ ScriptHashInput inp rdm + _ -> Nothing errMsg = "decodeInput: Could not decode script input" -{- | Like 'decodeInput' but decodes directly from a serialized script - 'ByteString'. --} -decodeInputBS :: Network -> ByteString -> Either String ScriptInput -decodeInputBS net = decodeInput net <=< runGetS deserialize +instance Marshal (Network, Ctx) ScriptInput where + marshalGet (net, ctx) = + deserialize >>= either fail return . decodeInput net ctx + + marshalPut (net, ctx) = + serialize . encodeInput net ctx -- | Encode a standard input into a script. -encodeInput :: ScriptInput -> Script -encodeInput s = case s of - RegularInput ri -> encodeSimpleInput ri - ScriptHashInput i o -> - Script $ - scriptOps (encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o] - -{- | Similar to 'encodeInput' but encodes directly to a serialized script - 'ByteString'. --} -encodeInputBS :: ScriptInput -> ByteString -encodeInputBS = runPutS . serialize . encodeInput +encodeInput :: Network -> Ctx -> ScriptInput -> Script +encodeInput net ctx s = case s of + RegularInput ri -> encodeSimpleInput net ctx ri + ScriptHashInput i o -> + Script $ (encodeSimpleInput net ctx i).ops ++ [opPushData $ marshal ctx o] -- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'. -encodeSimpleInput :: SimpleInput -> Script -encodeSimpleInput s = - Script $ - case s of - SpendPK ts -> [f ts] - SpendPKHash ts p -> [f ts, opPushData $ runPutS $ serialize p] - SpendMulSig xs -> OP_0 : map f xs +encodeSimpleInput :: Network -> Ctx -> SimpleInput -> Script +encodeSimpleInput net ctx s = + Script $ + case s of + SpendPK ts -> [f ts] + SpendPKHash ts p -> [f ts, opPushData $ marshal ctx p] + SpendMulSig xs -> OP_0 : map f xs where f TxSignatureEmpty = OP_0 - f ts = opPushData $ encodeTxSig ts + f ts = opPushData $ encodeTxSig net ctx ts diff --git a/src/Haskoin/Transaction.hs b/src/Haskoin/Transaction.hs index 49ac96d7..12f30cb5 100644 --- a/src/Haskoin/Transaction.hs +++ b/src/Haskoin/Transaction.hs @@ -1,21 +1,21 @@ -{- | -Module : Haskoin.Transaction -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Transactions and related code. --} -module Haskoin.Transaction ( - module Common, +-- | +-- Module : Haskoin.Transaction +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Transactions and related code. +module Haskoin.Transaction + ( module Common, module Builder, module Segwit, module Taproot, module Partial, module Genesis, -) where + ) +where import Haskoin.Transaction.Builder as Builder import Haskoin.Transaction.Common as Common diff --git a/src/Haskoin/Transaction/Builder.hs b/src/Haskoin/Transaction/Builder.hs index 68af9c91..29e0f427 100644 --- a/src/Haskoin/Transaction/Builder.hs +++ b/src/Haskoin/Transaction/Builder.hs @@ -1,20 +1,24 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Transaction.Builder -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Code to simplify transaction creation, signing, fee calculation and coin -selection. --} -module Haskoin.Transaction.Builder ( - -- * Transaction Builder +-- | +-- Module : Haskoin.Transaction.Builder +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Code to simplify transaction creation, signing, fee calculation and coin +-- selection. +module Haskoin.Transaction.Builder + ( -- * Transaction Builder buildAddrTx, buildTx, buildInput, @@ -43,24 +47,19 @@ module Haskoin.Transaction.Builder ( guessMSTxFee, guessTxSize, guessMSSize, -) where + ) +where import Control.Applicative ((<|>)) import Control.Arrow (first) import Control.Monad (foldM, unless) import Control.Monad.Identity (runIdentity) import Crypto.Secp256k1 -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial -import Data.Conduit ( - ConduitT, - Void, - await, - runConduit, - (.|), - ) +import Data.Conduit (ConduitT, Void, await, runConduit, (.|)) import Data.Conduit.List (sourceList) import Data.Either (fromRight) import Data.List (nub) @@ -70,508 +69,554 @@ import Data.Text (Text) import Data.Word (Word64) import Haskoin.Address import Haskoin.Crypto.Hash (Hash256, addressHash) +import Haskoin.Crypto.Keys.Common import Haskoin.Crypto.Signature -import Haskoin.Data -import Haskoin.Keys.Common import Haskoin.Network.Common +import Haskoin.Network.Data import Haskoin.Script -import Haskoin.Transaction.Builder.Sign ( - SigInput (..), - buildInput, - makeSignature, - sigKeys, - ) -import qualified Haskoin.Transaction.Builder.Sign as S +import Haskoin.Transaction.Builder.Sign (SigInput, buildInput, makeSignature, sigKeys) +import Haskoin.Transaction.Builder.Sign qualified as Sign import Haskoin.Transaction.Common -import Haskoin.Transaction.Segwit ( - decodeWitnessInput, - isSegwit, - viewWitnessProgram, - ) +import Haskoin.Transaction.Segwit import Haskoin.Util -{- | Any type can be used as a Coin if it can provide a value in Satoshi. - The value is used in coin selection algorithms. --} +-- | Any type can be used as a Coin if it can provide a value in Satoshi. +-- The value is used in coin selection algorithms. class Coin c where - coinValue :: c -> Word64 + coinValue :: c -> Word64 -{- | Coin selection algorithm for normal (non-multisig) transactions. This - function returns the selected coins together with the amount of change to - send back to yourself, taking the fee into account. --} +-- | Coin selection algorithm for normal (non-multisig) transactions. This +-- function returns the selected coins together with the amount of change to +-- send back to yourself, taking the fee into account. chooseCoins :: - Coin c => - -- | value to send - Word64 -> - -- | fee per byte - Word64 -> - -- | number of outputs (including change) - Int -> - -- | try to find better solutions - Bool -> - -- | list of ordered coins to choose from - [c] -> - -- | coin selection and change - Either String ([c], Word64) + (Coin c) => + -- | value to send + Word64 -> + -- | fee per byte + Word64 -> + -- | number of outputs (including change) + Int -> + -- | try to find better solutions + Bool -> + -- | list of ordered coins to choose from + [c] -> + -- | coin selection and change + Either String ([c], Word64) chooseCoins target fee nOut continue coins = - runIdentity . runConduit $ - sourceList coins .| chooseCoinsSink target fee nOut continue + runIdentity . runConduit $ + sourceList coins .| chooseCoinsSink target fee nOut continue -{- | Coin selection algorithm for normal (non-multisig) transactions. This - function returns the selected coins together with the amount of change to - send back to yourself, taking the fee into account. This version uses a Sink - for conduit-based coin selection. --} +-- | Coin selection algorithm for normal (non-multisig) transactions. This +-- function returns the selected coins together with the amount of change to +-- send back to yourself, taking the fee into account. This version uses a Sink +-- for conduit-based coin selection. chooseCoinsSink :: - (Monad m, Coin c) => - -- | value to send - Word64 -> - -- | fee per byte - Word64 -> - -- | number of outputs (including change) - Int -> - -- | try to find better solution - Bool -> - -- | coin selection and change - ConduitT c Void m (Either String ([c], Word64)) + (Monad m, Coin c) => + -- | value to send + Word64 -> + -- | fee per byte + Word64 -> + -- | number of outputs (including change) + Int -> + -- | try to find better solution + Bool -> + -- | coin selection and change + ConduitT c Void m (Either String ([c], Word64)) chooseCoinsSink target fee nOut continue - | target > 0 = - maybeToEither err - <$> greedyAddSink target (guessTxFee fee nOut) continue - | otherwise = return $ Left "chooseCoins: Target must be > 0" + | target > 0 = + maybeToEither err + <$> greedyAddSink target (guessTxFee fee nOut) continue + | otherwise = return $ Left "chooseCoins: Target must be > 0" where err = "chooseCoins: No solution found" -{- | Coin selection algorithm for multisig transactions. This function returns - the selected coins together with the amount of change to send back to - yourself, taking the fee into account. This function assumes all the coins - are script hash outputs that send funds to a multisignature address. --} +-- | Coin selection algorithm for multisig transactions. This function returns +-- the selected coins together with the amount of change to send back to +-- yourself, taking the fee into account. This function assumes all the coins +-- are script hash outputs that send funds to a multisignature address. chooseMSCoins :: - Coin c => - -- | value to send - Word64 -> - -- | fee per byte - Word64 -> - -- | m of n multisig - (Int, Int) -> - -- | number of outputs (including change) - Int -> - -- | try to find better solution - Bool -> - [c] -> - -- | coin selection change amount - Either String ([c], Word64) + (Coin c) => + -- | value to send + Word64 -> + -- | fee per byte + Word64 -> + -- | m of n multisig + (Int, Int) -> + -- | number of outputs (including change) + Int -> + -- | try to find better solution + Bool -> + [c] -> + -- | coin selection change amount + Either String ([c], Word64) chooseMSCoins target fee ms nOut continue coins = - runIdentity . runConduit $ - sourceList coins .| chooseMSCoinsSink target fee ms nOut continue + runIdentity . runConduit $ + sourceList coins .| chooseMSCoinsSink target fee ms nOut continue -{- | Coin selection algorithm for multisig transactions. This function returns - the selected coins together with the amount of change to send back to - yourself, taking the fee into account. This function assumes all the coins - are script hash outputs that send funds to a multisignature address. This - version uses a Sink if you need conduit-based coin selection. --} +-- | Coin selection algorithm for multisig transactions. This function returns +-- the selected coins together with the amount of change to send back to +-- yourself, taking the fee into account. This function assumes all the coins +-- are script hash outputs that send funds to a multisignature address. This +-- version uses a Sink if you need conduit-based coin selection. chooseMSCoinsSink :: - (Monad m, Coin c) => - -- | value to send - Word64 -> - -- | fee per byte - Word64 -> - -- | m of n multisig - (Int, Int) -> - -- | number of outputs (including change) - Int -> - -- | try to find better solution - Bool -> - -- | coin selection and change - ConduitT c Void m (Either String ([c], Word64)) + (Monad m, Coin c) => + -- | value to send + Word64 -> + -- | fee per byte + Word64 -> + -- | m of n multisig + (Int, Int) -> + -- | number of outputs (including change) + Int -> + -- | try to find better solution + Bool -> + -- | coin selection and change + ConduitT c Void m (Either String ([c], Word64)) chooseMSCoinsSink target fee ms nOut continue - | target > 0 = - maybeToEither err - <$> greedyAddSink target (guessMSTxFee fee ms nOut) continue - | otherwise = return $ Left "chooseMSCoins: Target must be > 0" + | target > 0 = + maybeToEither err + <$> greedyAddSink target (guessMSTxFee fee ms nOut) continue + | otherwise = return $ Left "chooseMSCoins: Target must be > 0" where err = "chooseMSCoins: No solution found" -{- | Select coins greedily by starting from an empty solution. If the 'continue' - flag is set, the algorithm will try to find a better solution in the stream - after a solution is found. If the next solution found is not strictly better - than the previously found solution, the algorithm stops and returns the - previous solution. If the continue flag is not set, the algorithm will return - the first solution it finds in the stream. --} +-- | Select coins greedily by starting from an empty solution. If the 'continue' +-- flag is set, the algorithm will try to find a better solution in the stream +-- after a solution is found. If the next solution found is not strictly better +-- than the previously found solution, the algorithm stops and returns the +-- previous solution. If the continue flag is not set, the algorithm will return +-- the first solution it finds in the stream. greedyAddSink :: - (Monad m, Coin c) => - -- | value to send - Word64 -> - -- | coin count to fee function - (Int -> Word64) -> - -- | try to find better solutions - Bool -> - -- | coin selection and change - ConduitT c Void m (Maybe ([c], Word64)) + (Monad m, Coin c) => + -- | value to send + Word64 -> + -- | coin count to fee function + (Int -> Word64) -> + -- | try to find better solutions + Bool -> + -- | coin selection and change + ConduitT c Void m (Maybe ([c], Word64)) greedyAddSink target guessFee continue = - go [] 0 [] 0 + go [] 0 [] 0 where -- The goal is the value we must reach (including the fee) for a certain -- amount of selected coins. goal c = target + guessFee c go acc aTot ps pTot = - await >>= \case - -- A coin is available in the stream - Just coin -> do - let val = coinValue coin - -- We have reached the goal using this coin - if val + aTot >= goal (length acc + 1) - then -- If we want to continue searching for better solutions + await >>= \case + -- A coin is available in the stream + Just coin -> do + let val = coinValue coin + -- We have reached the goal using this coin + if val + aTot >= goal (length acc + 1) + then -- If we want to continue searching for better solutions - if continue - then -- This solution is the first one or - -- This solution is better than the previous one + if continue + then -- This solution is the first one or + -- This solution is better than the previous one - if pTot == 0 || val + aTot < pTot - then -- Continue searching for better solutions in the stream - go [] 0 (coin : acc) (val + aTot) - else -- Otherwise, we stop here and return the previous - -- solution - return $ Just (ps, pTot - goal (length ps)) - else -- Otherwise, return this solution + if pTot == 0 || val + aTot < pTot + then -- Continue searching for better solutions in the stream + go [] 0 (coin : acc) (val + aTot) + else -- Otherwise, we stop here and return the previous + -- solution + return $ Just (ps, pTot - goal (length ps)) + else -- Otherwise, return this solution - return $ - Just (coin : acc, val + aTot - goal (length acc + 1)) - else -- We have not yet reached the goal. Add the coin to the - -- accumulator - go (coin : acc) (val + aTot) ps pTot - -- We reached the end of the stream - Nothing -> - return $ - if null ps - then -- If no solution was found, return Nothing - Nothing - else -- If we have a solution, return it - Just (ps, pTot - goal (length ps)) + return $ + Just (coin : acc, val + aTot - goal (length acc + 1)) + else -- We have not yet reached the goal. Add the coin to the + -- accumulator + go (coin : acc) (val + aTot) ps pTot + -- We reached the end of the stream + Nothing -> + return $ + if null ps + then -- If no solution was found, return Nothing + Nothing + else -- If we have a solution, return it + Just (ps, pTot - goal (length ps)) -- | Estimate tranasction fee to pay based on transaction size estimation. guessTxFee :: Word64 -> Int -> Int -> Word64 guessTxFee byteFee nOut nIn = - byteFee * fromIntegral (guessTxSize nIn [] nOut 0) + byteFee * fromIntegral (guessTxSize nIn [] nOut 0) -- | Same as 'guessTxFee' but for multisig transactions. guessMSTxFee :: Word64 -> (Int, Int) -> Int -> Int -> Word64 guessMSTxFee byteFee ms nOut nIn = - byteFee * fromIntegral (guessTxSize 0 (replicate nIn ms) nOut 0) + byteFee * fromIntegral (guessTxSize 0 (replicate nIn ms) nOut 0) -{- | Computes an upper bound on the size of a transaction based on some known - properties of the transaction. --} +-- | Computes an upper bound on the size of a transaction based on some known +-- properties of the transaction. guessTxSize :: - -- | number of regular transaction inputs - Int -> - -- | multisig m of n for each input - [(Int, Int)] -> - -- | number of P2PKH outputs - Int -> - -- | number of P2SH outputs - Int -> - -- | upper bound on transaction size - Int + -- | number of regular transaction inputs + Int -> + -- | multisig m of n for each input + [(Int, Int)] -> + -- | number of P2PKH outputs + Int -> + -- | number of P2SH outputs + Int -> + -- | upper bound on transaction size + Int guessTxSize pki msi pkout msout = - 8 + inpLen + inp + outLen + out + 8 + inpLen + inp + outLen + out where inpLen = - B.length - . runPutS - . serialize - . VarInt - . fromIntegral - $ length msi + pki + B.length + . runPutS + . serialize + . VarInt + . fromIntegral + $ length msi + pki outLen = - B.length - . runPutS - . serialize - . VarInt - . fromIntegral - $ pkout + msout + B.length + . runPutS + . serialize + . VarInt + . fromIntegral + $ pkout + msout inp = pki * 148 + sum (map guessMSSize msi) -- (20: hash160) + (5: opcodes) + -- (1: script len) + (8: Word64) out = - pkout * 34 - + - -- (20: hash160) + (3: opcodes) + - -- (1: script len) + (8: Word64) - msout * 32 + pkout * 34 + + + -- (20: hash160) + (3: opcodes) + + -- (20: hash160) + (3: opcodes) + + -- (20: hash160) + (3: opcodes) + + -- (20: hash160) + (3: opcodes) + + -- (1: script len) + (8: Word64) + -- (1: script len) + (8: Word64) + -- (1: script len) + (8: Word64) + -- (1: script len) + (8: Word64) + + -- (20: hash160) + (3: opcodes) + + + -- (20: hash160) + (3: opcodes) + + -- (1: script len) + (8: Word64) + -- (1: script len) + (8: Word64) + + -- (20: hash160) + (3: opcodes) + + -- (20: hash160) + (3: opcodes) + + -- (1: script len) + (8: Word64) + -- (1: script len) + (8: Word64) + + -- (20: hash160) + (3: opcodes) + + -- (1: script len) + (8: Word64) + msout * 32 -- | Size of a multisig P2SH input. guessMSSize :: (Int, Int) -> Int guessMSSize (m, n) = - -- OutPoint (36) + Sequence (4) + Script - 40 - + fromIntegral (B.length $ runPutS . serialize $ VarInt $ fromIntegral scp) - + scp + -- OutPoint (36) + Sequence (4) + Script + 40 + + fromIntegral (B.length $ runPutS . serialize $ VarInt $ fromIntegral scp) + + scp where -- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG rdm = - fromIntegral $ - B.length $ runPutS $ serialize $ opPushData $ B.replicate (n * 34 + 3) 0 + fromIntegral $ + B.length $ + runPutS $ + serialize $ + opPushData $ + B.replicate (n * 34 + 3) 0 -- Redeem + m*sig + OP_0 scp = rdm + m * 73 + 1 {- Build a new Tx -} -{- | Build a transaction by providing a list of outpoints as inputs - and a list of recipient addresses and amounts as outputs. --} -buildAddrTx :: Network -> [OutPoint] -> [(Text, Word64)] -> Either String Tx -buildAddrTx net ops rcps = - buildTx ops <$> mapM f rcps +-- | Build a transaction by providing a list of outpoints as inputs +-- and a list of recipient addresses and amounts as outputs. +buildAddrTx :: Network -> Ctx -> [OutPoint] -> [(Text, Word64)] -> Either String Tx +buildAddrTx net ctx ops rcps = + buildTx ctx ops <$> mapM f rcps where f (aTxt, v) = - maybeToEither ("buildAddrTx: Invalid address " <> cs aTxt) $ do - a <- textToAddr net aTxt - let o = addressToOutput a - return (o, v) + maybeToEither ("buildAddrTx: Invalid address " <> cs aTxt) $ do + a <- textToAddr net aTxt + let o = addressToOutput a + return (o, v) -{- | Build a transaction by providing a list of outpoints as inputs - and a list of 'ScriptOutput' and amounts as outputs. --} -buildTx :: [OutPoint] -> [(ScriptOutput, Word64)] -> Tx -buildTx ops rcpts = - Tx 1 (toIn <$> ops) (toOut <$> rcpts) [] 0 +-- | Build a transaction by providing a list of outpoints as inputs +-- and a list of 'ScriptOutput' and amounts as outputs. +buildTx :: Ctx -> [OutPoint] -> [(ScriptOutput, Word64)] -> Tx +buildTx ctx ops rcpts = + Tx 1 (toIn <$> ops) (toOut <$> rcpts) [] 0 where toIn op = TxIn op B.empty maxBound - toOut (o, v) = TxOut v $ encodeOutputBS o + toOut (o, v) = TxOut v $ marshal ctx o -{- | Sign a transaction by providing the 'SigInput' signing parameters and a - list of private keys. The signature is computed deterministically as defined - in RFC-6979. - - Example: P2SH-P2WKH - - > sigIn = SigInput (PayWitnessPKHash h) 100000 op sigHashAll Nothing - > signedTx = signTx btc unsignedTx [sigIn] [key] - - Example: P2SH-P2WSH multisig - - > sigIn = SigInput (PayWitnessScriptHash h) 100000 op sigHashAll (Just $ PayMulSig [p1,p2,p3] 2) - > signedTx = signTx btc unsignedTx [sigIn] [k1,k3] --} +-- | Sign a transaction by providing the 'SigInput' signing parameters and a +-- list of private keys. The signature is computed deterministically as defined +-- in RFC-6979. +-- +-- Example: P2SH-P2WKH +-- +-- > sigIn = SigInput (PayWitnessPKHash h) 100000 op sigHashAll Nothing +-- > signedTx = signTx btc unsignedTx [sigIn] [key] +-- +-- Example: P2SH-P2WSH multisig +-- +-- > sigIn = SigInput (PayWitnessScriptHash h) 100000 op sigHashAll (Just $ PayMulSig [p1,p2,p3] 2) +-- > signedTx = signTx btc unsignedTx [sigIn] [k1,k3] signTx :: - Network -> - -- | transaction to sign - Tx -> - -- | signing parameters - [SigInput] -> - -- | private keys to sign with - [SecKey] -> - -- | signed transaction - Either String Tx -signTx net tx si = S.signTx net tx $ notNested <$> si + Network -> + Ctx -> + -- | transaction to sign + Tx -> + -- | signing parameters + [SigInput] -> + -- | private keys to sign with + [SecKey] -> + -- | signed transaction + Either String Tx +signTx net ctx tx si = Sign.signTx net ctx tx $ notNested <$> si where notNested s = (s, False) -{- | This function differs from 'signTx' by assuming all segwit inputs are - P2SH-nested. Use the same signing parameters for segwit inputs as in 'signTx'. --} +-- | This function differs from 'signTx' by assuming all segwit inputs are +-- P2SH-nested. Use the same signing parameters for segwit inputs as in 'signTx'. signNestedWitnessTx :: - Network -> - -- | transaction to sign - Tx -> - -- | signing parameters - [SigInput] -> - -- | private keys to sign with - [SecKey] -> - -- | signed transaction - Either String Tx -signNestedWitnessTx net tx si = S.signTx net tx $ nested <$> si + Network -> + Ctx -> + -- | transaction to sign + Tx -> + -- | signing parameters + [SigInput] -> + -- | private keys to sign with + [SecKey] -> + -- | signed transaction + Either String Tx +signNestedWitnessTx net ctx tx si = Sign.signTx net ctx tx $ nested <$> si where -- NOTE: the nesting flag is ignored for non-segwit inputs nested s = (s, True) -- | Sign a single input in a transaction deterministically (RFC-6979). -signInput :: Network -> Tx -> Int -> SigInput -> SecKeyI -> Either String Tx -signInput net tx i si = S.signInput net tx i (si, False) +signInput :: + Network -> Ctx -> Tx -> Int -> SigInput -> PrivateKey -> Either String Tx +signInput net ctx tx i si = + Sign.signInput net ctx tx i (si, False) -- | Like 'signInput' but treat segwit inputs as nested -signNestedInput :: Network -> Tx -> Int -> SigInput -> SecKeyI -> Either String Tx -signNestedInput net tx i si = S.signInput net tx i (si, True) +signNestedInput :: + Network -> Ctx -> Tx -> Int -> SigInput -> PrivateKey -> Either String Tx +signNestedInput net ctx tx i si = + Sign.signInput net ctx tx i (si, True) -{- | Order the 'SigInput' with respect to the transaction inputs. This allows - the user to provide the 'SigInput' in any order. Users can also provide only - a partial set of 'SigInput' entries. --} +-- | Order the 'SigInput' with respect to the transaction inputs. This allows +-- the user to provide the 'SigInput' in any order. Users can also provide only +-- a partial set of 'SigInput' entries. findSigInput :: [SigInput] -> [TxIn] -> [(SigInput, Int)] -findSigInput = S.findInputIndex sigInputOP +findSigInput = Sign.findInputIndex (.outpoint) {- Merge multisig transactions -} -{- | Merge partially-signed multisig transactions. This function does not - support segwit and P2SH-segwit inputs. Use PSBTs to merge transactions with - segwit inputs. --} +-- | Merge partially-signed multisig transactions. This function does not +-- support segwit and P2SH-segwit inputs. Use PSBTs to merge transactions with +-- segwit inputs. mergeTxs :: - Network -> [Tx] -> [(ScriptOutput, Word64, OutPoint)] -> Either String Tx -mergeTxs net txs os - | null txs = Left "Transaction list is empty" - | length (nub emptyTxs) /= 1 = Left "Transactions do not match" - | length txs == 1 = return $ head txs - | otherwise = foldM (mergeTxInput net txs) (head emptyTxs) outs + Network -> + Ctx -> + [Tx] -> + [(ScriptOutput, Word64, OutPoint)] -> + Either String Tx +mergeTxs net ctx txs os + | null txs = Left "Transaction list is empty" + | length (nub emptyTxs) /= 1 = Left "Transactions do not match" + | length txs == 1 = return $ head txs + | otherwise = foldM (mergeTxInput net ctx txs) (head emptyTxs) outs where - zipOp = zip (matchTemplate os (txIn $ head txs) f) [0 ..] + zipOp = zip (matchTemplate os (head txs).inputs f) [0 ..] outs = - map (first $ (\(o, v, _) -> (o, v)) . fromJust) $ - filter (isJust . fst) zipOp - f (_, _, o) txin = o == prevOutput txin + map (first $ (\(o, v, _) -> (o, v)) . fromJust) $ + filter (isJust . fst) zipOp + f (_, _, o) txin = o == txin.outpoint emptyTxs = map (\tx -> foldl clearInput tx outs) txs - ins is i = updateIndex i is (\ti -> ti{scriptInput = B.empty}) + ins is i = updateIndex i is (\TxIn {..} -> TxIn {script = B.empty, ..}) clearInput tx (_, i) = - Tx (txVersion tx) (ins (txIn tx) i) (txOut tx) [] (txLockTime tx) + Tx tx.version (ins tx.inputs i) tx.outputs [] tx.locktime -{- | Merge input from partially-signed multisig transactions. This function - does not support segwit and P2SH-segwit inputs. --} +-- | Merge input from partially-signed multisig transactions. This function +-- does not support segwit and P2SH-segwit inputs. mergeTxInput :: - Network -> - [Tx] -> - Tx -> - ((ScriptOutput, Word64), Int) -> - Either String Tx -mergeTxInput net txs tx ((so, val), i) = do - -- Ignore transactions with empty inputs - let ins = map (scriptInput . (!! i) . txIn) txs - sigRes <- mapM extractSigs $ filter (not . B.null) ins - let rdm = snd $ head sigRes - unless (all ((== rdm) . snd) sigRes) $ Left "Redeem scripts do not match" - si <- encodeInputBS <$> go (nub $ concatMap fst sigRes) so rdm - let ins' = updateIndex i (txIn tx) (\ti -> ti{scriptInput = si}) - return $ Tx (txVersion tx) ins' (txOut tx) [] (txLockTime tx) + Network -> + Ctx -> + [Tx] -> + Tx -> + ((ScriptOutput, Word64), Int) -> + Either String Tx +mergeTxInput net ctx txs tx ((so, val), i) = do + -- Ignore transactions with empty inputs + let ins = map ((.script) . (!! i) . (.inputs)) txs + sigRes <- mapM extractSigs $ filter (not . B.null) ins + let rdm = snd $ head sigRes + unless (all ((== rdm) . snd) sigRes) $ Left "Redeem scripts do not match" + si <- marshal (net, ctx) <$> go (nub $ concatMap fst sigRes) so rdm + let ins' = updateIndex i tx.inputs (\TxIn {..} -> TxIn {script = si, ..}) + return $ Tx tx.version ins' tx.outputs [] tx.locktime where go allSigs out rdmM = - case out of - PayMulSig msPubs r -> - let sigs = - take r $ - catMaybes $ matchTemplate allSigs msPubs $ f out - in return $ RegularInput $ SpendMulSig sigs - PayScriptHash _ -> - case rdmM of - Just rdm -> do - si <- go allSigs rdm Nothing - return $ ScriptHashInput (getRegularInput si) rdm - _ -> Left "Invalid output script type" + case out of + PayMulSig msPubs r -> + let sigs = + take r $ + catMaybes $ + matchTemplate allSigs msPubs $ + f out + in return $ RegularInput $ SpendMulSig sigs + PayScriptHash _ -> + case rdmM of + Just rdm -> do + si <- go allSigs rdm Nothing + return $ ScriptHashInput si.get rdm _ -> Left "Invalid output script type" + _ -> Left "Invalid output script type" extractSigs si = - case decodeInputBS net si of - Right (RegularInput (SpendMulSig sigs)) -> Right (sigs, Nothing) - Right (ScriptHashInput (SpendMulSig sigs) rdm) -> - Right (sigs, Just rdm) - _ -> Left "Invalid script input type" + case unmarshal (net, ctx) si of + Right (RegularInput (SpendMulSig sigs)) -> + Right (sigs, Nothing) + Right (ScriptHashInput (SpendMulSig sigs) rdm) -> + Right (sigs, Just rdm) + _ -> Left "Invalid script input type" f out (TxSignature x sh) p = - verifyHashSig - (txSigHash net tx (encodeOutput out) val i sh) - x - (pubKeyPoint p) + verifyHashSig + ctx + (txSigHash net tx (encodeOutput ctx out) val i sh) + x + p.point f _ TxSignatureEmpty _ = False {- Tx verification -} -- | Verify if a transaction is valid and all of its inputs are standard. -verifyStdTx :: Network -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool -verifyStdTx net tx xs = - not (null (txIn tx)) && all go (zip (matchTemplate xs (txIn tx) f) [0 ..]) +verifyStdTx :: + Network -> Ctx -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool +verifyStdTx net ctx tx xs = + not (null tx.inputs) && all go (zip (matchTemplate xs tx.inputs f) [0 ..]) where - f (_, _, o) txin = o == prevOutput txin - go (Just (so, val, _), i) = verifyStdInput net tx i so val + f (_, _, o) txin = o == txin.outpoint + go (Just (so, val, _), i) = verifyStdInput net ctx tx i so val go _ = False -- | Verify if a transaction input is valid and standard. -verifyStdInput :: Network -> Tx -> Int -> ScriptOutput -> Word64 -> Bool -verifyStdInput net tx i so0 val - | isSegwit so0 = - fromRight False $ (inp == mempty &&) . verifySegwitInput so0 <$> wp so0 - | otherwise = - fromRight False $ - (verifyLegacyInput so0 <$> decodeInputBS net inp) - <|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so) +verifyStdInput :: Network -> Ctx -> Tx -> Int -> ScriptOutput -> Word64 -> Bool +verifyStdInput net ctx tx i so0 val + | isSegwit so0 = + fromRight False $ (inp == mempty &&) . verifySegwitInput so0 <$> wp so0 + | otherwise = + fromRight False $ + (verifyLegacyInput so0 <$> unmarshal (net, ctx) inp) + <|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so) where - inp = scriptInput $ txIn tx !! i - theTxSigHash so = S.makeSigHash net tx i so val + inp = (tx.inputs !! i).script + theTxSigHash so = Sign.makeSigHash net ctx tx i so val ws :: WitnessStack ws - | length (txWitness tx) > i = txWitness tx !! i - | otherwise = [] + | length tx.witness > i = tx.witness !! i + | otherwise = [] wp :: ScriptOutput -> Either String (Maybe ScriptOutput, SimpleInput) - wp so = decodeWitnessInput net =<< viewWitnessProgram net so ws + wp so = decodeWitnessInput net ctx =<< viewWitnessProgram net ctx so ws nestedScriptOutput :: Either String ScriptOutput nestedScriptOutput = - scriptOps <$> runGetS deserialize inp >>= \case - [OP_PUSHDATA bs _] -> decodeOutputBS bs - _ -> Left "nestedScriptOutput: not a nested output" + runGetS deserialize inp >>= dec . ops + where + ops (Script ops') = ops' + dec = \case + [OP_PUSHDATA bs _] -> unmarshal ctx bs + _ -> Left "nestedScriptOutput: not a nested output" verifyLegacyInput :: ScriptOutput -> ScriptInput -> Bool verifyLegacyInput so si = case (so, si) of - (PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) -> - verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) -> - pubKeyAddr pub == p2pkhAddr h - && verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayMulSig pubs r, RegularInput (SpendMulSig sigs)) -> - countMulSig net tx out val i (pubKeyPoint <$> pubs) sigs == r - (PayScriptHash h, ScriptHashInput si' rdm) -> - payToScriptAddress rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si') - _ -> False + (PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) -> + verifyHashSig ctx (theTxSigHash so sh Nothing) sig pub.point + (PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) -> + pubKeyAddr ctx pub == p2pkhAddr h + && verifyHashSig ctx (theTxSigHash so sh Nothing) sig pub.point + (PayMulSig pubs r, RegularInput (SpendMulSig sigs)) -> + countMulSig net ctx tx out val i ((.point) <$> pubs) sigs == r + (PayScriptHash h, ScriptHashInput si' rdm) -> + payToScriptAddress ctx rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si') + _ -> False where - out = encodeOutput so + out = encodeOutput ctx so verifySegwitInput :: - ScriptOutput -> (Maybe ScriptOutput, SimpleInput) -> Bool + ScriptOutput -> (Maybe ScriptOutput, SimpleInput) -> Bool verifySegwitInput so (rdm, si) = case (so, rdm, si) of - (PayWitnessPKHash h, Nothing, SpendPKHash (TxSignature sig sh) pub) -> - pubKeyWitnessAddr pub == p2wpkhAddr h - && verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayPK pub), SpendPK (TxSignature sig sh)) -> - payToWitnessScriptAddress rdm' == p2wshAddr h - && verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayPKHash kh), SpendPKHash (TxSignature sig sh) pub) -> - payToWitnessScriptAddress rdm' == p2wshAddr h - && addressHash (runPutS (serialize pub)) == kh - && verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) -> - payToWitnessScriptAddress rdm' == p2wshAddr h - && countMulSig' (\sh -> theTxSigHash so sh $ Just rdm') (pubKeyPoint <$> pubs) sigs == r - _ -> False + ( PayWitnessPKHash h, + Nothing, + SpendPKHash (TxSignature sig sh) pub + ) -> + let keytest = pubKeyWitnessAddr ctx pub == p2wpkhAddr h + sighash = theTxSigHash so sh Nothing + pkpoint = pub.point + verify = verifyHashSig ctx sighash sig pkpoint + in keytest && verify + ( PayWitnessScriptHash h, + Just rdm'@(PayPK pub), + SpendPK (TxSignature sig sh) + ) -> + let keytest = payToWitnessScriptAddress ctx rdm' == p2wshAddr h + sighash = theTxSigHash so sh $ Just rdm' + pkpoint = pub.point + verify = verifyHashSig ctx sighash sig pkpoint + in keytest && verify + ( PayWitnessScriptHash h, + Just rdm'@(PayPKHash kh), + SpendPKHash (TxSignature sig sh) pub + ) -> + let keytest = payToWitnessScriptAddress ctx rdm' == p2wshAddr h + addrtest = addressHash (marshal ctx pub) == kh + pkpoint = pub.point + sighash = theTxSigHash so sh $ Just rdm' + verify = verifyHashSig ctx sighash sig pkpoint + in keytest && addrtest && verify + ( PayWitnessScriptHash h, + Just rdm'@(PayMulSig pubs r), + SpendMulSig sigs + ) -> + let keytest = payToWitnessScriptAddress ctx rdm' == p2wshAddr h + pkpoints = (.point) <$> pubs + hashfun sh = theTxSigHash so sh $ Just rdm' + verify = countMulSig' ctx hashfun pkpoints sigs == r + in keytest && verify + _ -> False verifyNestedInput :: - ScriptOutput -> ScriptOutput -> (Maybe RedeemScript, SimpleInput) -> Bool + ScriptOutput -> ScriptOutput -> (Maybe RedeemScript, SimpleInput) -> Bool verifyNestedInput so so' x = case so of - PayScriptHash h -> payToScriptAddress so' == p2shAddr h && verifySegwitInput so' x - _ -> False + PayScriptHash h -> payToScriptAddress ctx so' == p2shAddr h && verifySegwitInput so' x + _ -> False -- | Count the number of valid signatures for a multi-signature transaction. countMulSig :: - Network -> - Tx -> - Script -> - Word64 -> - Int -> - [PubKey] -> - [TxSignature] -> - Int -countMulSig net tx out val i = - countMulSig' h + Network -> + Ctx -> + Tx -> + Script -> + Word64 -> + Int -> + [PubKey] -> + [TxSignature] -> + Int +countMulSig net ctx tx out val i = + countMulSig' ctx h where h = txSigHash net tx out val i -countMulSig' :: (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int -countMulSig' _ [] _ = 0 -countMulSig' _ _ [] = 0 -countMulSig' h (_ : pubs) (TxSignatureEmpty : sigs) = countMulSig' h pubs sigs -countMulSig' h (pub : pubs) sigs@(TxSignature sig sh : sigs') - | verifyHashSig (h sh) sig pub = 1 + countMulSig' h pubs sigs' - | otherwise = countMulSig' h pubs sigs +countMulSig' :: Ctx -> (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int +countMulSig' _ _ [] _ = 0 +countMulSig' _ _ _ [] = 0 +countMulSig' ctx h (_ : pubs) (TxSignatureEmpty : sigs) = + countMulSig' ctx h pubs sigs +countMulSig' ctx h (pub : pubs) sigs@(TxSignature sig sh : sigs') + | verifyHashSig ctx (h sh) sig pub = 1 + countMulSig' ctx h pubs sigs' + | otherwise = countMulSig' ctx h pubs sigs diff --git a/src/Haskoin/Transaction/Builder/Sign.hs b/src/Haskoin/Transaction/Builder/Sign.hs index adc4f245..81d520db 100644 --- a/src/Haskoin/Transaction/Builder/Sign.hs +++ b/src/Haskoin/Transaction/Builder/Sign.hs @@ -1,20 +1,25 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Transaction.Builder.Sign -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Types and logic for signing transactions. --} -module Haskoin.Transaction.Builder.Sign ( - SigInput (..), +-- | +-- Module : Haskoin.Transaction.Builder.Sign +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Types and logic for signing transactions. +module Haskoin.Transaction.Builder.Sign + ( SigInput (..), makeSignature, makeSigHash, signTx, @@ -22,298 +27,296 @@ module Haskoin.Transaction.Builder.Sign ( signInput, buildInput, sigKeys, -) where + ) +where -import Control.DeepSeq (NFData) -import Control.Monad (foldM, when) -import Data.Aeson ( - FromJSON, - ToJSON (..), - object, - pairs, - parseJSON, - withObject, - (.:), - (.:?), - (.=), - ) +import Control.DeepSeq +import Control.Monad +import Crypto.Secp256k1 +import Data.Aeson +import Data.Aeson.Encoding import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial -import Data.Either (rights) -import Data.Hashable (Hashable) -import Data.List (find, nub) -import Data.Maybe ( - catMaybes, - fromMaybe, - mapMaybe, - maybeToList, - ) -import Data.Word (Word64) -import GHC.Generics (Generic) -import Haskoin.Address (getAddrHash160, pubKeyAddr) -import Haskoin.Crypto (Hash256, SecKey) -import Haskoin.Crypto.Signature (signHash, verifyHashSig) -import Haskoin.Data (Network) -import Haskoin.Keys.Common ( - PubKeyI (..), - SecKeyI (..), - derivePubKeyI, - wrapSecKey, - ) +import Data.Either +import Data.Hashable +import Data.List +import Data.Maybe +import Data.Word +import GHC.Generics +import Haskoin.Address +import Haskoin.Crypto.Hash +import Haskoin.Crypto.Keys.Common +import Haskoin.Crypto.Signature +import Haskoin.Network.Data import Haskoin.Script import Haskoin.Transaction.Common import Haskoin.Transaction.Segwit -import Haskoin.Util (matchTemplate, updateIndex) +import Haskoin.Util -{- | Data type used to specify the signing parameters of a transaction input. - To sign an input, the previous output script, outpoint and sighash are - required. When signing a pay to script hash output, an additional redeem - script is required. --} +-- | Data type used to specify the signing parameters of a transaction input. +-- To sign an input, the previous output script, outpoint and sighash are +-- required. When signing a pay to script hash output, an additional redeem +-- script is required. data SigInput = SigInput - { -- | output script to spend - -- ^ output script value - sigInputScript :: !ScriptOutput - , -- | output script value - -- ^ outpoint to spend - sigInputValue :: !Word64 - , -- | outpoint to spend - -- ^ signature type - sigInputOP :: !OutPoint - , -- | signature type - -- ^ redeem script - sigInputSH :: !SigHash - , -- | redeem script - sigInputRedeem :: !(Maybe RedeemScript) - } - deriving (Eq, Show, Read, Generic, Hashable, NFData) + { -- | output script to spend + -- ^ output script value + script :: !ScriptOutput, + -- | output script value + -- ^ outpoint to spend + value :: !Word64, + -- | outpoint to spend + -- ^ signature type + outpoint :: !OutPoint, + -- | signature type + -- ^ redeem script + sighash :: !SigHash, + -- | redeem script + redeem :: !(Maybe RedeemScript) + } + deriving (Show, Read, Eq, Generic, NFData) -instance ToJSON SigInput where - toJSON (SigInput so val op sh rdm) = - object $ - [ "pkscript" .= so - , "value" .= val - , "outpoint" .= op - , "sighash" .= sh - ] - ++ ["redeem" .= r | r <- maybeToList rdm] - toEncoding (SigInput so val op sh rdm) = - pairs $ - "pkscript" .= so - <> "value" .= val - <> "outpoint" .= op - <> "sighash" .= sh - <> maybe mempty ("redeem" .=) rdm +instance MarshalJSON Ctx SigInput where + marshalValue ctx (SigInput s v o h r) = + object $ + [ "pkscript" .= marshalValue ctx s, + "value" .= v, + "outpoint" .= o, + "sighash" .= h + ] + ++ [ "redeem" .= marshalValue ctx r + | r <- maybeToList r + ] -instance FromJSON SigInput where - parseJSON = - withObject "SigInput" $ \o -> - SigInput <$> o .: "pkscript" - <*> o .: "value" - <*> o .: "outpoint" - <*> o .: "sighash" - <*> o .:? "redeem" + marshalEncoding ctx (SigInput s v o h r) = + pairs $ + mconcat + [ "pkscript" `pair` marshalEncoding ctx s, + "value" `pair` word64 v, + "outpoint" `pair` toEncoding o, + "sighash" `pair` toEncoding h, + maybe mempty (pair "redeem" . marshalEncoding ctx) r + ] -{- | Sign a transaction by providing the 'SigInput' signing parameters and a - list of private keys. The signature is computed deterministically as defined - in RFC-6979. --} + unmarshalValue ctx = + withObject "SigInput" $ \o -> + SigInput + <$> (unmarshalValue ctx =<< o .: "pkscript") + <*> o .: "value" + <*> o .: "outpoint" + <*> o .: "sighash" + <*> (mapM (unmarshalValue ctx) =<< o .:? "redeem") + +-- | Sign a transaction by providing the 'SigInput' signing parameters and a +-- list of private keys. The signature is computed deterministically as defined +-- in RFC-6979. signTx :: - Network -> - -- | transaction to sign - Tx -> - -- | signing parameters, with nesting flag - [(SigInput, Bool)] -> - -- | private keys to sign with - [SecKey] -> - -- | signed transaction - Either String Tx -signTx net otx sigis allKeys - | null ti = Left "signTx: Transaction has no inputs" - | otherwise = foldM go otx $ findInputIndex (sigInputOP . fst) sigis ti + Network -> + Ctx -> + -- | transaction to sign + Tx -> + -- | signing parameters, with nesting flag + [(SigInput, Bool)] -> + -- | private keys to sign with + [SecKey] -> + -- | signed transaction + Either String Tx +signTx net ctx otx sigis allKeys + | null ti = Left "signTx: Transaction has no inputs" + | otherwise = foldM go otx $ findInputIndex ((.outpoint) . fst) sigis ti where - ti = txIn otx + ti = otx.inputs go tx (sigi@(SigInput so _ _ _ rdmM, _), i) = do - keys <- sigKeys so rdmM allKeys - foldM (\t k -> signInput net t i sigi k) tx keys + keys <- sigKeys ctx so rdmM allKeys + foldM (\t k -> signInput net ctx t i sigi k) tx keys -{- | Sign a single input in a transaction deterministically (RFC-6979). The - nesting flag only affects the behavior of segwit inputs. --} +-- | Sign a single input in a transaction deterministically (RFC-6979). The +-- nesting flag only affects the behavior of segwit inputs. signInput :: - Network -> - Tx -> - Int -> - -- | boolean flag: nest input - (SigInput, Bool) -> - SecKeyI -> - Either String Tx -signInput net tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do - let sig = makeSignature net tx i sigIn key - si <- buildInput net tx i so val rdmM sig $ derivePubKeyI key - w <- updatedWitnessData tx i so si - return - tx - { txIn = nextTxIn so si - , txWitness = w - } + Network -> + Ctx -> + Tx -> + Int -> + -- | boolean flag: nest input + (SigInput, Bool) -> + PrivateKey -> + Either String Tx +signInput net ctx tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do + let sig = makeSignature net ctx tx i sigIn key + si <- buildInput net ctx tx i so val rdmM sig $ derivePublicKey ctx key + w <- updatedWitnessData net ctx tx i so si + return tx {inputs = nextTxIn so si, witness = w} where - f si x = x{scriptInput = encodeInputBS si} - g so' x = x{scriptInput = runPutS . serialize . opPushData $ encodeOutputBS so'} - txis = txIn tx + f si TxIn {..} = TxIn {script = marshal (net, ctx) si, ..} + g so' TxIn {..} = TxIn {script = pkScript so', ..} + pkScript so' = runPutS . serialize . opPushData $ marshal ctx so' nextTxIn so' si - | isSegwit so' && nest = updateIndex i txis (g so') - | isSegwit so' = txIn tx - | otherwise = updateIndex i txis (f si) + | isSegwit so' && nest = updateIndex i tx.inputs (g so') + | isSegwit so' = tx.inputs + | otherwise = updateIndex i tx.inputs (f si) -{- | Add the witness data of the transaction given segwit parameters for an input. - - @since 0.11.0.0 --} -updatedWitnessData :: Tx -> Int -> ScriptOutput -> ScriptInput -> Either String WitnessData -updatedWitnessData tx i so si - | isSegwit so = updateWitness . toWitnessStack =<< calcWitnessProgram so si - | otherwise = return $ txWitness tx +-- | Add the witness data of the transaction given segwit parameters for an input. +-- +-- @since 0.11.0.0 +updatedWitnessData :: + Network -> + Ctx -> + Tx -> + Int -> + ScriptOutput -> + ScriptInput -> + Either String WitnessData +updatedWitnessData net ctx tx i so si + | isSegwit so = + updateWitness . toWitnessStack net ctx =<< calcWitnessProgram net ctx so si + | otherwise = + return tx.witness where updateWitness w - | null $ txWitness tx = return $ updateIndex i defaultStack (const w) - | length (txWitness tx) /= n = Left "Invalid number of witness stacks" - | otherwise = return $ updateIndex i (txWitness tx) (const w) - defaultStack = replicate n $ toWitnessStack EmptyWitnessProgram - n = length $ txIn tx + | null tx.witness = return $ updateIndex i defaultStack (const w) + | length tx.witness /= n = Left "Invalid number of witness stacks" + | otherwise = return $ updateIndex i tx.witness (const w) + defaultStack = replicate n $ toWitnessStack net ctx EmptyWitnessProgram + n = length tx.inputs -- | Associate an input index to each value in a list findInputIndex :: - -- | extract an outpoint - (a -> OutPoint) -> - -- | input list - [a] -> - -- | reference list of inputs - [TxIn] -> - [(a, Int)] + -- | extract an outpoint + (a -> OutPoint) -> + -- | input list + [a] -> + -- | reference list of inputs + [TxIn] -> + [(a, Int)] findInputIndex getOutPoint as ti = - mapMaybe g $ zip (matchTemplate as ti f) [0 ..] + mapMaybe g $ zip (matchTemplate as ti f) [0 ..] where - f s txin = getOutPoint s == prevOutput txin + f s txin = getOutPoint s == txin.outpoint g (Just s, i) = Just (s, i) g (Nothing, _) = Nothing -{- | Find from the list of provided private keys which one is required to sign - the 'ScriptOutput'. --} +-- | Find from the list of provided private keys which one is required to sign +-- the 'ScriptOutput'. sigKeys :: - ScriptOutput -> - Maybe RedeemScript -> - [SecKey] -> - Either String [SecKeyI] -sigKeys so rdmM keys = - case (so, rdmM) of - (PayPK p, Nothing) -> - return . map fst . maybeToList $ find ((== p) . snd) zipKeys - (PayPKHash h, Nothing) -> return $ keyByHash h - (PayMulSig ps r, Nothing) -> - return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys - (PayScriptHash _, Just rdm) -> sigKeys rdm Nothing keys - (PayWitnessPKHash h, _) -> return $ keyByHash h - (PayWitnessScriptHash _, Just rdm) -> sigKeys rdm Nothing keys - _ -> Left "sigKeys: Could not decode output script" + Ctx -> + ScriptOutput -> + Maybe RedeemScript -> + [SecKey] -> + Either String [PrivateKey] +sigKeys ctx so rdmM keys = + case (so, rdmM) of + (PayPK p, Nothing) -> + return . map fst . maybeToList $ find ((== p) . snd) zipKeys + (PayPKHash h, Nothing) -> return $ keyByHash h + (PayMulSig ps r, Nothing) -> + return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys + (PayScriptHash _, Just rdm) -> sigKeys ctx rdm Nothing keys + (PayWitnessPKHash h, _) -> return $ keyByHash h + (PayWitnessScriptHash _, Just rdm) -> sigKeys ctx rdm Nothing keys + _ -> Left "sigKeys: Could not decode output script" where zipKeys = - [ (prv, pub) - | k <- keys - , t <- [True, False] - , let prv = wrapSecKey t k - , let pub = derivePubKeyI prv - ] + [ (prv, pub) + | k <- keys, + t <- [True, False], + let prv = wrapSecKey t k, + let pub = derivePublicKey ctx prv + ] keyByHash h = fmap fst . maybeToList . findKey h $ zipKeys - findKey h = find $ (== h) . getAddrHash160 . pubKeyAddr . snd + findKey h = find $ (== h) . (.hash160) . pubKeyAddr ctx . snd -{- | Construct an input for a transaction given a signature, public key and data - about the previous output. --} +-- | Construct an input for a transaction given a signature, public key and data +-- about the previous output. buildInput :: - Network -> - -- | transaction where input will be added - Tx -> - -- | input index where signature will go - Int -> - -- | output script being spent - ScriptOutput -> - -- | amount of previous output - Word64 -> - -- | redeem script if pay-to-script-hash - Maybe RedeemScript -> - TxSignature -> - PubKeyI -> - Either String ScriptInput -buildInput net tx i so val rdmM sig pub = do - when (i >= length (txIn tx)) $ Left "buildInput: Invalid input index" - case (so, rdmM) of - (PayScriptHash _, Just rdm) -> buildScriptHashInput rdm - (PayWitnessScriptHash _, Just rdm) -> buildScriptHashInput rdm - (PayWitnessPKHash _, Nothing) -> return . RegularInput $ SpendPKHash sig pub - (_, Nothing) -> buildRegularInput so - _ -> Left "buildInput: Invalid output/redeem script combination" + Network -> + Ctx -> + -- | transaction where input will be added + Tx -> + -- | input index where signature will go + Int -> + -- | output script being spent + ScriptOutput -> + -- | amount of previous output + Word64 -> + -- | redeem script if pay-to-script-hash + Maybe RedeemScript -> + TxSignature -> + PublicKey -> + Either String ScriptInput +buildInput net ctx tx i so val rdmM sig pub = do + when (i >= length tx.inputs) $ Left "buildInput: Invalid input index" + case (so, rdmM) of + (PayScriptHash _, Just rdm) -> + buildScriptHashInput rdm + (PayWitnessScriptHash _, Just rdm) -> + buildScriptHashInput rdm + (PayWitnessPKHash _, Nothing) -> + return . RegularInput $ SpendPKHash sig pub + (_, Nothing) -> + buildRegularInput so + _ -> Left "buildInput: Invalid output/redeem script combination" where buildRegularInput = \case - PayPK _ -> return $ RegularInput $ SpendPK sig - PayPKHash _ -> return $ RegularInput $ SpendPKHash sig pub - PayMulSig msPubs r -> do - let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f - allSigs = nub $ sig : parseExistingSigs net tx so i - return $ RegularInput $ SpendMulSig mSigs - _ -> Left "buildInput: Invalid output/redeem script combination" + PayPK _ -> return $ RegularInput $ SpendPK sig + PayPKHash _ -> return $ RegularInput $ SpendPKHash sig pub + PayMulSig msPubs r -> do + let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f + allSigs = nub $ sig : parseExistingSigs net ctx tx so i + return $ RegularInput $ SpendMulSig mSigs + _ -> Left "buildInput: Invalid output/redeem script combination" buildScriptHashInput rdm = do - inp <- buildRegularInput rdm - return $ ScriptHashInput (getRegularInput inp) rdm + inp <- buildRegularInput rdm + return $ ScriptHashInput inp.get rdm f (TxSignature x sh) p = - verifyHashSig (makeSigHash net tx i so val sh rdmM) x (pubKeyPoint p) + verifyHashSig + ctx + (makeSigHash net ctx tx i so val sh rdmM) + x + p.point f TxSignatureEmpty _ = False -{- | Apply heuristics to extract the signatures for a particular input that are - embedded in the transaction. - - @since 0.11.0.0 --} -parseExistingSigs :: Network -> Tx -> ScriptOutput -> Int -> [TxSignature] -parseExistingSigs net tx so i = insSigs <> witSigs +-- | Apply heuristics to extract the signatures for a particular input that are +-- embedded in the transaction. +-- +-- @since 0.11.0.0 +parseExistingSigs :: Network -> Ctx -> Tx -> ScriptOutput -> Int -> [TxSignature] +parseExistingSigs net ctx tx so i = insSigs <> witSigs where - insSigs = case decodeInputBS net scp of - Right (ScriptHashInput (SpendMulSig xs) _) -> xs - Right (RegularInput (SpendMulSig xs)) -> xs - _ -> [] - scp = scriptInput $ txIn tx !! i + insSigs = case unmarshal (net, ctx) scp of + Right (ScriptHashInput (SpendMulSig xs) _) -> xs + Right (RegularInput (SpendMulSig xs)) -> xs + _ -> [] + scp = (tx.inputs !! i).script witSigs - | not $ isSegwit so = [] - | null $ txWitness tx = [] - | otherwise = rights $ decodeTxSig net <$> (txWitness tx !! i) + | not $ isSegwit so = [] + | null tx.witness = [] + | otherwise = rights $ decodeTxSig net ctx <$> (tx.witness !! i) -- | Produce a structured representation of a deterministic (RFC-6979) signature over an input. -makeSignature :: Network -> Tx -> Int -> SigInput -> SecKeyI -> TxSignature -makeSignature net tx i (SigInput so val _ sh rdmM) key = - TxSignature (signHash (secKeyData key) m) sh +makeSignature :: Network -> Ctx -> Tx -> Int -> SigInput -> PrivateKey -> TxSignature +makeSignature net ctx tx i (SigInput so val _ sh rdmM) key = + TxSignature (signHash ctx key.key m) sh where - m = makeSigHash net tx i so val sh rdmM + m = makeSigHash net ctx tx i so val sh rdmM -{- | A function which selects the digest algorithm and parameters as appropriate - - @since 0.11.0.0 --} +-- | A function which selects the digest algorithm and parameters as appropriate +-- +-- @since 0.11.0.0 makeSigHash :: - Network -> - Tx -> - Int -> - ScriptOutput -> - Word64 -> - SigHash -> - Maybe RedeemScript -> - Hash256 -makeSigHash net tx i so val sh rdmM = h net tx (encodeOutput so') val i sh + Network -> + Ctx -> + Tx -> + Int -> + ScriptOutput -> + Word64 -> + SigHash -> + Maybe RedeemScript -> + Hash256 +makeSigHash net ctx tx i so val sh rdmM = h net tx (encodeOutput ctx so') val i sh where so' = case so of - PayWitnessPKHash h' -> PayPKHash h' - _ -> fromMaybe so rdmM + PayWitnessPKHash h' -> PayPKHash h' + _ -> fromMaybe so rdmM h - | isSegwit so = txSigHashForkId - | otherwise = txSigHash + | isSegwit so = txSigHashForkId + | otherwise = txSigHash diff --git a/src/Haskoin/Transaction/Common.hs b/src/Haskoin/Transaction/Common.hs index 052bb5ab..323a4559 100644 --- a/src/Haskoin/Transaction/Common.hs +++ b/src/Haskoin/Transaction/Common.hs @@ -1,19 +1,25 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Transaction.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Code related to transactions parsing and serialization. --} -module Haskoin.Transaction.Common ( - -- * Transactions +-- | +-- Module : Haskoin.Transaction.Common +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Code related to transactions parsing and serialization. +module Haskoin.Transaction.Common + ( -- * Transactions Tx (..), TxIn (..), TxOut (..), @@ -27,27 +33,20 @@ module Haskoin.Transaction.Common ( txHashToHex, nosigTxHash, nullOutPoint, -) where + ) +where import Control.Applicative ((<|>)) import Control.DeepSeq -import Control.Monad ( - forM_, - guard, - liftM2, - mzero, - replicateM, - unless, - when, - (<=<), - ) +import Control.Monad (forM_, guard, liftM2, mzero, replicateM, unless, when, (<=<)) import Data.Aeson as A -import Data.Aeson.Encoding (unsafeToEncoding) +import Data.Aeson.Encoding qualified as E import Data.Binary (Binary (..)) +import Data.Bool (bool) import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.ByteString.Builder (char7) -import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Lazy qualified as BL import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -61,67 +60,67 @@ import Data.Word (Word32, Word64) import GHC.Generics (Generic) import Haskoin.Crypto.Hash import Haskoin.Network.Common -import Haskoin.Util +import Haskoin.Util.Helpers import Text.Read as R -- | Transaction id: hash of transaction excluding witness data. -newtype TxHash = TxHash {getTxHash :: Hash256} - deriving (Eq, Ord, Generic, Hashable, Serial, NFData) +newtype TxHash = TxHash {get :: Hash256} + deriving (Eq, Ord, Generic) + deriving newtype (Hashable, NFData) + +instance Serial TxHash where + serialize (TxHash h) = serialize h + deserialize = TxHash <$> deserialize instance Serialize TxHash where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Binary TxHash where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Show TxHash where - showsPrec _ = shows . txHashToHex + showsPrec _ = shows . txHashToHex instance Read TxHash where - readPrec = do - R.String str <- R.lexP - maybe R.pfail return $ hexToTxHash $ cs str + readPrec = do + R.String str <- R.lexP + maybe R.pfail return $ hexToTxHash $ cs str instance IsString TxHash where - fromString s = - let e = error "Could not read transaction hash from hex string" - in fromMaybe e $ hexToTxHash $ cs s + fromString s = + let e = error "Could not read transaction hash from hex string" + in fromMaybe e $ hexToTxHash $ cs s instance FromJSON TxHash where - parseJSON = - withText "txid" $ - maybe mzero return . hexToTxHash + parseJSON = + withText "txid" $ + maybe mzero return . hexToTxHash instance ToJSON TxHash where - toJSON = A.String . txHashToHex - toEncoding h = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (BL.reverse (runPutL (serialize h))) - <> char7 '"' + toJSON = A.String . txHashToHex + toEncoding = hexEncoding . BL.reverse . runPutL . serialize -- | Transaction hash excluding signatures. nosigTxHash :: Tx -> TxHash -nosigTxHash tx = - TxHash $ - doubleSHA256 $ - runPutS $ - serialize tx{txIn = map clearInput $ txIn tx} +nosigTxHash Tx {..} = + TxHash . doubleSHA256 . runPutS $ serialize tx where - clearInput ti = ti{scriptInput = B.empty} + tx = Tx {inputs = map clr inputs, ..} + clr TxIn {..} = TxIn {script = B.empty, ..} -- | Convert transaction hash to hex form, reversing bytes. txHashToHex :: TxHash -> Text -txHashToHex (TxHash h) = encodeHex (B.reverse (runPutS (serialize h))) +txHashToHex (TxHash h) = + encodeHex . B.reverse . runPutS $ serialize h -- | Convert transaction hash from hex, reversing bytes. hexToTxHash :: Text -> Maybe TxHash hexToTxHash hex = do - bs <- B.reverse <$> decodeHex hex - h <- either (const Nothing) Just (runGetS deserialize bs) - return $ TxHash h + bs <- B.reverse <$> decodeHex hex + h <- either (const Nothing) Just (runGetS deserialize bs) + return $ TxHash h -- | Witness stack for SegWit transactions. type WitnessData = [WitnessStack] @@ -134,289 +133,297 @@ type WitnessStackItem = ByteString -- | Data type representing a transaction. data Tx = Tx - { -- | transaction data format version - txVersion :: !Word32 - , -- | list of transaction inputs - txIn :: ![TxIn] - , -- | list of transaction outputs - txOut :: ![TxOut] - , -- | witness data for the transaction - txWitness :: !WitnessData - , -- | earliest mining height or time - txLockTime :: !Word32 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + { -- | transaction data format version + version :: !Word32, + -- | list of transaction inputs + inputs :: ![TxIn], + -- | list of transaction outputs + outputs :: ![TxOut], + -- | witness data for the transaction + witness :: !WitnessData, + -- | earliest mining height or time + locktime :: !Word32 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) -- | Compute transaction hash. txHash :: Tx -> TxHash -txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx{txWitness = []} +txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx {witness = []} instance IsString Tx where - fromString = - fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs - where - e = error "Could not read transaction from hex string" + fromString = + fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs + where + e = error "Could not read transaction from hex string" instance Serial Tx where - deserialize = - isWitnessTx >>= \w -> if w then parseWitnessTx else parseLegacyTx - serialize tx - | null (txWitness tx) = putLegacyTx tx - | otherwise = putWitnessTx tx + deserialize = isWitnessTx >>= bool parseLegacyTx parseWitnessTx + serialize tx + | null tx.witness = putLegacyTx tx + | otherwise = putWitnessTx tx instance Binary Tx where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize Tx where - put = serialize - get = deserialize + put = serialize + get = deserialize -putInOut :: MonadPut m => Tx -> m () +putInOut :: (MonadPut m) => Tx -> m () putInOut tx = do - putVarInt $ length (txIn tx) - forM_ (txIn tx) serialize - putVarInt $ length (txOut tx) - forM_ (txOut tx) serialize + putVarInt $ length tx.inputs + mapM_ serialize tx.inputs + putVarInt $ length tx.outputs + mapM_ serialize tx.outputs -- | Non-SegWit transaction serializer. -putLegacyTx :: MonadPut m => Tx -> m () +putLegacyTx :: (MonadPut m) => Tx -> m () putLegacyTx tx = do - putWord32le (txVersion tx) - putInOut tx - putWord32le (txLockTime tx) + putWord32le tx.version + putInOut tx + putWord32le tx.locktime -- | Witness transaciton serializer. -putWitnessTx :: MonadPut m => Tx -> m () +putWitnessTx :: (MonadPut m) => Tx -> m () putWitnessTx tx = do - putWord32le (txVersion tx) - putWord8 0x00 - putWord8 0x01 - putInOut tx - putWitnessData (txWitness tx) - putWord32le (txLockTime tx) + putWord32le tx.version + putWord8 0x00 + putWord8 0x01 + putInOut tx + putWitnessData tx.witness + putWord32le tx.locktime -isWitnessTx :: MonadGet m => m Bool +isWitnessTx :: (MonadGet m) => m Bool isWitnessTx = lookAhead $ do - _ <- getWord32le - m <- getWord8 - f <- getWord8 - return (m == 0x00 && f == 0x01) + _ <- getWord32le + m <- getWord8 + f <- getWord8 + return (m == 0x00 && f == 0x01) -- | Non-SegWit transaction deseralizer. -parseLegacyTx :: MonadGet m => m Tx +parseLegacyTx :: (MonadGet m) => m Tx parseLegacyTx = do - v <- getWord32le - is <- replicateList =<< deserialize - os <- replicateList =<< deserialize - when (length is == 0x00 && length os == 0x01) $ fail "Witness transaction" - l <- getWord32le - return - Tx - { txVersion = v - , txIn = is - , txOut = os - , txWitness = [] - , txLockTime = l - } + version <- getWord32le + inputs <- rl =<< deserialize + outputs <- rl =<< deserialize + when (length inputs == 0x00 && length outputs == 0x01) $ + fail "Witness transaction" + locktime <- getWord32le + return Tx {witness = [], ..} where - replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + rl (VarInt c) = replicateM (fromIntegral c) deserialize -- | Witness transaction deserializer. -parseWitnessTx :: MonadGet m => m Tx +parseWitnessTx :: (MonadGet m) => m Tx parseWitnessTx = do - v <- getWord32le - m <- getWord8 - f <- getWord8 - unless (m == 0x00 && f == 0x01) $ fail "Not a witness transaction" - is <- replicateList =<< deserialize - os <- replicateList =<< deserialize - w <- parseWitnessData $ length is - l <- getWord32le - return - Tx{txVersion = v, txIn = is, txOut = os, txWitness = w, txLockTime = l} + version <- getWord32le + m <- getWord8 + f <- getWord8 + unless (m == 0x00 && f == 0x01) $ fail "Not a witness transaction" + inputs <- replicateList =<< deserialize + outputs <- replicateList =<< deserialize + witness <- parseWitnessData $ length inputs + locktime <- getWord32le + return Tx {..} where replicateList (VarInt c) = replicateM (fromIntegral c) deserialize -- | Witness data deserializer. Requires count of inputs. -parseWitnessData :: MonadGet m => Int -> m WitnessData +parseWitnessData :: (MonadGet m) => Int -> m WitnessData parseWitnessData n = replicateM n parseWitnessStack where parseWitnessStack = do - VarInt i <- deserialize - replicateM (fromIntegral i) parseWitnessStackItem + VarInt i <- deserialize + replicateM (fromIntegral i) parseWitnessStackItem parseWitnessStackItem = do - VarInt i <- deserialize - getByteString $ fromIntegral i + VarInt i <- deserialize + getByteString $ fromIntegral i -- | Witness data serializer. -putWitnessData :: MonadPut m => WitnessData -> m () +putWitnessData :: (MonadPut m) => WitnessData -> m () putWitnessData = mapM_ putWitnessStack where putWitnessStack ws = do - putVarInt $ length ws - mapM_ putWitnessStackItem ws + putVarInt $ length ws + mapM_ putWitnessStackItem ws putWitnessStackItem bs = do - putVarInt $ B.length bs - putByteString bs + putVarInt $ B.length bs + putByteString bs instance FromJSON Tx where - parseJSON = withObject "Tx" $ \o -> - Tx <$> o .: "version" - <*> o .: "inputs" - <*> o .: "outputs" - <*> (mapM (mapM f) =<< o .: "witnessdata") - <*> o .: "locktime" - where - f = maybe mzero return . decodeHex + parseJSON = withObject "Tx" $ \o -> + Tx + <$> o .: "version" + <*> o .: "inputs" + <*> o .: "outputs" + <*> (mapM (mapM f) =<< o .: "witnessdata") + <*> o .: "locktime" + where + f = maybe mzero return . decodeHex instance ToJSON Tx where - toJSON (Tx v i o w l) = - object - [ "version" .= v - , "inputs" .= i - , "outputs" .= o - , "witnessdata" .= fmap (fmap encodeHex) w - , "locktime" .= l - ] - toEncoding (Tx v i o w l) = - pairs - ( "version" .= v - <> "inputs" .= i - <> "outputs" .= o - <> "witnessdata" .= fmap (fmap encodeHex) w - <> "locktime" .= l - ) + toJSON (Tx v i o w l) = + object + [ "version" .= v, + "inputs" .= i, + "outputs" .= o, + "witnessdata" .= fmap (fmap encodeHex) w, + "locktime" .= l + ] + toEncoding (Tx v i o w l) = + pairs $ + mconcat + [ "version" `E.pair` E.word32 v, + "inputs" `E.pair` E.list toEncoding i, + "outputs" `E.pair` E.list toEncoding o, + "witnessdata" `E.pair` E.list (E.list f) w, + "locktime" `E.pair` E.word32 l + ] + where + f = hexEncoding . BL.fromStrict -- | Data type representing a transaction input. data TxIn = TxIn - { -- | output being spent - prevOutput :: !OutPoint - , -- | signatures and redeem script - scriptInput :: !ByteString - , -- | lock-time using sequence numbers (BIP-68) - txInSequence :: !Word32 - } - deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) + { -- | output being spent + outpoint :: !OutPoint, + -- | signatures and redeem script + script :: !ByteString, + -- | lock-time using sequence numbers (BIP-68) + sequence :: !Word32 + } + deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) instance Serial TxIn where - deserialize = - TxIn <$> deserialize <*> (readBS =<< deserialize) <*> getWord32le - where - readBS (VarInt len) = getByteString $ fromIntegral len + deserialize = + TxIn <$> deserialize <*> (readBS =<< deserialize) <*> getWord32le + where + readBS (VarInt len) = getByteString $ fromIntegral len - serialize (TxIn o s q) = do - serialize o - putVarInt $ B.length s - putByteString s - putWord32le q + serialize (TxIn o s q) = do + serialize o + putVarInt $ B.length s + putByteString s + putWord32le q instance Binary TxIn where - get = deserialize - put = serialize + get = deserialize + put = serialize instance Serialize TxIn where - get = deserialize - put = serialize + get = deserialize + put = serialize instance FromJSON TxIn where - parseJSON = - withObject "TxIn" $ \o -> - TxIn <$> o .: "prevoutput" - <*> (maybe mzero return . decodeHex =<< o .: "inputscript") - <*> o .: "sequence" + parseJSON = + withObject "TxIn" $ \o -> + TxIn + <$> o .: "prevoutput" + <*> (maybe mzero return . decodeHex =<< o .: "inputscript") + <*> o .: "sequence" instance ToJSON TxIn where - toJSON (TxIn o s q) = - object - [ "prevoutput" .= o - , "inputscript" .= encodeHex s - , "sequence" .= q - ] - toEncoding (TxIn o s q) = - pairs - ( "prevoutput" .= o - <> "inputscript" .= encodeHex s - <> "sequence" .= q - ) + toJSON (TxIn o s q) = + object + [ "prevoutput" .= o, + "inputscript" .= encodeHex s, + "sequence" .= q + ] + toEncoding (TxIn o s q) = + pairs $ + mconcat + [ "prevoutput" `E.pair` toEncoding o, + "inputscript" `E.pair` hexEncoding (BL.fromStrict s), + "sequence" `E.pair` E.word32 q + ] -- | Data type representing a transaction output. data TxOut = TxOut - { -- | value of output is satoshi - outValue :: !Word64 - , -- | pubkey script - scriptOutput :: !ByteString - } - deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) + { -- | value of output is satoshi + value :: !Word64, + -- | pubkey script + script :: !ByteString + } + deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) instance Serial TxOut where - deserialize = do - val <- getWord64le - VarInt len <- deserialize - TxOut val <$> getByteString (fromIntegral len) + deserialize = do + val <- getWord64le + VarInt len <- deserialize + TxOut val <$> getByteString (fromIntegral len) - serialize (TxOut o s) = do - putWord64le o - putVarInt $ B.length s - putByteString s + serialize (TxOut o s) = do + putWord64le o + putVarInt $ B.length s + putByteString s instance Binary TxOut where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize TxOut where - put = serialize - get = deserialize + put = serialize + get = deserialize instance FromJSON TxOut where - parseJSON = - withObject "TxOut" $ \o -> - TxOut <$> o .: "value" - <*> (maybe mzero return . decodeHex =<< o .: "outputscript") + parseJSON = + withObject "TxOut" $ \o -> do + value <- o .: "value" + t <- o .: "outputscript" + script <- maybe mzero return (decodeHex t) + return TxOut {..} instance ToJSON TxOut where - toJSON (TxOut o s) = - object ["value" .= o, "outputscript" .= encodeHex s] - toEncoding (TxOut o s) = - pairs ("value" .= o <> "outputscript" .= encodeHex s) + toJSON (TxOut o s) = + object ["value" .= o, "outputscript" .= encodeHex s] + toEncoding (TxOut o s) = + pairs $ + mconcat + [ "value" `E.pair` E.word64 o, + "outputscript" `E.pair` hexEncoding (BL.fromStrict s) + ] -- | The 'OutPoint' refers to a transaction output being spent. data OutPoint = OutPoint - { -- | hash of previous transaction - outPointHash :: !TxHash - , -- | position of output in previous transaction - outPointIndex :: !Word32 - } - deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + { -- | hash of previous transaction + hash :: !TxHash, + -- | position of output in previous transaction + index :: !Word32 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) instance Serial OutPoint where - deserialize = do - (h, i) <- liftM2 (,) deserialize getWord32le - return $ OutPoint h i - serialize (OutPoint h i) = serialize h >> putWord32le i + deserialize = do + (h, i) <- liftM2 (,) deserialize getWord32le + return $ OutPoint h i + serialize (OutPoint h i) = serialize h >> putWord32le i instance Binary OutPoint where - put = serialize - get = deserialize + put = serialize + get = deserialize instance Serialize OutPoint where - put = serialize - get = deserialize + put = serialize + get = deserialize instance FromJSON OutPoint where - parseJSON = - withObject "OutPoint" $ \o -> - OutPoint <$> o .: "txid" <*> o .: "index" + parseJSON = + withObject "OutPoint" $ \o -> + OutPoint <$> o .: "txid" <*> o .: "index" instance ToJSON OutPoint where - toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i] - toEncoding (OutPoint h i) = pairs ("txid" .= h <> "index" .= i) + toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i] + toEncoding (OutPoint h i) = + pairs $ + mconcat + [ "txid" `E.pair` toEncoding h, + "index" `E.pair` E.word32 i + ] -- | Outpoint used in coinbase transactions. nullOutPoint :: OutPoint nullOutPoint = - OutPoint - { outPointHash = - "0000000000000000000000000000000000000000000000000000000000000000" - , outPointIndex = maxBound - } + OutPoint + { hash = "0000000000000000000000000000000000000000000000000000000000000000", + index = maxBound + } diff --git a/src/Haskoin/Transaction/Genesis.hs b/src/Haskoin/Transaction/Genesis.hs index ce3d9554..1511b6b7 100644 --- a/src/Haskoin/Transaction/Genesis.hs +++ b/src/Haskoin/Transaction/Genesis.hs @@ -1,42 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Transaction.Genesis -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX +-- | +-- Module : Haskoin.Transaction.Genesis +-- Copyright : No rights reserved +-- License : UNLICENSE +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Code related to transactions parsing and serialization. +module Haskoin.Transaction.Genesis (genesisTx) where -Code related to transactions parsing and serialization. --} -module Haskoin.Transaction.Genesis ( - genesisTx, -) where - -import Data.String (fromString) +import Crypto.Secp256k1 (Ctx, importPubKey) +import Data.Bytes.Get (runGetS) +import Haskoin.Crypto.Keys.Common import Haskoin.Script.Standard import Haskoin.Transaction.Common import Haskoin.Util -- | Transaction from Genesis block. -genesisTx :: Tx -genesisTx = - Tx 1 [txin] [txout] [] locktime +genesisTx :: Ctx -> Tx +genesisTx ctx = + Tx 1 [txin] [txout] [] locktime where txin = TxIn outpoint inputBS maxBound - txout = TxOut 5000000000 (encodeOutputBS output) + txout = TxOut 5000000000 (marshal ctx output) locktime = 0 outpoint = OutPoint z maxBound Just inputBS = - decodeHex $ - fromString $ - "04ffff001d0104455468652054696d65732030332f4a616e2f323030392043686" - ++ "16e63656c6c6f72206f6e206272696e6b206f66207365636f6e64206261696c6f" - ++ "757420666f722062616e6b73" - output = - PayPK $ - fromString $ - "04678afdb0fe5548271967f1a67130b7105cd6a828e03909a67962e0ea1f61deb" - ++ "649f6bc3f4cef38c4f35504e51ec112de5c384df7ba0b8d578a4c702b6bf11d5f" + decodeHex + "04ffff001d0104455468652054696d65732030332f4a616e2f323030392043686\ + \16e63656c6c6f72206f6e206272696e6b206f66207365636f6e64206261696c6f\ + \757420666f722062616e6b73" + Just pubKeyBS = + decodeHex + "04678afdb0fe5548271967f1a67130b7105cd6a828e03909a67962e0ea1f61deb\ + \649f6bc3f4cef38c4f35504e51ec112de5c384df7ba0b8d578a4c702b6bf11d5f" + Right pubKey = + unmarshal ctx pubKeyBS + output = PayPK pubKey z = "0000000000000000000000000000000000000000000000000000000000000000" diff --git a/src/Haskoin/Transaction/Partial.hs b/src/Haskoin/Transaction/Partial.hs index 0bf7b0ed..79bde514 100644 --- a/src/Haskoin/Transaction/Partial.hs +++ b/src/Haskoin/Transaction/Partial.hs @@ -1,24 +1,37 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Transaction.Partial -Copyright : No rights reserved -License : MIT -Maintainer : matt@bitnomial.com -Stability : experimental -Portability : POSIX - -Code related to PSBT parsing and serialization. --} -module Haskoin.Transaction.Partial ( - -- * Partially-Signed Transactions - PartiallySignedTransaction (..), +-- | +-- Module : Haskoin.Transaction.Partial +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : matt@bitnomial.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Code related to PSBT parsing and serialization. +module Haskoin.Transaction.Partial + ( -- * Partially-Signed Transactions + PSBT (..), + getPSBT, + putPSBT, Input (..), + getInput, + putInput, Output (..), + getOutput, + putOutput, UnknownMap (..), Key (..), merge, @@ -32,894 +45,906 @@ module Haskoin.Transaction.Partial ( emptyOutput, -- ** Signing - PsbtSigner, + PSBTSigner, getSignerKey, secKeySigner, xPrvSigner, signPSBT, -) where + ) +where import Control.Applicative ((<|>)) -import Control.DeepSeq +import Control.DeepSeq (NFData) import Control.Monad (foldM, guard, replicateM, void) +import Control.Monad.Cont (unless) +import Crypto.Secp256k1 +import Data.Binary (Binary (..)) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Bytes.Get (runGetS) -import Data.Bytes.Put (runPutS) +import Data.ByteString qualified as B +import Data.Bytes.Get +import Data.Bytes.Put import Data.Bytes.Serial (Serial (..)) import Data.Either (fromRight) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict qualified as HashMap import Data.Hashable (Hashable) import Data.List (foldl') import Data.Maybe (fromMaybe, isJust) -import Data.Serialize (Get, Put, Serialize) -import qualified Data.Serialize as S +import Data.Serialize (Get, Put, Serialize (..)) +import Data.Serialize qualified as S +import Data.String.Conversions (cs) import GHC.Generics (Generic) import GHC.Word (Word32, Word8) import Haskoin.Address (Address (..), pubKeyAddr) -import Haskoin.Crypto (SecKey, derivePubKey) -import Haskoin.Data (Network) -import Haskoin.Keys ( - DerivPath, - DerivPathI (Deriv), - Fingerprint, - KeyIndex, - PubKeyI, - SecKeyI (SecKeyI), - XPrvKey, - derivePath, - deriveXPubKey, - listToPath, - pathToList, - pubKeyCompressed, - pubKeyPoint, - xPrvKey, - xPubFP, - ) -import Haskoin.Network ( - VarInt (..), - VarString (..), - putVarInt, - ) -import Haskoin.Script ( - Script (..), - ScriptOp (..), - ScriptOutput (..), - SigHash, - decodeOutput, - decodeOutputBS, - encodeOutputBS, - encodeTxSig, - isPayScriptHash, - opPushData, - sigHashAll, - toP2SH, - toP2WSH, - ) -import Haskoin.Transaction.Builder (SigInput (..), makeSignature) -import Haskoin.Transaction.Common ( - Tx (..), - TxOut, - WitnessStack, - outPointIndex, - outValue, - prevOutput, - scriptInput, - scriptOutput, - ) -import Haskoin.Transaction.Segwit (isSegwit) -import Haskoin.Util (eitherToMaybe) +import Haskoin.Crypto.Keys.Common +import Haskoin.Crypto.Keys.Extended +import Haskoin.Network.Common +import Haskoin.Network.Data +import Haskoin.Script.Common +import Haskoin.Script.SigHash +import Haskoin.Script.Standard +import Haskoin.Transaction.Builder.Sign +import Haskoin.Transaction.Common +import Haskoin.Transaction.Segwit +import Haskoin.Util +import Numeric (showHex) -{- | PSBT data type as specified in - [BIP-174](https://github.com/bitcoin/bips/blob/master/bip-0174.mediawiki). - This contains an unsigned transaction, inputs and outputs, and unspecified - extra data. There is one input per input in the unsigned transaction, and one - output per output in the unsigned transaction. The inputs and outputs in the - 'PartiallySignedTransaction' line up by index with the inputs and outputs in - the unsigned transaction. --} -data PartiallySignedTransaction = PartiallySignedTransaction - { unsignedTransaction :: Tx - , globalUnknown :: UnknownMap - , inputs :: [Input] - , outputs :: [Output] - } - deriving (Show, Eq, Generic) +-- | PSBT data type as specified in +-- [BIP-174](https://github.com/bitcoin/bips/blob/master/bip-0174.mediawiki). +-- This contains an unsigned transaction, inputs and outputs, and unspecified +-- extra data. There is one input per input in the unsigned transaction, and one +-- output per output in the unsigned transaction. The inputs and outputs in the +-- 'PSBT' line up by index with the inputs and outputs in +-- the unsigned transaction. +data PSBT = PSBT + { unsignedTransaction :: Tx, + globalUnknown :: UnknownMap, + inputs :: [Input], + outputs :: [Output] + } + deriving (Show, Read, Eq, Generic) + deriving anyclass (NFData) -instance NFData PartiallySignedTransaction - -{- | Inputs contain all of the data needed to sign a transaction and all of the - resulting signature data after signing. --} +-- | Inputs contain all of the data needed to sign a transaction and all of the +-- resulting signature data after signing. data Input = Input - { nonWitnessUtxo :: Maybe Tx - , witnessUtxo :: Maybe TxOut - , partialSigs :: HashMap PubKeyI ByteString - , sigHashType :: Maybe SigHash - , inputRedeemScript :: Maybe Script - , inputWitnessScript :: Maybe Script - , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex]) - , finalScriptSig :: Maybe Script - , finalScriptWitness :: Maybe WitnessStack - , inputUnknown :: UnknownMap - } - deriving (Show, Eq, Generic) - -instance NFData Input + { nonWitnessUtxo :: Maybe Tx, + witnessUtxo :: Maybe TxOut, + partialSigs :: HashMap PublicKey ByteString, + sigHashType :: Maybe SigHash, + inputRedeemScript :: Maybe Script, + inputWitnessScript :: Maybe Script, + inputHDKeypaths :: HashMap PublicKey (Fingerprint, [KeyIndex]), + finalScriptSig :: Maybe Script, + finalScriptWitness :: Maybe WitnessStack, + inputUnknown :: UnknownMap + } + deriving (Show, Read, Eq, Generic) + deriving anyclass (NFData) -- | Outputs can contain information needed to spend the output at a later date. data Output = Output - { outputRedeemScript :: Maybe Script - , outputWitnessScript :: Maybe Script - , outputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex]) - , outputUnknown :: UnknownMap - } - deriving (Show, Eq, Generic) + { outputRedeemScript :: Maybe Script, + outputWitnessScript :: Maybe Script, + outputHDKeypaths :: HashMap PublicKey (Fingerprint, [KeyIndex]), + outputUnknown :: UnknownMap + } + deriving (Show, Read, Eq, Generic) + deriving anyclass (NFData) -instance NFData Output - -{- | A map of raw PSBT keys to byte strings for extra data. The 'keyType' field - cannot overlap with any of the reserved 'keyType' fields specified in the - PSBT specification. --} +-- | A map of raw PSBT keys to byte strings for extra data. The 'keyType' field +-- cannot overlap with any of the reserved 'keyType' fields specified in the +-- PSBT specification. newtype UnknownMap = UnknownMap {unknownMap :: HashMap Key ByteString} - deriving (Show, Eq, Semigroup, Monoid, Generic) - -instance NFData UnknownMap + deriving (Show, Read, Eq, Generic) + deriving newtype (Semigroup, Monoid, NFData) -- | Raw keys for the map type used in PSBTs. data Key = Key - { keyType :: Word8 - , key :: ByteString - } - deriving (Show, Eq, Generic) + { keyType :: Word8, + key :: ByteString + } + deriving (Show, Read, Eq, Generic, NFData, Hashable) -instance NFData Key - -instance Hashable Key - -{- | Take two 'PartiallySignedTransaction's and merge them. The - 'unsignedTransaction' field in both must be the same. --} +-- | Take two 'PSBT's and merge them. The +-- 'unsignedTransaction' field in both must be the same. merge :: - PartiallySignedTransaction -> - PartiallySignedTransaction -> - Maybe PartiallySignedTransaction + PSBT -> + PSBT -> + Maybe PSBT merge psbt1 psbt2 - | unsignedTransaction psbt1 == unsignedTransaction psbt2 = - Just $ - psbt1 - { globalUnknown = globalUnknown psbt1 <> globalUnknown psbt2 - , inputs = zipWith mergeInput (inputs psbt1) (inputs psbt2) - , outputs = zipWith mergeOutput (outputs psbt1) (outputs psbt2) - } + | psbt1.unsignedTransaction == psbt2.unsignedTransaction = + Just $ + psbt1 + { globalUnknown = psbt1.globalUnknown <> psbt2.globalUnknown, + inputs = zipWith mergeInput psbt1.inputs psbt2.inputs, + outputs = zipWith mergeOutput psbt1.outputs psbt2.outputs + } merge _ _ = Nothing -{- | A version of 'merge' for a collection of PSBTs. - - @since 0.21.0 --} -mergeMany :: [PartiallySignedTransaction] -> Maybe PartiallySignedTransaction +-- | A version of 'merge' for a collection of PSBTs. +-- +-- @since 0.21.0 +mergeMany :: [PSBT] -> Maybe PSBT mergeMany (psbt : psbts) = foldM merge psbt psbts mergeMany _ = Nothing mergeInput :: Input -> Input -> Input mergeInput a b = - Input - { nonWitnessUtxo = - if isJust witUtx - then Nothing - else nonWitnessUtxo a <|> nonWitnessUtxo b - , witnessUtxo = - witUtx - , sigHashType = - sigHashType a <|> sigHashType b - , partialSigs = - partialSigs a <> partialSigs b - , inputHDKeypaths = - inputHDKeypaths a <> inputHDKeypaths b - , inputUnknown = - inputUnknown a <> inputUnknown b - , inputRedeemScript = - inputRedeemScript a <|> inputRedeemScript b - , inputWitnessScript = - inputWitnessScript a <|> inputWitnessScript b - , finalScriptSig = - finalScriptSig a <|> finalScriptSig b - , finalScriptWitness = - finalScriptWitness a <|> finalScriptWitness b - } + Input + { nonWitnessUtxo = + if isJust witUtx + then Nothing + else a.nonWitnessUtxo <|> b.nonWitnessUtxo, + witnessUtxo = + witUtx, + sigHashType = + a.sigHashType <|> b.sigHashType, + partialSigs = + a.partialSigs <> b.partialSigs, + inputHDKeypaths = + a.inputHDKeypaths <> b.inputHDKeypaths, + inputUnknown = + a.inputUnknown <> b.inputUnknown, + inputRedeemScript = + a.inputRedeemScript <|> b.inputRedeemScript, + inputWitnessScript = + a.inputWitnessScript <|> b.inputWitnessScript, + finalScriptSig = + a.finalScriptSig <|> b.finalScriptSig, + finalScriptWitness = + a.finalScriptWitness <|> b.finalScriptWitness + } where - witUtx = witnessUtxo a <|> witnessUtxo b + witUtx = a.witnessUtxo <|> b.witnessUtxo mergeOutput :: Output -> Output -> Output mergeOutput a b = - Output - { outputRedeemScript = - outputRedeemScript a <|> outputRedeemScript b - , outputWitnessScript = - outputWitnessScript a <|> outputWitnessScript b - , outputHDKeypaths = - outputHDKeypaths a <> outputHDKeypaths b - , outputUnknown = - outputUnknown a <> outputUnknown b - } - -{- | A abstraction which covers varying key configurations. Use the 'Semigroup' - instance to create signers for sets of keys: `signerA <> signerB` can sign - anything for which `signerA` or `signerB` could sign. - - @since 0.21@ --} -newtype PsbtSigner = PsbtSigner - { unPsbtSigner :: - PubKeyI -> - Maybe (Fingerprint, DerivPath) -> - Maybe SecKey + Output + { outputRedeemScript = + a.outputRedeemScript <|> b.outputRedeemScript, + outputWitnessScript = + a.outputWitnessScript <|> b.outputWitnessScript, + outputHDKeypaths = + a.outputHDKeypaths <> b.outputHDKeypaths, + outputUnknown = + a.outputUnknown <> b.outputUnknown } -instance Semigroup PsbtSigner where - PsbtSigner signer1 <> PsbtSigner signer2 = - PsbtSigner $ \pubKey origin -> - signer1 pubKey origin <|> signer2 pubKey origin +-- | A abstraction which covers varying key configurations. Use the 'Semigroup' +-- instance to create signers for sets of keys: `signerA <> signerB` can sign +-- anything for which `signerA` or `signerB` could sign. +-- +-- @since 0.21@ +newtype PSBTSigner = PSBTSigner + { unPSBTSigner :: + PublicKey -> + Maybe (Fingerprint, DerivPath) -> + Maybe SecKey + } -instance Monoid PsbtSigner where - mempty = PsbtSigner $ \_ _ -> Nothing +instance Semigroup PSBTSigner where + PSBTSigner signer1 <> PSBTSigner signer2 = + PSBTSigner $ \pubKey origin -> + signer1 pubKey origin <|> signer2 pubKey origin -{- | Fetch the secret key for the given 'PubKeyI' if possible. +instance Monoid PSBTSigner where + mempty = PSBTSigner $ \_ _ -> Nothing - @since 0.21@ --} -getSignerKey :: PsbtSigner -> PubKeyI -> Maybe (Fingerprint, DerivPath) -> Maybe SecKey -getSignerKey = unPsbtSigner +-- | Fetch the secret key for the given 'PublicKey' if possible. +-- +-- @since 0.21@ +getSignerKey :: PSBTSigner -> PublicKey -> Maybe (Fingerprint, DerivPath) -> Maybe SecKey +getSignerKey = (.unPSBTSigner) -{- | This signer can sign for one key. - - @since 0.21@ --} -secKeySigner :: SecKey -> PsbtSigner -secKeySigner theSecKey = PsbtSigner signer +-- | This signer can sign for one key. +-- +-- @since 0.21@ +secKeySigner :: Ctx -> SecKey -> PSBTSigner +secKeySigner ctx theSecKey = + PSBTSigner signer where signer requiredKey _ - | pubKeyPoint requiredKey == derivePubKey theSecKey = Just theSecKey - | otherwise = Nothing + | requiredKey.point == derivePubKey ctx theSecKey = Just theSecKey + | otherwise = Nothing -{- | This signer can sign with any child key, provided that derivation information is present. - - @since 0.21@ --} +-- | This signer can sign with any child key, provided that derivation information is present. +-- +-- @since 0.21@ xPrvSigner :: - XPrvKey -> - -- | Origin data, if the input key is explicitly a child key - Maybe (Fingerprint, DerivPath) -> - PsbtSigner -xPrvSigner xprv origin = PsbtSigner signer + Ctx -> + XPrvKey -> + -- | Origin data, if the input key is explicitly a child key + Maybe (Fingerprint, DerivPath) -> + PSBTSigner +xPrvSigner ctx xprv origin = PSBTSigner signer where signer pubKey (Just hdData) - | result@(Just theSecKey) <- maybe noOrigin onOrigin origin hdData - , pubKeyPoint pubKey == derivePubKey theSecKey = - result + | result@(Just theSecKey) <- maybe noOrigin onOrigin origin hdData, + pubKey.point == derivePubKey ctx theSecKey = + result signer _ _ = Nothing noOrigin (fp, path) - | thisFP == fp = Just $ deriveSecKey path - | otherwise = Nothing + | thisFP == fp = Just $ deriveSecKey path + | otherwise = Nothing onOrigin (originFP, originPath) (fp, path) - | thisFP == fp = Just $ deriveSecKey path - | originFP == fp = - deriveSecKey <$> adjustPath (pathToList originPath) (pathToList path) - | otherwise = Nothing + | thisFP == fp = Just $ deriveSecKey path + | originFP == fp = + deriveSecKey <$> adjustPath (pathToList originPath) (pathToList path) + | otherwise = Nothing - deriveSecKey path = xPrvKey $ derivePath path xprv + deriveSecKey path = (derivePath ctx path xprv).key - thisFP = xPubFP $ deriveXPubKey xprv + thisFP = xPubFP ctx $ deriveXPubKey ctx xprv -- The origin path should be a prefix of the target path if we match the -- origin fingerprint. We need to remove this prefix. adjustPath :: [KeyIndex] -> [KeyIndex] -> Maybe DerivPath adjustPath (originIx : originTail) (thisIx : thisTail) - | originIx == thisIx = adjustPath originTail thisTail - | otherwise = Nothing + | originIx == thisIx = adjustPath originTail thisTail + | otherwise = Nothing adjustPath [] thePath = Just $ listToPath thePath adjustPath _ _ = Nothing -{- | Update a PSBT with signatures when possible. This function uses - 'inputHDKeypaths' in order to calculate secret keys. - - @since 0.21@ --} +-- | Update a PSBT with signatures when possible. This function uses +-- 'inputHDKeypaths' in order to calculate secret keys. +-- +-- @since 0.21@ signPSBT :: - Network -> - PsbtSigner -> - PartiallySignedTransaction -> - PartiallySignedTransaction -signPSBT net signer psbt = - psbt - { inputs = addSigsForInput net signer tx <$> zip [0 :: Int ..] (inputs psbt) - } + Network -> + Ctx -> + PSBTSigner -> + PSBT -> + PSBT +signPSBT net ctx signer PSBT {..} = + PSBT {inputs = f <$> zip [0 ..] inputs, ..} where - tx = unsignedTransaction psbt + f = addSigsForInput net ctx signer unsignedTransaction -addSigsForInput :: Network -> PsbtSigner -> Tx -> (Int, Input) -> Input -addSigsForInput net signer tx (ix, input) = - maybe input (onPrevTxOut net signer tx ix input) $ - Left <$> nonWitnessUtxo input <|> Right <$> witnessUtxo input +addSigsForInput :: Network -> Ctx -> PSBTSigner -> Tx -> (Int, Input) -> Input +addSigsForInput net ctx signer tx (ix, input) = + maybe input (onPrevTxOut net ctx signer tx ix input) $ + Left <$> input.nonWitnessUtxo <|> Right <$> input.witnessUtxo onPrevTxOut :: - Network -> - PsbtSigner -> - Tx -> - Int -> - Input -> - Either Tx TxOut -> - Input -onPrevTxOut net signer tx ix input prevTxData = - input - { partialSigs = newSigs <> partialSigs input - } + Network -> + Ctx -> + PSBTSigner -> + Tx -> + Int -> + Input -> + Either Tx TxOut -> + Input +onPrevTxOut net ctx signer tx ix input prevTxData = + input + { partialSigs = newSigs <> input.partialSigs + } where - newSigs = HM.mapWithKey sigForInput sigKeys + newSigs = HashMap.mapWithKey sigForInput sigKeys sigForInput thePubKey theSecKey = - encodeTxSig . makeSignature net tx ix theSigInput $ - SecKeyI theSecKey (pubKeyCompressed thePubKey) + encodeTxSig net ctx . makeSignature net ctx tx ix theSigInput $ + PrivateKey theSecKey thePubKey.compress theSigInput = - SigInput - { -- Must be the segwit input script for segwit spends (even nested) - sigInputScript = fromMaybe theInputScript segwitInput - , sigInputValue = outValue prevTxOut - , sigInputOP = thePrevOutPoint - , sigInputSH = fromMaybe sigHashAll $ sigHashType input - , -- Must be the witness script for segwit spends (even nested) - sigInputRedeem = theWitnessScript <|> theRedeemScript - } + SigInput + { -- Must be the segwit input script for segwit spends (even nested) + script = fromMaybe theInputScript segwitInput, + value = prevTxOut.value, + outpoint = thePrevOutPoint, + sighash = fromMaybe sigHashAll input.sigHashType, + -- Must be the witness script for segwit spends (even nested) + redeem = theWitnessScript <|> theRedeemScript + } - prevTxOut = either ((!! (fromIntegral . outPointIndex) thePrevOutPoint) . txOut) id prevTxData - thePrevOutPoint = prevOutput $ txIn tx !! ix + prevTxOut = + let rf = ((!! (fromIntegral . (.index)) thePrevOutPoint) . (.outputs)) + in either rf id prevTxData + thePrevOutPoint = (tx.inputs !! ix).outpoint segwitInput = justWhen isSegwit theInputScript <|> (justWhen isSegwit =<< theRedeemScript) - theInputScript = fromRight inputScriptErr $ (decodeOutputBS . scriptOutput) prevTxOut + theInputScript = fromRight inputScriptErr $ (unmarshal ctx . (.script)) prevTxOut inputScriptErr = error "addSigsForInput: Unable to decode input script" - theRedeemScript = case decodeOutput <$> inputRedeemScript input of - Just (Right script) -> Just script - Just Left{} -> error "addSigsForInput: Unable to decode redeem script" - _ -> Nothing + theRedeemScript = case decodeOutput ctx <$> input.inputRedeemScript of + Just (Right script) -> Just script + Just Left {} -> error "addSigsForInput: Unable to decode redeem script" + _ -> Nothing - theWitnessScript = case decodeOutput <$> inputWitnessScript input of - Just (Right script) -> Just script - Just Left{} -> error "addSigsForInput: Unable to decode witness script" - _ -> Nothing + theWitnessScript = case decodeOutput ctx <$> input.inputWitnessScript of + Just (Right script) -> Just script + Just Left {} -> error "addSigsForInput: Unable to decode witness script" + _ -> Nothing - sigKeys = HM.mapMaybeWithKey getSignerKey $ inputHDKeypaths input - getSignerKey pubKey (fp, ixs) = unPsbtSigner signer pubKey $ Just (fp, listToPath ixs) + sigKeys = HashMap.mapMaybeWithKey getSignerKey input.inputHDKeypaths + getSignerKey pubKey (fp, ixs) = (.unPSBTSigner) signer pubKey $ Just (fp, listToPath ixs) -- | Take partial signatures from all of the 'Input's and finalize the signature. complete :: - PartiallySignedTransaction -> - PartiallySignedTransaction -complete psbt = - psbt - { inputs = - map - (completeInput . analyzeInputs) - (indexed $ inputs psbt) - } + Ctx -> + PSBT -> + PSBT +complete ctx PSBT {..} = + PSBT {inputs = map (completeInput . analyzeInputs) (indexed inputs), ..} where analyzeInputs (i, input) = - (,) - (outputScript =<< witnessUtxo input <|> nonWitScript) - input + (,) + (outputScript =<< input.witnessUtxo <|> nonWitScript) + input where - nonWitScript = getPrevOut i =<< nonWitnessUtxo input + nonWitScript = getPrevOut i =<< input.nonWitnessUtxo getPrevOut i tx = - (txOut tx !!?) - . fromIntegral - . outPointIndex - . prevOutput - =<< txIn (unsignedTransaction psbt) !!? i + (tx.outputs !!?) . fromIntegral . (.outpoint.index) + =<< unsignedTransaction.inputs !!? i xs !!? i = lookup i $ indexed xs - outputScript = eitherToMaybe . decodeOutputBS . scriptOutput + outputScript = eitherToMaybe . unmarshal ctx . (.script) completeInput (Nothing, input) = input - completeInput (Just script, input) = pruneInputFields $ completeSig input script + completeInput (Just script, input) = pruneInputFields $ completeSig ctx input script -- If we have final scripts, we can get rid of data for signing following -- the Bitcoin Core implementation. pruneInputFields input - | isJust (finalScriptSig input) || isJust (finalScriptWitness input) = - input - { partialSigs = mempty - , inputHDKeypaths = mempty - , inputRedeemScript = Nothing - , inputWitnessScript = Nothing - , sigHashType = Nothing - } - | otherwise = input + | isJust input.finalScriptSig || isJust input.finalScriptWitness = + input + { partialSigs = mempty, + inputHDKeypaths = mempty, + inputRedeemScript = Nothing, + inputWitnessScript = Nothing, + sigHashType = Nothing + } + | otherwise = input indexed :: [a] -> [(Word32, a)] indexed = zip [0 ..] -completeSig :: Input -> ScriptOutput -> Input -completeSig input (PayPK k) = - input +completeSig :: Ctx -> Input -> ScriptOutput -> Input +completeSig ctx input (PayPK k) = + input + { finalScriptSig = + eitherToMaybe . runGetS deserialize + =<< HashMap.lookup k input.partialSigs + } +completeSig ctx input (PayPKHash h) + | [(k, sig)] <- HashMap.toList input.partialSigs, + PubKeyAddress h == pubKeyAddr ctx k = + input { finalScriptSig = - eitherToMaybe . runGetS deserialize - =<< HashMap.lookup k (partialSigs input) + Just $ + Script + [ opPushData sig, + opPushData (marshal ctx k) + ] } -completeSig input (PayPKHash h) - | [(k, sig)] <- HashMap.toList (partialSigs input) - , PubKeyAddress h == pubKeyAddr k = - input - { finalScriptSig = - Just $ - Script - [ opPushData sig - , opPushData (runPutS (serialize k)) - ] - } -completeSig input (PayMulSig pubKeys m) - | length sigs >= m = - input{finalScriptSig = Just finalSig} +completeSig ctx input (PayMulSig pubKeys m) + | length sigs >= m = + input {finalScriptSig = Just finalSig} where sigs = collectSigs m pubKeys input finalSig = Script $ OP_0 : map opPushData sigs -completeSig input (PayScriptHash h) - | Just rdmScript <- inputRedeemScript input - , PayScriptHash h == toP2SH rdmScript - , Right decodedScript <- decodeOutput rdmScript - , not (isPayScriptHash decodedScript) = - pushScript rdmScript $ completeSig input decodedScript +completeSig ctx input (PayScriptHash h) + | Just rdmScript <- input.inputRedeemScript, + PayScriptHash h == toP2SH rdmScript, + Right decodedScript <- decodeOutput ctx rdmScript, + not (isPayScriptHash decodedScript) = + pushScript rdmScript $ completeSig ctx input decodedScript where pushScript rdmScript updatedInput = - updatedInput - { finalScriptSig = - Just $ - fromMaybe (Script mempty) (finalScriptSig updatedInput) - `scriptAppend` serializedRedeemScript rdmScript - } + updatedInput + { finalScriptSig = + Just $ + fromMaybe (Script mempty) updatedInput.finalScriptSig + `scriptAppend` serializedRedeemScript rdmScript + } scriptAppend (Script script1) (Script script2) = Script $ script1 <> script2 -completeSig input (PayWitnessPKHash h) - | [(k, sig)] <- HashMap.toList (partialSigs input) - , PubKeyAddress h == pubKeyAddr k = - input{finalScriptWitness = Just [sig, runPutS $ serialize k]} -completeSig input (PayWitnessScriptHash h) - | Just witScript <- inputWitnessScript input - , PayWitnessScriptHash h == toP2WSH witScript - , Right decodedScript <- decodeOutput witScript = - completeWitnessSig input decodedScript -completeSig input _ = input +completeSig ctx input (PayWitnessPKHash h) + | [(k, sig)] <- HashMap.toList input.partialSigs, + PubKeyAddress h == pubKeyAddr ctx k = + input {finalScriptWitness = Just [sig, marshal ctx k]} +completeSig ctx input (PayWitnessScriptHash h) + | Just witScript <- input.inputWitnessScript, + PayWitnessScriptHash h == toP2WSH witScript, + Right decodedScript <- decodeOutput ctx witScript = + completeWitnessSig ctx input decodedScript +completeSig _ input _ = input serializedRedeemScript :: Script -> Script serializedRedeemScript = Script . pure . opPushData . runPutS . serialize -completeWitnessSig :: Input -> ScriptOutput -> Input -completeWitnessSig input script@(PayMulSig pubKeys m) - | length sigs >= m = - input{finalScriptWitness = Just finalWit} +completeWitnessSig :: Ctx -> Input -> ScriptOutput -> Input +completeWitnessSig ctx input script@(PayMulSig pubKeys m) + | length sigs >= m = + input {finalScriptWitness = Just finalWit} where sigs = collectSigs m pubKeys input - finalWit = mempty : sigs <> [encodeOutputBS script] -completeWitnessSig input _ = input + finalWit = mempty : sigs <> [marshal ctx script] +completeWitnessSig _ input _ = input -collectSigs :: Int -> [PubKeyI] -> Input -> [ByteString] +collectSigs :: Int -> [PublicKey] -> Input -> [ByteString] collectSigs m pubKeys input = - take m . reverse $ foldl' lookupKey [] pubKeys + take m . reverse $ foldl' lookupKey [] pubKeys where lookupKey sigs key = - maybe sigs (: sigs) $ - HashMap.lookup key (partialSigs input) + maybe sigs (: sigs) $ + HashMap.lookup key input.partialSigs -{- | Take a finalized 'PartiallySignedTransaction' and produce the signed final - transaction. You may need to call 'complete' on the - 'PartiallySignedTransaction' before producing the final transaction. --} -finalTransaction :: PartiallySignedTransaction -> Tx +-- | Take a finalized 'PSBT' and produce the signed final +-- transaction. You may need to call 'complete' on the +-- 'PSBT' before producing the final transaction. +finalTransaction :: PSBT -> Tx finalTransaction psbt = - setInputs - . foldl' finalizeInput ([], []) - $ zip (txIn tx) (inputs psbt) + setInputs + . foldl' finalizeInput ([], []) + $ zip tx.inputs psbt.inputs where - tx = unsignedTransaction psbt - hasWitness = - any - (isJust . finalScriptWitness) - (inputs psbt) + tx = psbt.unsignedTransaction + hasWitness = any (isJust . (.finalScriptWitness)) psbt.inputs setInputs (ins, witData) = - tx - { txIn = reverse ins - , txWitness = if hasWitness then reverse witData else [] - } - finalizeInput (ins, witData) (txInput, psbtInput) = - ( txInput{scriptInput = maybe mempty (runPutS . serialize) $ finalScriptSig psbtInput} : ins - , fromMaybe [] (finalScriptWitness psbtInput) : witData - ) - -{- | Take an unsigned transaction and produce an empty - 'PartiallySignedTransaction' --} -emptyPSBT :: Tx -> PartiallySignedTransaction -emptyPSBT tx = - PartiallySignedTransaction - { unsignedTransaction = tx - , globalUnknown = mempty - , inputs = replicate (length (txIn tx)) emptyInput - , outputs = replicate (length (txOut tx)) emptyOutput + tx + { inputs = reverse ins, + witness = if hasWitness then reverse witData else [] } + finalizeInput (ins, witData) (TxIn {..}, psbtInput) = + ( TxIn + { script = + maybe + mempty + (runPutS . serialize) + psbtInput.finalScriptSig, + .. + } + : ins, + fromMaybe [] psbtInput.finalScriptWitness : witData + ) + +-- | Take an unsigned transaction and produce an empty +-- 'PSBT' +emptyPSBT :: Tx -> PSBT +emptyPSBT tx = + PSBT + { unsignedTransaction = tx, + globalUnknown = mempty, + inputs = replicate (length tx.inputs) emptyInput, + outputs = replicate (length tx.outputs) emptyOutput + } emptyInput :: Input emptyInput = - Input - Nothing - Nothing - HashMap.empty - Nothing - Nothing - Nothing - HashMap.empty - Nothing - Nothing - (UnknownMap HashMap.empty) + Input + Nothing + Nothing + HashMap.empty + Nothing + Nothing + Nothing + HashMap.empty + Nothing + Nothing + (UnknownMap HashMap.empty) emptyOutput :: Output emptyOutput = Output Nothing Nothing HashMap.empty (UnknownMap HashMap.empty) -instance Serialize PartiallySignedTransaction where - get = do - magic <- S.getBytes 4 - guard $ magic == "psbt" - headerSep <- S.getWord8 - guard $ headerSep == 0xff +getPSBT :: (MonadGet m) => Ctx -> m PSBT +getPSBT ctx = do + magic <- getBytes 4 + unless (magic == "psbt") $ + fail $ + "Expected magic = 'psbt' but got '" ++ cs magic ++ "'" + headerSep <- getWord8 + unless (headerSep == 0xff) $ + fail $ + "Expected headerSep = 0xff but got 0x" ++ showHex headerSep "" - keySize <- S.getWord8 - guard $ keySize == 1 - globalUnsignedTxType <- S.getWord8 - guard $ globalUnsignedTxType == 0x00 - unsignedTransaction <- getSizedBytes deserialize - guard $ all (B.null . scriptInput) (txIn unsignedTransaction) - guard $ null (txWitness unsignedTransaction) + keySize <- getWord8 + unless (keySize == 1) $ + fail $ + "Expected keySize = 1 but got " ++ show keySize + globalUnsignedTxType <- getWord8 + unless (globalUnsignedTxType == 0x00) $ + fail $ + "Expected globalUnsignedTxType = 0x00 but got 0x" + ++ showHex globalUnsignedTxType "" + unsignedTransaction <- getSizedBytes deserialize + unless (all (B.null . (.script)) unsignedTransaction.inputs) $ + fail $ + "Not all inputs from unsignedTransaction have empty scripts" + unless (null unsignedTransaction.witness) $ + fail $ + "Not all witnesses from unsignedTransaction are empty" - globalUnknown <- S.get - globalEnd <- S.getWord8 - guard $ globalEnd == 0x00 + globalUnknown <- deserialize + globalEnd <- getWord8 + unless (globalEnd == 0x00) $ + fail $ + "Expected globalEnd == 0x00 but got 0x" ++ showHex globalEnd "" - inputs <- - replicateM - (length (txIn unsignedTransaction)) - S.get - outputs <- - replicateM - (length (txOut unsignedTransaction)) - S.get + inputs <- + replicateM + (length unsignedTransaction.inputs) + (getInput ctx) + outputs <- + replicateM + (length unsignedTransaction.outputs) + (getOutput ctx) - return - PartiallySignedTransaction - { unsignedTransaction - , globalUnknown - , inputs - , outputs - } + return + PSBT + { unsignedTransaction, + globalUnknown, + inputs, + outputs + } - put - PartiallySignedTransaction - { unsignedTransaction - , globalUnknown - , inputs - , outputs - } = do - S.putByteString "psbt" - S.putWord8 0xff -- Header separator - S.putWord8 0x01 -- Key size - S.putWord8 0x00 -- Unsigned Transaction type - putSizedBytes $ serialize unsignedTransaction - S.put globalUnknown - S.putWord8 0x00 -- Global end - mapM_ S.put inputs - mapM_ S.put outputs +putPSBT :: (MonadPut m) => Ctx -> PSBT -> m () +putPSBT + ctx + PSBT + { unsignedTransaction, + globalUnknown, + inputs, + outputs + } = do + putByteString "psbt" + putWord8 0xff -- Header separator + putWord8 0x01 -- Key size + putWord8 0x00 -- Unsigned Transaction type + putSizedBytes $ S.encode unsignedTransaction + serialize globalUnknown + putWord8 0x00 -- Global end + mapM_ (putInput ctx) inputs + mapM_ (putOutput ctx) outputs + +instance Serial Key where + deserialize = do + VarInt keySize <- deserialize + unless (keySize > 0) $ + fail $ + "Expected keySize > 0 but got " ++ show keySize + t <- getWord8 + k <- getBytes (fromIntegral keySize - 1) + return (Key t k) + + serialize (Key t k) = do + putVarInt $ 1 + B.length k + putWord8 t + putByteString k + +instance Binary Key where + put = serialize + get = deserialize instance Serialize Key where - get = do - VarInt keySize <- deserialize - guard $ keySize > 0 - t <- S.getWord8 - k <- S.getBytes (fromIntegral keySize - 1) - return (Key t k) + put = serialize + get = deserialize - put (Key t k) = do - putVarInt $ 1 + B.length k - S.putWord8 t - S.putByteString k +instance Serial UnknownMap where + deserialize = go HashMap.empty + where + getItem m = do + k <- deserialize + VarString v <- deserialize + go $ HashMap.insert k v m + go m = do + isEnd <- lookAhead getWord8 + if isEnd == 0x00 + then return (UnknownMap m) + else getItem m -instance Serialize UnknownMap where - get = go HashMap.empty - where - getItem m = do - k <- S.get - VarString v <- deserialize - go $ HashMap.insert k v m - go m = do - isEnd <- S.lookAhead S.getWord8 - if isEnd == 0x00 - then return (UnknownMap m) - else getItem m + serialize (UnknownMap m) = + void $ + HashMap.traverseWithKey + (\k v -> serialize k >> serialize (VarString v)) + m - put (UnknownMap m) = - void $ - HashMap.traverseWithKey - (\k v -> S.put k >> serialize (VarString v)) - m - -instance Serialize Input where - get = - getMap getInputItem setInputUnknown emptyInput - where - setInputUnknown f input = - input - { inputUnknown = - UnknownMap (f (unknownMap (inputUnknown input))) - } - - put - Input - { nonWitnessUtxo - , witnessUtxo - , partialSigs - , sigHashType - , inputRedeemScript - , inputWitnessScript - , inputHDKeypaths - , finalScriptSig - , finalScriptWitness - , inputUnknown - } = do - whenJust - (putKeyValue InNonWitnessUtxo . serialize) - nonWitnessUtxo - whenJust - (putKeyValue InWitnessUtxo . serialize) - witnessUtxo - putPartialSig partialSigs - whenJust - putSigHash - sigHashType - whenJust - (putKeyValue InRedeemScript . serialize) - inputRedeemScript - whenJust - (putKeyValue InWitnessScript . serialize) - inputWitnessScript - putHDPath InBIP32Derivation inputHDKeypaths - whenJust - (putKeyValue InFinalScriptSig . serialize) - finalScriptSig - whenJust - (putKeyValue InFinalScriptWitness . putFinalScriptWitness) - finalScriptWitness - S.put inputUnknown - S.putWord8 0x00 - where - putPartialSig = - putPubKeyMap serialize InPartialSig . fmap VarString - putSigHash sigHash = do - putKey InSigHashType - S.putWord8 0x04 - S.putWord32le (fromIntegral sigHash) - putFinalScriptWitness witnessStack = do - S.put $ (VarInt . fromIntegral . length) witnessStack - mapM_ (serialize . VarString) witnessStack - -instance Serialize Output where - get = getMap getOutputItem setOutputUnknown emptyOutput - where - setOutputUnknown f output = - output - { outputUnknown = - UnknownMap (f (unknownMap (outputUnknown output))) - } - - put - Output - { outputRedeemScript - , outputWitnessScript - , outputHDKeypaths - , outputUnknown - } = do - whenJust - (putKeyValue OutRedeemScript . serialize) - outputRedeemScript - whenJust - (putKeyValue OutWitnessScript . serialize) - outputWitnessScript - putHDPath - OutBIP32Derivation - outputHDKeypaths - S.put outputUnknown - S.putWord8 0x00 - -putSizedBytes :: Put -> Put -putSizedBytes f = do - putVarInt (B.length bs) - S.putByteString bs +getInput :: (MonadGet m) => Ctx -> m Input +getInput ctx = + getMap (getInputItem ctx) setInputUnknown emptyInput where - bs = S.runPut f + setInputUnknown f input = + input + { inputUnknown = + UnknownMap (f input.inputUnknown.unknownMap) + } -getSizedBytes :: Get a -> Get a +putInput :: (MonadPut m) => Ctx -> Input -> m () +putInput + ctx + Input + { nonWitnessUtxo, + witnessUtxo, + partialSigs, + sigHashType, + inputRedeemScript, + inputWitnessScript, + inputHDKeypaths, + finalScriptSig, + finalScriptWitness, + inputUnknown + } = do + whenJust + (putKeyValue InNonWitnessUtxo . S.encode) + nonWitnessUtxo + whenJust + (putKeyValue InWitnessUtxo . S.encode) + witnessUtxo + putPartialSig partialSigs + whenJust + putSigHash + sigHashType + whenJust + (putKeyValue InRedeemScript . S.encode) + inputRedeemScript + whenJust + (putKeyValue InWitnessScript . S.encode) + inputWitnessScript + putHDPath ctx InBIP32Derivation inputHDKeypaths + whenJust + (putKeyValue InFinalScriptSig . S.encode) + finalScriptSig + whenJust + (putKeyValue InFinalScriptWitness . putFinalScriptWitness) + finalScriptWitness + serialize inputUnknown + putWord8 0x00 + where + putPartialSig = + putPubKeyMap ctx serialize InPartialSig . fmap VarString + putSigHash sigHash = do + putKey InSigHashType + putWord8 0x04 + putWord32le (fromIntegral sigHash) + putFinalScriptWitness witnessStack = runPutS $ do + serialize $ (VarInt . fromIntegral . length) witnessStack + mapM_ (serialize . VarString) witnessStack + +getOutput :: (MonadGet m) => Ctx -> m Output +getOutput ctx = getMap (getOutputItem ctx) setOutputUnknown emptyOutput + where + setOutputUnknown f output = + output + { outputUnknown = + UnknownMap (f output.outputUnknown.unknownMap) + } + +putOutput :: (MonadPut m) => Ctx -> Output -> m () +putOutput + ctx + Output + { outputRedeemScript, + outputWitnessScript, + outputHDKeypaths, + outputUnknown + } = do + whenJust + (putKeyValue OutRedeemScript . S.encode) + outputRedeemScript + whenJust + (putKeyValue OutWitnessScript . S.encode) + outputWitnessScript + putHDPath + ctx + OutBIP32Derivation + outputHDKeypaths + serialize outputUnknown + putWord8 0x00 + +putSizedBytes :: (MonadPut m) => ByteString -> m () +putSizedBytes bs = do + putVarInt (B.length bs) + putByteString bs + +getSizedBytes :: (MonadGet m) => Get a -> m a getSizedBytes = - S.getNested - (fromIntegral . getVarInt <$> deserialize) + getNested $ (\(VarInt i) -> fromIntegral i) <$> deserialize -putKeyValue :: Enum t => t -> Put -> Put +putKeyValue :: (Enum t, MonadPut m) => t -> ByteString -> m () putKeyValue t v = do - putKey t - putSizedBytes v + putKey t + putSizedBytes v -putKey :: Enum t => t -> Put +putKey :: (Enum t, MonadPut m) => t -> m () putKey t = do - putVarInt (1 :: Word8) - S.putWord8 (enumWord8 t) + putVarInt (1 :: Word8) + putWord8 (enumWord8 t) getMap :: - (Bounded t, Enum t) => - (Int -> a -> t -> Get a) -> - ((HashMap Key ByteString -> HashMap Key ByteString) -> a -> a) -> - a -> - Get a + (Bounded t, Enum t, MonadGet m) => + (Int -> a -> t -> m a) -> + ((HashMap Key ByteString -> HashMap Key ByteString) -> a -> a) -> + a -> + m a getMap getMapItem setUnknown = go where getItem keySize m (Right t) = - getMapItem (fromIntegral keySize - 1) m t >>= go + getMapItem (fromIntegral keySize - 1) m t >>= go getItem keySize m (Left t) = do - k <- S.getBytes (fromIntegral keySize - 1) - VarString v <- deserialize - go $ setUnknown (HashMap.insert (Key t k) v) m + k <- getBytes (fromIntegral keySize - 1) + VarString v <- deserialize + go $ setUnknown (HashMap.insert (Key t k) v) m go m = do - keySize <- getVarInt <$> deserialize - if keySize == 0 - then return m - else getItem keySize m . word8Enum =<< S.getWord8 + keySize <- (\(VarInt i) -> i) <$> deserialize + if keySize == 0 + then return m + else getItem keySize m . word8Enum =<< getWord8 data InputType - = InNonWitnessUtxo - | InWitnessUtxo - | InPartialSig - | InSigHashType - | InRedeemScript - | InWitnessScript - | InBIP32Derivation - | InFinalScriptSig - | InFinalScriptWitness - deriving (Show, Eq, Enum, Bounded, Generic) - -instance NFData InputType + = InNonWitnessUtxo + | InWitnessUtxo + | InPartialSig + | InSigHashType + | InRedeemScript + | InWitnessScript + | InBIP32Derivation + | InFinalScriptSig + | InFinalScriptWitness + deriving (Show, Eq, Enum, Bounded, Generic) + deriving anyclass (NFData) data OutputType - = OutRedeemScript - | OutWitnessScript - | OutBIP32Derivation - deriving (Show, Eq, Enum, Bounded, Generic) + = OutRedeemScript + | OutWitnessScript + | OutBIP32Derivation + deriving (Show, Eq, Enum, Bounded, Generic) + deriving anyclass (NFData) -instance NFData OutputType - -getInputItem :: Int -> Input -> InputType -> Get Input -getInputItem 0 input@Input{nonWitnessUtxo = Nothing} InNonWitnessUtxo = do - utxo <- getSizedBytes deserialize - return input{nonWitnessUtxo = Just utxo} -getInputItem 0 input@Input{witnessUtxo = Nothing} InWitnessUtxo = do - utxo <- getSizedBytes deserialize - return input{witnessUtxo = Just utxo} -getInputItem keySize input InPartialSig = do - (k, v) <- getPartialSig - return - input - { partialSigs = HashMap.insert k v (partialSigs input) - } +getInputItem :: + (MonadGet m) => + Ctx -> + Int -> + Input -> + InputType -> + m Input +getInputItem ctx 0 input@Input {nonWitnessUtxo = Nothing} InNonWitnessUtxo = do + utxo <- getSizedBytes deserialize + return input {nonWitnessUtxo = Just utxo} +getInputItem ctx 0 input@Input {witnessUtxo = Nothing} InWitnessUtxo = do + utxo <- getSizedBytes deserialize + return input {witnessUtxo = Just utxo} +getInputItem ctx keySize input InPartialSig = do + (k, v) <- getPartialSig + return + input + { partialSigs = HashMap.insert k v input.partialSigs + } where getPartialSig = - (,) - <$> S.isolate keySize deserialize - <*> (getVarString <$> deserialize) -getInputItem 0 input@Input{sigHashType = Nothing} InSigHashType = do - VarInt size <- deserialize - guard $ size == 0x04 - sigHash <- fromIntegral <$> S.getWord32le - return $ input{sigHashType = Just sigHash} -getInputItem 0 input@Input{inputRedeemScript = Nothing} InRedeemScript = do - script <- getSizedBytes deserialize - return $ input{inputRedeemScript = Just script} -getInputItem 0 input@Input{inputWitnessScript = Nothing} InWitnessScript = do - script <- getSizedBytes deserialize - return $ input{inputWitnessScript = Just script} -getInputItem keySize input InBIP32Derivation = do - (k, v) <- getHDPath keySize - return - input - { inputHDKeypaths = HashMap.insert k v (inputHDKeypaths input) - } -getInputItem 0 input@Input{finalScriptSig = Nothing} InFinalScriptSig = do - script <- getSizedBytes deserialize - return $ input{finalScriptSig = Just script} -getInputItem 0 input@Input{finalScriptWitness = Nothing} InFinalScriptWitness = do - scripts <- map getVarString <$> getVarIntList - return $ input{finalScriptWitness = Just scripts} + (,) + <$> isolate keySize (marshalGet ctx :: Get PublicKey) + <*> ((\(VarString s) -> s) <$> deserialize) +getInputItem ctx 0 input@Input {sigHashType = Nothing} InSigHashType = do + VarInt size <- deserialize + unless (size == 0x04) $ + fail $ + "Expected size == 0x04 but got 0x" ++ showHex size "" + sigHash <- fromIntegral <$> getWord32le + return $ input {sigHashType = Just sigHash} +getInputItem ctx 0 input@Input {inputRedeemScript = Nothing} InRedeemScript = do + script <- getSizedBytes deserialize + return $ input {inputRedeemScript = Just script} +getInputItem ctx 0 input@Input {inputWitnessScript = Nothing} InWitnessScript = do + script <- getSizedBytes deserialize + return $ input {inputWitnessScript = Just script} +getInputItem ctx keySize input InBIP32Derivation = do + (k, v) <- getHDPath ctx keySize + return + input + { inputHDKeypaths = HashMap.insert k v input.inputHDKeypaths + } +getInputItem ctx 0 input@Input {finalScriptSig = Nothing} InFinalScriptSig = do + script <- getSizedBytes deserialize + return $ input {finalScriptSig = Just script} +getInputItem ctx 0 input@Input {finalScriptWitness = Nothing} InFinalScriptWitness = do + scripts <- map (\(VarString s) -> s) <$> getVarIntList + return $ input {finalScriptWitness = Just scripts} where getVarIntList = getSizedBytes $ do - VarInt n <- deserialize -- Item count - replicateM (fromIntegral n) deserialize -getInputItem keySize input inputType = - fail $ - "Incorrect key size for input item or item already existed: " - <> show (keySize, input, inputType) + VarInt n <- deserialize -- Item count + replicateM (fromIntegral n) deserialize +getInputItem ctx keySize input inputType = + fail "Incorrect key size for input item or item already existed" -getOutputItem :: Int -> Output -> OutputType -> Get Output -getOutputItem 0 output@Output{outputRedeemScript = Nothing} OutRedeemScript = do - script <- getSizedBytes deserialize - return $ output{outputRedeemScript = Just script} -getOutputItem 0 output@Output{outputWitnessScript = Nothing} OutWitnessScript = do - script <- getSizedBytes deserialize - return $ output{outputWitnessScript = Just script} -getOutputItem keySize output OutBIP32Derivation = do - (k, v) <- getHDPath keySize - return $ output{outputHDKeypaths = HashMap.insert k v (outputHDKeypaths output)} -getOutputItem keySize output outputType = - fail $ - "Incorrect key size for output item or item already existed: " - <> show (keySize, output, outputType) +getOutputItem :: (MonadGet m) => Ctx -> Int -> Output -> OutputType -> m Output +getOutputItem ctx 0 output@Output {outputRedeemScript = Nothing} OutRedeemScript = do + script <- getSizedBytes deserialize + return $ output {outputRedeemScript = Just script} +getOutputItem ctx 0 output@Output {outputWitnessScript = Nothing} OutWitnessScript = do + script <- getSizedBytes deserialize + return $ output {outputWitnessScript = Just script} +getOutputItem ctx keySize output OutBIP32Derivation = do + (k, v) <- getHDPath ctx keySize + return $ output {outputHDKeypaths = HashMap.insert k v output.outputHDKeypaths} +getOutputItem ctx keySize output outputType = + fail "Incorrect key size for output item or item already existed" -getHDPath :: Int -> Get (PubKeyI, (Fingerprint, [KeyIndex])) -getHDPath keySize = - (,) - <$> S.isolate keySize deserialize - <*> (unPSBTHDPath <$> S.get) +getHDPath :: + forall m. + (MonadGet m) => + Ctx -> + Int -> + m (PublicKey, (Fingerprint, [KeyIndex])) +getHDPath ctx keySize = + (,) + <$> isolate keySize (marshalGet ctx :: Get PublicKey) + <*> ((\(PSBTHDPath s) -> s) <$> deserialize) -putHDPath :: Enum t => t -> HashMap PubKeyI (Fingerprint, [KeyIndex]) -> Put -putHDPath t = putPubKeyMap S.put t . fmap PSBTHDPath +putHDPath :: + (Enum t, MonadPut m) => + Ctx -> + t -> + HashMap PublicKey (Fingerprint, [KeyIndex]) -> + m () +putHDPath ctx t = putPubKeyMap ctx serialize t . fmap PSBTHDPath newtype PSBTHDPath = PSBTHDPath {unPSBTHDPath :: (Fingerprint, [KeyIndex])} - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic) + deriving newtype (NFData) -instance NFData PSBTHDPath +instance Serial PSBTHDPath where + deserialize = do + VarInt valueSize <- deserialize + unless (valueSize `mod` 4 == 0) $ + fail $ + "Expected valueSize = 4 but got " ++ show valueSize + let numIndices = (fromIntegral valueSize - 4) `div` 4 + PSBTHDPath + <$> isolate + (fromIntegral valueSize) + ((,) <$> deserialize <*> getKeyIndexList numIndices) + where + getKeyIndexList n = replicateM n getWord32le + + serialize (PSBTHDPath (fp, kis)) = do + putVarInt (B.length bs) + putByteString bs + where + bs = runPutS $ serialize fp >> mapM_ putWord32le kis + +instance Binary PSBTHDPath where + put = serialize + get = deserialize instance Serialize PSBTHDPath where - get = do - VarInt valueSize <- deserialize - guard $ valueSize `mod` 4 == 0 - let numIndices = (fromIntegral valueSize - 4) `div` 4 - PSBTHDPath - <$> S.isolate - (fromIntegral valueSize) - ((,) <$> S.get <*> getKeyIndexList numIndices) - where - getKeyIndexList n = replicateM n S.getWord32le + put = serialize + get = deserialize - put (PSBTHDPath (fp, kis)) = do - putVarInt (B.length bs) - S.putByteString bs - where - bs = S.runPut $ S.put fp >> mapM_ S.putWord32le kis - -putPubKeyMap :: Enum t => (a -> Put) -> t -> HashMap PubKeyI a -> Put -putPubKeyMap f t = - void . HashMap.traverseWithKey putItem +putPubKeyMap :: + (Enum t, MonadPut m) => + Ctx -> + (a -> m ()) -> + t -> + HashMap PublicKey a -> + m () +putPubKeyMap ctx f t = + void . HashMap.traverseWithKey putItem where putItem k v = do - S.put $ Key (enumWord8 t) (runPutS (serialize k)) - f v + serialize $ Key (enumWord8 t) (marshal ctx k) + f v -enumWord8 :: Enum a => a -> Word8 +enumWord8 :: (Enum a) => a -> Word8 enumWord8 = fromIntegral . fromEnum word8Enum :: forall a. (Bounded a, Enum a) => Word8 -> Either Word8 a word8Enum n | n <= enumWord8 (maxBound :: a) = Right . toEnum $ fromIntegral n word8Enum n = Left n -whenJust :: Monad m => (a -> m ()) -> Maybe a -> m () +whenJust :: (Monad m) => (a -> m ()) -> Maybe a -> m () whenJust = maybe (return ()) justWhen :: (a -> Bool) -> a -> Maybe a justWhen test x = if test x then Just x else Nothing + +isolate :: (MonadGet m) => Int -> Get a -> m a +isolate length getVal = do + bs <- getByteString length + either fail return (runGetS getVal bs) + +getNested :: (MonadGet m) => m Int -> Get a -> m a +getNested getLength getVal = do + length <- getLength + isolate length getVal diff --git a/src/Haskoin/Transaction/Segwit.hs b/src/Haskoin/Transaction/Segwit.hs index b9b0891c..0f16827a 100644 --- a/src/Haskoin/Transaction/Segwit.hs +++ b/src/Haskoin/Transaction/Segwit.hs @@ -1,22 +1,23 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Transaction.Segwit -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Types to represent segregated witness data and auxilliary functions to -manipulate it. See [BIP 141](https://github.com/bitcoin/bips/blob/master/bip-0141.mediawiki) -and [BIP 143](https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki) for -details. --} -module Haskoin.Transaction.Segwit ( - -- * Segwit +-- | +-- Module : Haskoin.Transaction.Segwit +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Types to represent segregated witness data and auxilliary functions to +-- manipulate it. See [BIP 141](https://github.com/bitcoin/bips/blob/master/bip-0141.mediawiki) +-- and [BIP 143](https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki) for +-- details. +module Haskoin.Transaction.Segwit + ( -- * Segwit WitnessProgram (..), WitnessProgramPKH (..), WitnessProgramSH (..), @@ -26,131 +27,149 @@ module Haskoin.Transaction.Segwit ( calcWitnessProgram, simpleInputStack, toWitnessStack, -) where + ) +where +import Crypto.Secp256k1 import Data.ByteString (ByteString) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Haskoin.Data -import Haskoin.Keys.Common -import Haskoin.Script +import Data.Bytes.Get (runGetS) +import Data.Bytes.Put (runPutS) +import Data.Bytes.Serial (Serial (deserialize, serialize)) +import Haskoin.Crypto.Keys.Common +import Haskoin.Network.Data +import Haskoin.Script.Common +import Haskoin.Script.SigHash +import Haskoin.Script.Standard import Haskoin.Transaction.Common +import Haskoin.Util.Marshal -{- | Test if a 'ScriptOutput' is P2WPKH or P2WSH - - @since 0.11.0.0 --} +-- | Test if a 'ScriptOutput' is P2WPKH or P2WSH +-- +-- @since 0.11.0.0 isSegwit :: ScriptOutput -> Bool isSegwit = \case - PayWitnessPKHash{} -> True - PayWitnessScriptHash{} -> True - _ -> False + PayWitnessPKHash {} -> True + PayWitnessScriptHash {} -> True + _ -> False -{- | High level represenation of a (v0) witness program - - @since 0.11.0.0 --} +-- | High level represenation of a (v0) witness program +-- +-- @since 0.11.0.0 data WitnessProgram - = P2WPKH WitnessProgramPKH - | P2WSH WitnessProgramSH - | EmptyWitnessProgram - deriving (Eq, Show) + = P2WPKH WitnessProgramPKH + | P2WSH WitnessProgramSH + | EmptyWitnessProgram + deriving (Eq) -{- | Encode a witness program +-- | Encode a witness program +-- +-- @since 0.11.0.0 +toWitnessStack :: Network -> Ctx -> WitnessProgram -> WitnessStack +toWitnessStack net ctx = \case + P2WPKH (WitnessProgramPKH sig key) -> + [encodeTxSig net ctx sig, marshal ctx key] + P2WSH (WitnessProgramSH stack scr) -> + stack <> [runPutS (serialize scr)] + EmptyWitnessProgram -> + mempty - @since 0.11.0.0 --} -toWitnessStack :: WitnessProgram -> WitnessStack -toWitnessStack = \case - P2WPKH (WitnessProgramPKH sig key) -> [encodeTxSig sig, runPutS (serialize key)] - P2WSH (WitnessProgramSH stack scr) -> stack <> [runPutS (serialize scr)] - EmptyWitnessProgram -> mempty - -{- | High level representation of a P2WPKH witness - - @since 0.11.0.0 --} +-- | High level representation of a P2WPKH witness +-- +-- @since 0.11.0.0 data WitnessProgramPKH = WitnessProgramPKH - { witnessSignature :: !TxSignature - , witnessPubKey :: !PubKeyI - } - deriving (Eq, Show) + { signature :: !TxSignature, + key :: !PublicKey + } + deriving (Eq) -{- | High-level representation of a P2WSH witness - - @since 0.11.0.0 --} +-- | High-level representation of a P2WSH witness +-- +-- @since 0.11.0.0 data WitnessProgramSH = WitnessProgramSH - { witnessScriptHashStack :: ![ByteString] - , witnessScriptHashScript :: !Script - } - deriving (Eq, Show) + { stack :: ![ByteString], + script :: !Script + } + deriving (Eq, Show) -{- | Calculate the witness program from the transaction data - - @since 0.11.0.0 --} +-- | Calculate the witness program from the transaction data +-- +-- @since 0.11.0.0 viewWitnessProgram :: - Network -> ScriptOutput -> WitnessStack -> Either String WitnessProgram -viewWitnessProgram net so witness = case so of - PayWitnessPKHash _ | length witness == 2 -> do - sig <- decodeTxSig net $ head witness - pubkey <- runGetS deserialize $ witness !! 1 - return . P2WPKH $ WitnessProgramPKH sig pubkey - PayWitnessScriptHash _ | not (null witness) -> do - redeemScript <- runGetS deserialize $ last witness - return . P2WSH $ WitnessProgramSH (init witness) redeemScript - _ - | null witness -> return EmptyWitnessProgram - | otherwise -> Left "viewWitnessProgram: Invalid witness program" + Network -> + Ctx -> + ScriptOutput -> + WitnessStack -> + Either String WitnessProgram +viewWitnessProgram net ctx so witness = case so of + PayWitnessPKHash _ | length witness == 2 -> do + sig <- decodeTxSig net ctx (head witness) + pubkey <- unmarshal ctx $ witness !! 1 + return . P2WPKH $ WitnessProgramPKH sig pubkey + PayWitnessScriptHash _ | not (null witness) -> do + redeemScript <- runGetS deserialize $ last witness + return . P2WSH $ WitnessProgramSH (init witness) redeemScript + _ + | null witness -> return EmptyWitnessProgram + | otherwise -> Left "viewWitnessProgram: Invalid witness program" -{- | Analyze the witness, trying to match it with standard input structures - - @since 0.11.0.0 --} +-- | Analyze the witness, trying to match it with standard input structures +-- +-- @since 0.11.0.0 decodeWitnessInput :: - Network -> - WitnessProgram -> - Either String (Maybe ScriptOutput, SimpleInput) -decodeWitnessInput net = \case - P2WPKH (WitnessProgramPKH sig key) -> return (Nothing, SpendPKHash sig key) - P2WSH (WitnessProgramSH st scr) -> do - so <- decodeOutput scr - fmap (Just so,) $ case (so, st) of - (PayPK _, [sigBS]) -> - SpendPK <$> decodeTxSig net sigBS - (PayPKHash _, [sigBS, keyBS]) -> - SpendPKHash <$> decodeTxSig net sigBS <*> runGetS deserialize keyBS - (PayMulSig _ _, "" : sigsBS) -> - SpendMulSig <$> traverse (decodeTxSig net) sigsBS - _ -> Left "decodeWitnessInput: Non-standard script output" - EmptyWitnessProgram -> Left "decodeWitnessInput: Empty witness program" + Network -> + Ctx -> + WitnessProgram -> + Either String (Maybe ScriptOutput, SimpleInput) +decodeWitnessInput net ctx = \case + P2WPKH (WitnessProgramPKH sig key) -> return (Nothing, SpendPKHash sig key) + P2WSH (WitnessProgramSH st scr) -> do + so <- decodeOutput ctx scr + fmap (Just so,) $ case (so, st) of + (PayPK _, [sigBS]) -> + SpendPK <$> decodeTxSig net ctx sigBS + (PayPKHash _, [sigBS, keyBS]) -> + SpendPKHash + <$> decodeTxSig net ctx sigBS + <*> unmarshal ctx keyBS + (PayMulSig _ _, "" : sigsBS) -> + SpendMulSig + <$> traverse (decodeTxSig net ctx) sigsBS + _ -> Left "decodeWitnessInput: Non-standard script output" + EmptyWitnessProgram -> Left "decodeWitnessInput: Empty witness program" -{- | Create the witness program for a standard input - - @since 0.11.0.0 --} -calcWitnessProgram :: ScriptOutput -> ScriptInput -> Either String WitnessProgram -calcWitnessProgram so si = case (so, si) of - (PayWitnessPKHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk - (PayScriptHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk - (PayWitnessScriptHash{}, ScriptHashInput i o) -> p2wsh i o - (PayScriptHash{}, ScriptHashInput i o) -> p2wsh i o - _ -> Left "calcWitnessProgram: Invalid segwit SigInput" +-- | Create the witness program for a standard input +-- +-- @since 0.11.0.0 +calcWitnessProgram :: + Network -> + Ctx -> + ScriptOutput -> + ScriptInput -> + Either String WitnessProgram +calcWitnessProgram net ctx so si = case (so, si) of + (PayWitnessPKHash {}, RegularInput (SpendPKHash sig pk)) -> + Right $ p2wpkh sig pk + (PayScriptHash {}, RegularInput (SpendPKHash sig pk)) -> + Right $ p2wpkh sig pk + (PayWitnessScriptHash {}, ScriptHashInput i o) -> + Right $ p2wsh i o + (PayScriptHash {}, ScriptHashInput i o) -> + Right $ p2wsh i o + _ -> Left "calcWitnessProgram: Invalid segwit SigInput" where - p2wpkh sig = return . P2WPKH . WitnessProgramPKH sig - p2wsh i o = return . P2WSH $ WitnessProgramSH (simpleInputStack i) (encodeOutput o) + p2wpkh sig = + P2WPKH . WitnessProgramPKH sig + p2wsh i = + P2WSH . WitnessProgramSH (simpleInputStack net ctx i) . encodeOutput ctx -{- | Create the witness stack required to spend a standard P2WSH input - - @since 0.11.0.0 --} -simpleInputStack :: SimpleInput -> [ByteString] -simpleInputStack = \case - SpendPK sig -> [f sig] - SpendPKHash sig k -> [f sig, runPutS (serialize k)] - SpendMulSig sigs -> "" : fmap f sigs +-- | Create the witness stack required to spend a standard P2WSH input +-- +-- @since 0.11.0.0 +simpleInputStack :: Network -> Ctx -> SimpleInput -> [ByteString] +simpleInputStack net ctx = \case + SpendPK sig -> [f sig] + SpendPKHash sig k -> [f sig, marshal ctx k] + SpendMulSig sigs -> "" : fmap f sigs where f TxSignatureEmpty = "" - f sig = encodeTxSig sig + f sig = encodeTxSig net ctx sig diff --git a/src/Haskoin/Transaction/Taproot.hs b/src/Haskoin/Transaction/Taproot.hs index b6332f92..5ccf9acc 100644 --- a/src/Haskoin/Transaction/Taproot.hs +++ b/src/Haskoin/Transaction/Taproot.hs @@ -1,21 +1,26 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Transaction.Taproot -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module provides support for reperesenting full taproot outputs and parsing -taproot witnesses. For reference see BIPS 340, 341, and 342. --} -module Haskoin.Transaction.Taproot ( - XOnlyPubKey (..), +-- | +-- Module : Haskoin.Transaction.Taproot +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- This module provides support for reperesenting full taproot outputs and parsing +-- taproot witnesses. For reference see BIPS 340, 341, and 342. +module Haskoin.Transaction.Taproot + ( XOnlyPubKey (..), TapLeafVersion, MAST (..), mastCommitment, @@ -28,283 +33,283 @@ module Haskoin.Transaction.Taproot ( viewTaprootWitness, encodeTaprootWitness, verifyScriptPathData, -) where + ) +where import Control.Applicative (many) import Control.Monad ((<=<)) -import Crypto.Hash ( - Digest, +import Crypto.Hash + ( Digest, SHA256, digestFromByteString, hashFinalize, hashUpdate, hashUpdates, - ) -import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) + ) +import Crypto.Secp256k1 +import Data.Aeson + ( FromJSON (parseJSON), + ToJSON (toJSON), + Value (String), + withText, + ) +import Data.Aeson.Types (Parser, Value) import Data.Binary (Binary (..)) import Data.Bits ((.&.), (.|.)) import Data.Bool (bool) -import qualified Data.ByteArray as BA +import Data.ByteArray qualified as BA import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Bytes.Get (getBytes, runGetS) -import Data.Bytes.Put (putByteString, runPutS) +import Data.ByteString qualified as BS +import Data.Bytes.Get (MonadGet, getBytes, runGetS) +import Data.Bytes.Put (MonadPut, putByteString, runPutL, runPutS) import Data.Bytes.Serial (Serial (..), deserialize, serialize) import Data.Bytes.VarInt (VarInt (VarInt)) import Data.Foldable (foldl') import Data.Maybe (fromMaybe, mapMaybe) import Data.Serialize (Serialize, get, getByteString, getWord8, put) import Data.Word (Word8) -import Haskoin.Crypto (PubKey, initTaggedHash, tweak, tweakAddPubKey) -import Haskoin.Keys.Common (PubKeyI (PubKeyI), pubKeyPoint) -import Haskoin.Script.Common (Script) -import Haskoin.Script.Standard (ScriptOutput (PayWitness)) -import Haskoin.Transaction.Common (WitnessStack) -import Haskoin.Util (decodeHex, eitherToMaybe, encodeHex) +import Haskoin.Crypto.Hash +import Haskoin.Crypto.Keys.Common +import Haskoin.Crypto.Keys.Extended +import Haskoin.Script.Common +import Haskoin.Script.Standard +import Haskoin.Transaction.Common +import Haskoin.Util -{- | An x-only pubkey corresponds to the keys @(x,y)@ and @(x, -y)@. The -equality test only checks the x-coordinate. An x-only pubkey serializes to 32 -bytes. - -@since 0.21.0 --} -newtype XOnlyPubKey = XOnlyPubKey {xOnlyPubKey :: PubKey} - deriving (Show) +-- | An x-only pubkey corresponds to the keys @(x,y)@ and @(x, -y)@. The +-- equality test only checks the x-coordinate. An x-only pubkey serializes to 32 +-- bytes. +-- +-- @since 0.21.0 +newtype XOnlyPubKey = XOnlyPubKey {point :: PubKey} + deriving (Read, Show) instance Eq XOnlyPubKey where - k1 == k2 = runPutS (serialize k1) == runPutS (serialize k2) + XOnlyPubKey k1 == XOnlyPubKey k2 = f k1 == f k2 + where + f = BS.take 32 . (.get) -instance Serial XOnlyPubKey where - serialize (XOnlyPubKey pk) = - putByteString - . BS.drop 1 - . runPutS - . serialize - $ PubKeyI pk True - deserialize = - either fail (pure . XOnlyPubKey . pubKeyPoint) - . runGetS deserialize - . BS.cons 0x02 - =<< getBytes 32 +instance Marshal Ctx XOnlyPubKey where + marshalPut ctx (XOnlyPubKey pk) = + putByteString + . BS.drop 1 + . marshal ctx + $ PublicKey pk True -instance Serialize XOnlyPubKey where - put = serialize - get = deserialize + marshalGet ctx = + either fail (pure . XOnlyPubKey . (\PublicKey {point} -> point)) + . unmarshal ctx + . BS.cons 0x02 + =<< getBytes 32 -instance Binary XOnlyPubKey where - put = serialize - get = deserialize +instance MarshalJSON Ctx XOnlyPubKey where + unmarshalValue ctx = + withText "XOnlyPubKey" $ either fail pure . (des <=< hex) + where + hex = maybe (Left "Unable to decode hex") Right . decodeHex + des = runGetS $ marshalGet ctx --- | Hex encoding -instance FromJSON XOnlyPubKey where - parseJSON = - withText "XOnlyPubKey" $ - either fail pure - . (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex) + marshalValue ctx = + String . encodeHex . marshal ctx --- | Hex encoding -instance ToJSON XOnlyPubKey where - toJSON = toJSON . encodeHex . runPutS . serialize + marshalEncoding ctx = + hexEncoding . runPutL . marshalPut ctx -- | @since 0.21.0 type TapLeafVersion = Word8 -{- | Merklized Abstract Syntax Tree. This type can represent trees where only a -subset of the leaves are known. Note that the tree is invariant under swapping -branches at an internal node. - -@since 0.21.0 --} +-- | Merklized Abstract Syntax Tree. This type can represent trees where only a +-- subset of the leaves are known. Note that the tree is invariant under swapping +-- branches at an internal node. +-- +-- @since 0.21.0 data MAST - = MASTBranch MAST MAST - | MASTLeaf TapLeafVersion Script - | MASTCommitment (Digest SHA256) - deriving (Show) + = MASTBranch MAST MAST + | MASTLeaf TapLeafVersion Script + | MASTCommitment (Digest SHA256) + deriving (Show) -{- | Get the inclusion proofs for the leaves in the tree. The proof is ordered -leaf-to-root. - -@since 0.21.0 --} +-- | Get the inclusion proofs for the leaves in the tree. The proof is ordered +-- leaf-to-root. +-- +-- @since 0.21.0 getMerkleProofs :: MAST -> [(TapLeafVersion, Script, [Digest SHA256])] getMerkleProofs = getProofs mempty where getProofs proof = \case - MASTBranch branchL branchR -> - (updateProof proof (mastCommitment branchR) <$> getMerkleProofs branchL) - <> (updateProof proof (mastCommitment branchL) <$> getMerkleProofs branchR) - MASTLeaf v s -> [(v, s, proof)] - MASTCommitment{} -> mempty + MASTBranch branchL branchR -> + (updateProof proof (mastCommitment branchR) <$> getMerkleProofs branchL) + <> (updateProof proof (mastCommitment branchL) <$> getMerkleProofs branchR) + MASTLeaf v s -> [(v, s, proof)] + MASTCommitment {} -> mempty updateProof proofInit branchCommitment (v, s, proofTail) = - (v, s, reverse $ proofInit <> (branchCommitment : proofTail)) + (v, s, reverse $ proofInit <> (branchCommitment : proofTail)) -{- | Calculate the root hash for this tree. - -@since 0.21.0 --} +-- | Calculate the root hash for this tree. +-- +-- @since 0.21.0 mastCommitment :: MAST -> Digest SHA256 mastCommitment = \case - MASTBranch leftBranch rightBranch -> - hashBranch (mastCommitment leftBranch) (mastCommitment rightBranch) - MASTLeaf leafVersion leafScript -> leafHash leafVersion leafScript - MASTCommitment theCommitment -> theCommitment + MASTBranch leftBranch rightBranch -> + hashBranch (mastCommitment leftBranch) (mastCommitment rightBranch) + MASTLeaf leafVersion leafScript -> leafHash leafVersion leafScript + MASTCommitment theCommitment -> theCommitment hashBranch :: Digest SHA256 -> Digest SHA256 -> Digest SHA256 hashBranch hashA hashB = - hashFinalize $ - hashUpdates - (initTaggedHash "TapBranch") - [ min hashA hashB - , max hashA hashB - ] + hashFinalize $ + hashUpdates + (initTaggedHash "TapBranch") + [ min hashA hashB, + max hashA hashB + ] leafHash :: TapLeafVersion -> Script -> Digest SHA256 leafHash leafVersion leafScript = - hashFinalize - . hashUpdate (initTaggedHash "TapLeaf") - . runPutS - $ do - serialize leafVersion - serialize $ VarInt (BS.length scriptBytes) - putByteString scriptBytes + hashFinalize + . hashUpdate (initTaggedHash "TapLeaf") + . runPutS + $ do + serialize leafVersion + serialize $ VarInt (BS.length scriptBytes) + putByteString scriptBytes where scriptBytes = runPutS $ serialize leafScript -{- | Representation of a full taproot output. - -@since 0.21.0 --} +-- | Representation of a full taproot output. +-- +-- @since 0.21.0 data TaprootOutput = TaprootOutput - { taprootInternalKey :: PubKey - , taprootMAST :: Maybe MAST - } - deriving (Show) + { internalKey :: PubKey, + mast :: Maybe MAST + } -- | @since 0.21.0 -taprootOutputKey :: TaprootOutput -> PubKey -taprootOutputKey TaprootOutput{taprootInternalKey, taprootMAST} = - fromMaybe keyFail $ tweak commitment >>= tweakAddPubKey taprootInternalKey +taprootOutputKey :: Ctx -> TaprootOutput -> PubKey +taprootOutputKey ctx TaprootOutput {..} = + fromMaybe keyFail $ + tweak commitment >>= tweakAddPubKey ctx internalKey where - commitment = taprootCommitment taprootInternalKey $ mastCommitment <$> taprootMAST + commitment = + taprootCommitment ctx internalKey $ + mastCommitment <$> mast keyFail = error "haskoin-core taprootOutputKey: key derivation failed" -taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> ByteString -taprootCommitment internalKey merkleRoot = - BA.convert . hashFinalize - . maybe id (flip hashUpdate) merkleRoot - . (`hashUpdate` keyBytes) - $ initTaggedHash "TapTweak" +taprootCommitment :: Ctx -> PubKey -> Maybe (Digest SHA256) -> ByteString +taprootCommitment ctx internalKey merkleRoot = + BA.convert + . hashFinalize + . maybe id (flip hashUpdate) merkleRoot + . (`hashUpdate` keyBytes) + $ initTaggedHash "TapTweak" where - keyBytes = runPutS . serialize $ XOnlyPubKey internalKey + keyBytes = runPutS . marshalPut ctx $ XOnlyPubKey internalKey -{- | Generate the output script for a taproot output +-- | Generate the output script for a taproot output +-- +-- @since 0.21.0 +taprootScriptOutput :: Ctx -> TaprootOutput -> ScriptOutput +taprootScriptOutput ctx = + PayWitness 0x01 + . runPutS + . marshalPut ctx + . XOnlyPubKey + . taprootOutputKey ctx -@since 0.21.0 --} -taprootScriptOutput :: TaprootOutput -> ScriptOutput -taprootScriptOutput = PayWitness 0x01 . runPutS . serialize . XOnlyPubKey . taprootOutputKey - -{- | Comprehension of taproot witness data - -@since 0.21.0 --} +-- | Comprehension of taproot witness data +-- +-- @since 0.21.0 data TaprootWitness - = -- | Signature - KeyPathSpend ByteString - | ScriptPathSpend ScriptPathData - deriving (Eq, Show) + = -- | Signature + KeyPathSpend ByteString + | ScriptPathSpend ScriptPathData + deriving (Eq) -- | @since 0.21.0 data ScriptPathData = ScriptPathData - { scriptPathAnnex :: Maybe ByteString - , scriptPathStack :: [ByteString] - , scriptPathScript :: Script - , scriptPathExternalIsOdd :: Bool - , -- | This value is masked by 0xFE - scriptPathLeafVersion :: Word8 - , scriptPathInternalKey :: PubKey - , scriptPathControl :: [ByteString] - } - deriving (Eq, Show) + { annex :: Maybe ByteString, + stack :: [ByteString], + script :: Script, + extIsOdd :: Bool, + -- | This value is masked by 0xFE + leafVersion :: Word8, + internalKey :: PubKey, + control :: [ByteString] + } + deriving (Eq) -{- | Try to interpret a 'WitnessStack' as taproot witness data. - -@since 0.21.0 --} -viewTaprootWitness :: WitnessStack -> Maybe TaprootWitness -viewTaprootWitness witnessStack = case reverse witnessStack of - [sig] -> Just $ KeyPathSpend sig - annexA : remainingStack - | 0x50 : _ <- BS.unpack annexA -> - parseSpendPathData (Just annexA) remainingStack - remainingStack -> parseSpendPathData Nothing remainingStack +-- | Try to interpret a 'WitnessStack' as taproot witness data. +-- +-- @since 0.21.0 +viewTaprootWitness :: Ctx -> WitnessStack -> Maybe TaprootWitness +viewTaprootWitness ctx witnessStack = case reverse witnessStack of + [sig] -> Just $ KeyPathSpend sig + annexA : remainingStack + | 0x50 : _ <- BS.unpack annexA -> + parseSpendPathData (Just annexA) remainingStack + remainingStack -> parseSpendPathData Nothing remainingStack where - parseSpendPathData scriptPathAnnex = \case - scriptBytes : controlBytes : scriptPathStack -> do - scriptPathScript <- eitherToMaybe $ runGetS deserialize scriptBytes - (v, scriptPathInternalKey, scriptPathControl) <- deconstructControl controlBytes - pure . ScriptPathSpend $ - ScriptPathData - { scriptPathAnnex - , scriptPathStack - , scriptPathScript - , scriptPathExternalIsOdd = odd v - , scriptPathLeafVersion = v .&. 0xFE - , scriptPathInternalKey - , scriptPathControl - } - _ -> Nothing + parseSpendPathData annex = \case + scriptBytes : controlBytes : stack -> do + script <- eitherToMaybe $ runGetS deserialize scriptBytes + (v, internalKey, control) <- deconstructControl controlBytes + let extIsOdd = odd v + leafVersion = v .&. 0xFE + pure $ ScriptPathSpend ScriptPathData {..} + _ -> Nothing deconstructControl = eitherToMaybe . runGetS deserializeControl deserializeControl = do - v <- getWord8 - k <- xOnlyPubKey <$> deserialize - proof <- many $ getByteString 32 - pure (v, k, proof) + v <- getWord8 + XOnlyPubKey k <- marshalGet ctx + proof <- many $ getByteString 32 + pure (v, k, proof) -{- | Transform the high-level representation of taproot witness data into a witness stack - -@since 0.21.0 --} -encodeTaprootWitness :: TaprootWitness -> WitnessStack -encodeTaprootWitness = \case - KeyPathSpend signature -> pure signature - ScriptPathSpend scriptPathData -> - scriptPathStack scriptPathData - <> [ runPutS . serialize $ scriptPathScript scriptPathData - , mconcat - [ BS.pack [scriptPathLeafVersion scriptPathData .|. parity scriptPathData] - , runPutS . serialize . XOnlyPubKey $ scriptPathInternalKey scriptPathData - , mconcat $ scriptPathControl scriptPathData - ] - , fromMaybe mempty $ scriptPathAnnex scriptPathData - ] +-- | Transform the high-level representation of taproot witness data into a witness stack +-- +-- @since 0.21.0 +encodeTaprootWitness :: Ctx -> TaprootWitness -> WitnessStack +encodeTaprootWitness ctx = \case + KeyPathSpend signature -> pure signature + ScriptPathSpend scriptPathData -> wit scriptPathData where - parity = bool 0 1 . scriptPathExternalIsOdd + wit d = (.stack) d <> [script d, keys d, annex d] + keys d = mconcat [verpar d, xonlyk d, ctrl d] + script = runPutS . serialize . (.script) + verpar d = BS.pack [(.leafVersion) d .|. parity d] + xonlyk = runPutS . marshalPut ctx . XOnlyPubKey . (.internalKey) + annex = fromMaybe mempty . (.annex) + ctrl = mconcat . (.control) + parity = bool 0 1 . (.extIsOdd) -{- | Verify that the script path spend is valid, except for script execution. - -@since 0.21.0 --} +-- | Verify that the script path spend is valid, except for script execution. +-- +-- @since 0.21.0 verifyScriptPathData :: - -- | Output key - PubKey -> - ScriptPathData -> - Bool -verifyScriptPathData outputKey scriptPathData = fromMaybe False $ do - tweak commitment >>= fmap onComputedKey . tweakAddPubKey (scriptPathInternalKey scriptPathData) + Ctx -> + -- | Output key + PubKey -> + ScriptPathData -> + Bool +verifyScriptPathData ctx outkey spd = fromMaybe False $ do + tweak commitment + >>= fmap onComputedKey + . tweakAddPubKey ctx spd.internalKey where onComputedKey computedKey = - XOnlyPubKey outputKey == XOnlyPubKey computedKey - && expectedParity == keyParity computedKey - commitment = taprootCommitment (scriptPathInternalKey scriptPathData) (Just merkleRoot) + XOnlyPubKey outkey == XOnlyPubKey computedKey + && expectedParity == keyParity ctx computedKey + commitment = + taprootCommitment ctx spd.internalKey (Just merkleRoot) merkleRoot = - foldl' hashBranch theLeafHash - . mapMaybe (digestFromByteString @SHA256) - $ scriptPathControl scriptPathData - theLeafHash = (leafHash <$> (.&. 0xFE) . scriptPathLeafVersion <*> scriptPathScript) scriptPathData - expectedParity = bool 0 1 $ scriptPathExternalIsOdd scriptPathData + foldl' hashBranch theLeafHash $ + mapMaybe (digestFromByteString @SHA256) spd.control + theLeafHash = + (leafHash <$> (.&. 0xFE) . (.leafVersion) <*> (.script)) + spd + expectedParity = bool 0 1 spd.extIsOdd -keyParity :: PubKey -> Word8 -keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of +keyParity :: Ctx -> PubKey -> Word8 +keyParity ctx key = + case BS.unpack . marshal ctx $ PublicKey key True of 0x02 : _ -> 0x00 _ -> 0x01 diff --git a/src/Haskoin/Util.hs b/src/Haskoin/Util.hs index bdb35e47..32d513e8 100644 --- a/src/Haskoin/Util.hs +++ b/src/Haskoin/Util.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ImportQualifiedPost #-} - -- | -- Module : Haskoin.Util -- Copyright : No rights reserved @@ -11,376 +6,12 @@ -- Stability : experimental -- Portability : POSIX -- --- This module defines various utility functions used across the library. +-- Marshalling and helper functions. module Haskoin.Util - ( -- * ByteString Helpers - bsToInteger, - integerToBS, - hexBuilder, - encodeHex, - encodeHexLazy, - decodeHex, - decodeHexLazy, - getBits, - - -- * Maybe & Either Helpers - eitherToMaybe, - maybeToEither, - liftEither, - liftMaybe, - - -- * Other Helpers - updateIndex, - matchTemplate, - convertBits, - - -- * Triples - fst3, - snd3, - lst3, - - -- * JSON Utilities - dropFieldLabel, - dropSumLabels, - - -- * Serialization Helpers - putList, - getList, - putMaybe, - getMaybe, - putLengthBytes, - getLengthBytes, - putInteger, - getInteger, - putInt32be, - getInt32be, - putInt64be, - getInt64be, - getIntMap, - putIntMap, - getTwo, - putTwo, + ( module Marshal, + module Helpers, ) where -import Control.Monad -import Control.Monad.Except (ExceptT (..), liftEither) -import Data.Aeson.Types - ( Options (..), - SumEncoding (..), - defaultOptions, - defaultTaggedObject, - ) -import Data.Base16.Types (assertBase16, extractBase16) -import Data.Bits -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Base16 qualified as B16 -import Data.ByteString.Builder -import Data.ByteString.Lazy qualified as BL -import Data.ByteString.Lazy.Base16 qualified as BL16 -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Char (toLower) -import Data.Int -import Data.IntMap (IntMap) -import Data.IntMap qualified as IntMap -import Data.List -import Data.Text (Text) -import Data.Text.Encoding qualified as E -import Data.Text.Lazy qualified as TL -import Data.Text.Lazy.Encoding qualified as EL -import Data.Word - --- ByteString helpers - --- | Decode a big endian 'Integer' from a 'ByteString'. -bsToInteger :: ByteString -> Integer -bsToInteger = BS.foldr f 0 . BS.reverse - where - f w n = toInteger w .|. shiftL n 8 - --- | Encode an 'Integer' to a 'ByteString' as big endian. -integerToBS :: Integer -> ByteString -integerToBS 0 = BS.pack [0] -integerToBS i - | i > 0 = BS.reverse $ BS.unfoldr f i - | otherwise = error "integerToBS not defined for negative values" - where - f 0 = Nothing - f x = Just (fromInteger x :: Word8, x `shiftR` 8) - -hexBuilder :: BL.ByteString -> Builder -hexBuilder = lazyByteStringHex - -encodeHex :: ByteString -> Text -encodeHex = extractBase16 . B16.encodeBase16 - --- | Encode as string of human-readable hex characters. -encodeHexLazy :: BL.ByteString -> TL.Text -encodeHexLazy = extractBase16 . BL16.encodeBase16 - -decodeHex :: Text -> Maybe ByteString -decodeHex t = - if B16.isBase16 u8 - then Just . B16.decodeBase16 $ assertBase16 u8 - else Nothing - where - u8 = E.encodeUtf8 t - --- | Decode string of human-readable hex characters. -decodeHexLazy :: TL.Text -> Maybe BL.ByteString -decodeHexLazy t = - if BL16.isBase16 u8 - then Just . BL16.decodeBase16 $ assertBase16 u8 - else Nothing - where - u8 = EL.encodeUtf8 t - --- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString' --- will be smallest required to hold that many bits, padded with zeroes to the --- right. -getBits :: Int -> ByteString -> ByteString -getBits b bs - | r == 0 = BS.take q bs - | otherwise = i `BS.snoc` l - where - (q, r) = b `quotRem` 8 - s = BS.take (q + 1) bs - i = BS.init s - l = BS.last s .&. (0xff `shiftL` (8 - r)) -- zero unneeded bits - --- Maybe and Either monad helpers - --- | Transform an 'Either' value into a 'Maybe' value. 'Right' is mapped to --- 'Just' and 'Left' is mapped to 'Nothing'. The value inside 'Left' is lost. -eitherToMaybe :: Either a b -> Maybe b -eitherToMaybe (Right b) = Just b -eitherToMaybe _ = Nothing - --- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to --- 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required. -maybeToEither :: b -> Maybe a -> Either b a -maybeToEither err = maybe (Left err) Right - --- | Lift a 'Maybe' computation into the 'ExceptT' monad. -liftMaybe :: (Monad m) => b -> Maybe a -> ExceptT b m a -liftMaybe err = liftEither . maybeToEither err - --- Various helpers - --- | Applies a function to only one element of a list defined by its index. If --- the index is out of the bounds of the list, the original list is returned. -updateIndex :: - -- | index of the element to change - Int -> - -- | list of elements - [a] -> - -- | function to apply - (a -> a) -> - -- | result with one element changed - [a] -updateIndex i xs f - | i < 0 || i >= length xs = xs - | otherwise = l ++ (f h : r) - where - (l, h : r) = splitAt i xs - --- | Use the list @[b]@ as a template and try to match the elements of @[a]@ --- against it. For each element of @[b]@ return the (first) matching element of --- @[a]@, or 'Nothing'. Output list has same size as @[b]@ and contains results --- in same order. Elements of @[a]@ can only appear once. -matchTemplate :: - -- | input list - [a] -> - -- | list to serve as a template - [b] -> - -- | comparison function - (a -> b -> Bool) -> - [Maybe a] -matchTemplate [] bs _ = replicate (length bs) Nothing -matchTemplate _ [] _ = [] -matchTemplate as (b : bs) f = case break (`f` b) as of - (l, r : rs) -> Just r : matchTemplate (l ++ rs) bs f - _ -> Nothing : matchTemplate as bs f - --- | Returns the first value of a triple. -fst3 :: (a, b, c) -> a -fst3 (a, _, _) = a - --- | Returns the second value of a triple. -snd3 :: (a, b, c) -> b -snd3 (_, b, _) = b - --- | Returns the last value of a triple. -lst3 :: (a, b, c) -> c -lst3 (_, _, c) = c - --- | Field label goes lowercase and first @n@ characters get removed. -dropFieldLabel :: Int -> Options -dropFieldLabel n = - defaultOptions - { fieldLabelModifier = map toLower . drop n - } - --- | Transformation from 'dropFieldLabel' is applied with argument @f@, plus --- constructor tags are lowercased and first @c@ characters removed. @tag@ is --- used as the name of the object field name that will hold the transformed --- constructor tag as its value. -dropSumLabels :: Int -> Int -> String -> Options -dropSumLabels c f tag = - (dropFieldLabel f) - { constructorTagModifier = map toLower . drop c, - sumEncoding = defaultTaggedObject {tagFieldName = tag} - } - --- | Convert from one power-of-two base to another, as long as it fits in a --- 'Word'. -convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool) -convertBits pad frombits tobits i = (reverse yout, rem') - where - (xacc, xbits, xout) = foldl' outer (0, 0, []) i - (yout, rem') - | pad && xbits /= 0 = - let xout' = (xacc `shiftL` (tobits - xbits)) .&. maxv : xout - in (xout', False) - | pad = (xout, False) - | xbits /= 0 = (xout, True) - | otherwise = (xout, False) - maxv = 1 `shiftL` tobits - 1 - max_acc = 1 `shiftL` (frombits + tobits - 1) - 1 - outer (acc, bits, out) it = - let acc' = ((acc `shiftL` frombits) .|. it) .&. max_acc - bits' = bits + frombits - (out', bits'') = inner acc' out bits' - in (acc', bits'', out') - inner acc out bits - | bits >= tobits = - let bits' = bits - tobits - out' = ((acc `shiftR` bits') .&. maxv) : out - in inner acc out' bits' - | otherwise = (out, bits) - --- --- Serialization helpers --- - -putInt32be :: (MonadPut m) => Int32 -> m () -putInt32be n - | n < 0 = putWord32be (complement (fromIntegral (abs n)) + 1) - | otherwise = putWord32be (fromIntegral (abs n)) - -getInt32be :: (MonadGet m) => m Int32 -getInt32be = do - n <- getWord32be - if testBit n 31 - then return (negate (complement (fromIntegral n) + 1)) - else return (fromIntegral n) - -putInt64be :: (MonadPut m) => Int64 -> m () -putInt64be n - | n < 0 = putWord64be (complement (fromIntegral (abs n)) + 1) - | otherwise = putWord64be (fromIntegral (abs n)) - -getInt64be :: (MonadGet m) => m Int64 -getInt64be = do - n <- getWord64be - if testBit n 63 - then return (negate (complement (fromIntegral n) + 1)) - else return (fromIntegral n) - -putInteger :: (MonadPut m) => Integer -> m () -putInteger n - | n >= lo && n <= hi = do - putWord8 0x00 - putInt32be (fromIntegral n) - | otherwise = do - putWord8 0x01 - putWord8 (fromIntegral (signum n)) - let len = (nrBits (abs n) + 7) `div` 8 - putWord64be (fromIntegral len) - mapM_ putWord8 (unroll (abs n)) - where - lo = fromIntegral (minBound :: Int32) - hi = fromIntegral (maxBound :: Int32) - -getInteger :: (MonadGet m) => m Integer -getInteger = - getWord8 >>= \case - 0 -> fromIntegral <$> getInt32be - _ -> do - sign <- getWord8 - bytes <- getList getWord8 - let v = roll bytes - return $! if sign == 0x01 then v else -v - -putMaybe :: (MonadPut m) => (a -> m ()) -> Maybe a -> m () -putMaybe f Nothing = putWord8 0x00 -putMaybe f (Just x) = putWord8 0x01 >> f x - -getMaybe :: (MonadGet m) => m a -> m (Maybe a) -getMaybe f = - getWord8 >>= \case - 0x00 -> return Nothing - 0x01 -> Just <$> f - _ -> fail "Not a Maybe" - -putLengthBytes :: (MonadPut m) => ByteString -> m () -putLengthBytes bs = do - putWord64be (fromIntegral (BS.length bs)) - putByteString bs - -getLengthBytes :: (MonadGet m) => m ByteString -getLengthBytes = do - len <- fromIntegral <$> getWord64be - getByteString len - --- --- Fold and unfold an Integer to and from a list of its bytes --- -unroll :: (Integral a, Bits a) => a -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: (Integral a, Bits a) => [Word8] -> a -roll = foldr unstep 0 - where - unstep b a = a `shiftL` 8 .|. fromIntegral b - -nrBits :: (Ord a, Integral a) => a -> Int -nrBits k = - let expMax = until (\e -> 2 ^ e > k) (* 2) 1 - findNr :: Int -> Int -> Int - findNr lo hi - | mid == lo = hi - | 2 ^ mid <= k = findNr mid hi - | 2 ^ mid > k = findNr lo mid - where - mid = (lo + hi) `div` 2 - in findNr (expMax `div` 2) expMax - --- | Read as a list of pairs of int and element. -getIntMap :: (MonadGet m) => m Int -> m a -> m (IntMap a) -getIntMap i m = IntMap.fromList <$> getList (getTwo i m) - -putIntMap :: (MonadPut m) => (Int -> m ()) -> (a -> m ()) -> IntMap a -> m () -putIntMap f g = putList (putTwo f g) . IntMap.toAscList - -putTwo :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> (a, b) -> m () -putTwo f g (x, y) = f x >> g y - -getTwo :: (MonadGet m) => m a -> m b -> m (a, b) -getTwo f g = (,) <$> f <*> g - -putList :: (MonadPut m) => (a -> m ()) -> [a] -> m () -putList f ls = do - putWord64be (fromIntegral (length ls)) - mapM_ f ls - -getList :: (MonadGet m) => m a -> m [a] -getList f = do - l <- fromIntegral <$> getWord64be - replicateM l f +import Haskoin.Util.Helpers as Helpers +import Haskoin.Util.Marshal as Marshal diff --git a/src/Haskoin/Util/Arbitrary.hs b/src/Haskoin/Util/Arbitrary.hs index 628f4f24..3311baca 100644 --- a/src/Haskoin/Util/Arbitrary.hs +++ b/src/Haskoin/Util/Arbitrary.hs @@ -1,16 +1,16 @@ -{- | -Module : Haskoin.Test -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Arbitrary instances for testing. --} -module Haskoin.Util.Arbitrary ( - module X, -) where +-- | +-- Module : Haskoin.Test +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Arbitrary instances for testing. +module Haskoin.Util.Arbitrary + ( module X, + ) +where import Haskoin.Util.Arbitrary.Address as X import Haskoin.Util.Arbitrary.Block as X diff --git a/src/Haskoin/Util/Arbitrary/Address.hs b/src/Haskoin/Util/Arbitrary/Address.hs index 368af4e9..97650106 100644 --- a/src/Haskoin/Util/Arbitrary/Address.hs +++ b/src/Haskoin/Util/Arbitrary/Address.hs @@ -1,19 +1,18 @@ {-# LANGUAGE TupleSections #-} -{- | -Module : Haskoin.Test.Address -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Module : Haskoin.Test.Address +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Address where import qualified Data.ByteString as B import Haskoin.Address -import Haskoin.Constants -import Haskoin.Data +import Haskoin.Network.Constants +import Haskoin.Network.Data import Haskoin.Util.Arbitrary.Crypto import Haskoin.Util.Arbitrary.Util import Test.QuickCheck @@ -25,21 +24,21 @@ arbitraryAddress = oneof [arbitraryPubKeyAddress, arbitraryScriptAddress] -- | Arbitrary address including pay-to-witness arbitraryAddressAll :: Gen Address arbitraryAddressAll = - oneof - [ arbitraryPubKeyAddress - , arbitraryScriptAddress - , arbitraryWitnessPubKeyAddress - , arbitraryWitnessScriptAddress - , arbitraryWitnessAddress - ] + oneof + [ arbitraryPubKeyAddress, + arbitraryScriptAddress, + arbitraryWitnessPubKeyAddress, + arbitraryWitnessScriptAddress, + arbitraryWitnessAddress + ] -- | Arbitrary valid combination of (Network, Address) arbitraryNetAddress :: Gen (Network, Address) arbitraryNetAddress = do - net <- arbitraryNetwork - if net `elem` [bch, bchTest, bchTest4, bchRegTest] - then (net,) <$> arbitraryAddress - else (net,) <$> arbitraryAddressAll + net <- arbitraryNetwork + if net `elem` [bch, bchTest, bchTest4, bchRegTest] + then (net,) <$> arbitraryAddress + else (net,) <$> arbitraryAddressAll -- | Arbitrary pay-to-public-key-hash address. arbitraryPubKeyAddress :: Gen Address @@ -59,8 +58,8 @@ arbitraryWitnessScriptAddress = WitnessPubKeyAddress <$> arbitraryHash160 arbitraryWitnessAddress :: Gen Address arbitraryWitnessAddress = do - ver <- choose (1, 16) - len <- choose (2, 40) - ws <- vectorOf len arbitrary - let bs = B.pack ws - return $ WitnessAddress ver bs + ver <- choose (1, 16) + len <- choose (2, 40) + ws <- vectorOf len arbitrary + let bs = B.pack ws + return $ WitnessAddress ver bs diff --git a/src/Haskoin/Util/Arbitrary/Block.hs b/src/Haskoin/Util/Arbitrary/Block.hs index 2a57e2b3..3df235a2 100644 --- a/src/Haskoin/Util/Arbitrary/Block.hs +++ b/src/Haskoin/Util/Arbitrary/Block.hs @@ -1,16 +1,16 @@ -{- | -Module : Haskoin.Test.Block -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Module : Haskoin.Test.Block +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Block where import qualified Data.HashMap.Strict as HashMap import Haskoin.Block -import Haskoin.Data +import Haskoin.Crypto (Ctx) +import Haskoin.Network.Data import Haskoin.Util.Arbitrary.Crypto import Haskoin.Util.Arbitrary.Network import Haskoin.Util.Arbitrary.Transaction @@ -18,22 +18,23 @@ import Haskoin.Util.Arbitrary.Util import Test.QuickCheck -- | Block full or arbitrary transactions. -arbitraryBlock :: Network -> Gen Block -arbitraryBlock net = do - h <- arbitraryBlockHeader - c <- choose (0, 10) - txs <- vectorOf c (arbitraryTx net) - return $ Block h txs +arbitraryBlock :: Network -> Ctx -> Gen Block +arbitraryBlock net ctx = do + h <- arbitraryBlockHeader + c <- choose (0, 10) + txs <- vectorOf c (arbitraryTx net ctx) + return $ Block h txs -- | Block header with random hash. arbitraryBlockHeader :: Gen BlockHeader arbitraryBlockHeader = - BlockHeader <$> arbitrary - <*> arbitraryBlockHash - <*> arbitraryHash256 - <*> arbitrary - <*> arbitrary - <*> arbitrary + BlockHeader + <$> arbitrary + <*> arbitraryBlockHash + <*> arbitraryHash256 + <*> arbitrary + <*> arbitrary + <*> arbitrary -- | Arbitrary block hash. arbitraryBlockHash :: Gen BlockHash @@ -42,45 +43,45 @@ arbitraryBlockHash = BlockHash <$> arbitraryHash256 -- | Arbitrary 'GetBlocks' object with at least one block hash. arbitraryGetBlocks :: Gen GetBlocks arbitraryGetBlocks = - GetBlocks <$> arbitrary - <*> listOf1 arbitraryBlockHash - <*> arbitraryBlockHash + GetBlocks + <$> arbitrary + <*> listOf1 arbitraryBlockHash + <*> arbitraryBlockHash -- | Arbitrary 'GetHeaders' object with at least one block header. arbitraryGetHeaders :: Gen GetHeaders arbitraryGetHeaders = - GetHeaders <$> arbitrary - <*> listOf1 arbitraryBlockHash - <*> arbitraryBlockHash + GetHeaders + <$> arbitrary + <*> listOf1 arbitraryBlockHash + <*> arbitraryBlockHash -- | Arbitrary 'Headers' object with at least one block header. arbitraryHeaders :: Gen Headers arbitraryHeaders = - Headers <$> listOf1 ((,) <$> arbitraryBlockHeader <*> arbitraryVarInt) + Headers <$> listOf1 ((,) <$> arbitraryBlockHeader <*> arbitraryVarInt) -- | Arbitrary 'MerkleBlock' with at least one hash. arbitraryMerkleBlock :: Gen MerkleBlock arbitraryMerkleBlock = do - bh <- arbitraryBlockHeader - ntx <- arbitrary - hashes <- listOf1 arbitraryHash256 - c <- choose (1, 10) - flags <- vectorOf (c * 8) arbitrary - return $ MerkleBlock bh ntx hashes flags + bh <- arbitraryBlockHeader + ntx <- arbitrary + hashes <- listOf1 arbitraryHash256 + c <- choose (1, 10) + flags <- vectorOf (c * 8) arbitrary + return $ MerkleBlock bh ntx hashes flags -- | Arbitrary 'BlockNode' arbitraryBlockNode :: Gen BlockNode arbitraryBlockNode = - oneof - [ BlockNode - <$> arbitraryBlockHeader - <*> choose (0, maxBound) - <*> arbitrarySizedNatural - <*> arbitraryBlockHash - ] + BlockNode + <$> arbitraryBlockHeader + <*> choose (0, maxBound) + <*> arbitrarySizedNatural + <*> arbitraryBlockHash -- | Arbitrary 'HeaderMemory' arbitraryHeaderMemory :: Gen HeaderMemory arbitraryHeaderMemory = do - ls <- listOf $ (,) <$> arbitrary <*> arbitraryBSS - HeaderMemory (HashMap.fromList ls) <$> arbitraryBlockNode + ls <- listOf $ (,) <$> arbitrary <*> arbitraryBSS + HeaderMemory (HashMap.fromList ls) <$> arbitraryBlockNode diff --git a/src/Haskoin/Util/Arbitrary/Crypto.hs b/src/Haskoin/Util/Arbitrary/Crypto.hs index ec6cdbe8..91489431 100644 --- a/src/Haskoin/Util/Arbitrary/Crypto.hs +++ b/src/Haskoin/Util/Arbitrary/Crypto.hs @@ -1,11 +1,10 @@ -{- | -Module : Haskoin.Test.Crypto -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Module : Haskoin.Test.Crypto +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Crypto where import Haskoin.Crypto.Hash @@ -15,19 +14,19 @@ import Test.QuickCheck -- | Arbitrary 160-bit hash. arbitraryHash160 :: Gen Hash160 arbitraryHash160 = - ripemd160 <$> arbitraryBSn 20 + ripemd160 <$> arbitraryBSn 20 -- | Arbitrary 256-bit hash. arbitraryHash256 :: Gen Hash256 arbitraryHash256 = - sha256 <$> arbitraryBSn 32 + sha256 <$> arbitraryBSn 32 -- | Arbitrary 512-bit hash. arbitraryHash512 :: Gen Hash512 arbitraryHash512 = - sha512 <$> arbitraryBSn 64 + sha512 <$> arbitraryBSn 64 -- | Arbitrary 32-bit checksum. arbitraryCheckSum32 :: Gen CheckSum32 arbitraryCheckSum32 = - checkSum32 <$> arbitraryBSn 4 + checkSum32 <$> arbitraryBSn 4 diff --git a/src/Haskoin/Util/Arbitrary/Keys.hs b/src/Haskoin/Util/Arbitrary/Keys.hs index 8c43bfc1..78c94126 100644 --- a/src/Haskoin/Util/Arbitrary/Keys.hs +++ b/src/Haskoin/Util/Arbitrary/Keys.hs @@ -1,33 +1,34 @@ -{- | -Module : Haskoin.Test.Keys -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Module : Haskoin.Test.Keys +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Keys where +import Crypto.Secp256k1 import Data.Bits (clearBit) import Data.Coerce (coerce) import Data.List (foldl') import Data.Word (Word32) -import Haskoin.Crypto -import Haskoin.Keys.Common -import Haskoin.Keys.Extended -import Haskoin.Keys.Extended.Internal (Fingerprint (..)) +import Haskoin.Crypto.Hash +import Haskoin.Crypto.Keys.Common +import Haskoin.Crypto.Keys.Extended +import Haskoin.Crypto.Keys.Extended.Internal (Fingerprint (..)) +import Haskoin.Crypto.Signature import Haskoin.Util.Arbitrary.Crypto import Test.QuickCheck -- | Arbitrary private key with arbitrary compressed flag. -arbitrarySecKeyI :: Gen SecKeyI -arbitrarySecKeyI = wrapSecKey <$> arbitrary <*> arbitrary +arbitraryPrivateKey :: Gen PrivateKey +arbitraryPrivateKey = wrapSecKey <$> arbitrary <*> arbitrary -- | Arbitrary keypair, both either compressed or not. -arbitraryKeyPair :: Gen (SecKeyI, PubKeyI) -arbitraryKeyPair = do - k <- arbitrarySecKeyI - return (k, derivePubKeyI k) +arbitraryKeyPair :: Ctx -> Gen (PrivateKey, PublicKey) +arbitraryKeyPair ctx = do + k <- arbitraryPrivateKey + return (k, derivePublicKey ctx k) arbitraryFingerprint :: Gen Fingerprint arbitraryFingerprint = Fingerprint <$> arbitrary @@ -35,15 +36,16 @@ arbitraryFingerprint = Fingerprint <$> arbitrary -- | Arbitrary extended private key. arbitraryXPrvKey :: Gen XPrvKey arbitraryXPrvKey = - XPrvKey <$> arbitrary - <*> arbitraryFingerprint - <*> arbitrary - <*> arbitraryHash256 - <*> arbitrary + XPrvKey + <$> arbitrary + <*> arbitraryFingerprint + <*> arbitrary + <*> arbitraryHash256 + <*> arbitrary -- | Arbitrary extended public key with its corresponding private key. -arbitraryXPubKey :: Gen (XPrvKey, XPubKey) -arbitraryXPubKey = (\k -> (k, deriveXPubKey k)) <$> arbitraryXPrvKey +arbitraryXPubKey :: Ctx -> Gen (XPrvKey, XPubKey) +arbitraryXPubKey ctx = (\k -> (k, deriveXPubKey ctx k)) <$> arbitraryXPrvKey {- Custom derivations -} @@ -54,10 +56,10 @@ genIndex = (`clearBit` 31) <$> arbitrary -- | Arbitrary BIP-32 path index. Can be hardened or not. arbitraryBip32PathIndex :: Gen Bip32PathIndex arbitraryBip32PathIndex = - oneof - [ Bip32SoftIndex <$> genIndex - , Bip32HardIndex <$> genIndex - ] + oneof + [ Bip32SoftIndex <$> genIndex, + Bip32HardIndex <$> genIndex + ] -- | Arbitrary BIP-32 derivation path composed of only hardened derivations. arbitraryHardPath :: Gen HardPath @@ -71,24 +73,22 @@ arbitrarySoftPath = foldl' (:/) Deriv <$> listOf genIndex arbitraryDerivPath :: Gen DerivPath arbitraryDerivPath = concatBip32Segments <$> listOf arbitraryBip32PathIndex -{- | Arbitrary parsed derivation path. Can contain 'ParsedPrv', 'ParsedPub' or - 'ParsedEmpty' elements. --} +-- | Arbitrary parsed derivation path. Can contain 'ParsedPrv', 'ParsedPub' or +-- 'ParsedEmpty' elements. arbitraryParsedPath :: Gen ParsedPath arbitraryParsedPath = - oneof - [ ParsedPrv <$> arbitraryDerivPath - , ParsedPub <$> arbitraryDerivPath - , ParsedEmpty <$> arbitraryDerivPath - ] + oneof + [ ParsedPrv <$> arbitraryDerivPath, + ParsedPub <$> arbitraryDerivPath, + ParsedEmpty <$> arbitraryDerivPath + ] -{- | Arbitrary message hash, private key, nonce and corresponding signature. The - signature is generated with a random message, random private key and a random - nonce. --} -arbitrarySignature :: Gen (Hash256, SecKey, Sig) -arbitrarySignature = do - m <- arbitraryHash256 - key <- arbitrary - let sig = signHash key m - return (m, key, sig) +-- | Arbitrary message hash, private key, nonce and corresponding signature. The +-- signature is generated with a random message, random private key and a random +-- nonce. +arbitrarySignature :: Ctx -> Gen (Hash256, SecKey, Sig) +arbitrarySignature ctx = do + m <- arbitraryHash256 + key <- arbitrary + let sig = signHash ctx key m + return (m, key, sig) diff --git a/src/Haskoin/Util/Arbitrary/Message.hs b/src/Haskoin/Util/Arbitrary/Message.hs index 353ea8d9..1677d376 100644 --- a/src/Haskoin/Util/Arbitrary/Message.hs +++ b/src/Haskoin/Util/Arbitrary/Message.hs @@ -1,14 +1,14 @@ -{- | -Module : Haskoin.Test.Message -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Module : Haskoin.Test.Message +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Message where -import Haskoin.Data +import Haskoin.Crypto (Ctx) +import Haskoin.Network.Data import Haskoin.Network.Message import Haskoin.Util.Arbitrary.Block import Haskoin.Util.Arbitrary.Crypto @@ -19,34 +19,35 @@ import Test.QuickCheck -- | Arbitrary 'MessageHeader'. arbitraryMessageHeader :: Gen MessageHeader arbitraryMessageHeader = - MessageHeader <$> arbitrary - <*> arbitraryMessageCommand - <*> arbitrary - <*> arbitraryCheckSum32 + MessageHeader + <$> arbitrary + <*> arbitraryMessageCommand + <*> arbitrary + <*> arbitraryCheckSum32 -- | Arbitrary 'Message'. -arbitraryMessage :: Network -> Gen Message -arbitraryMessage net = - oneof - [ MVersion <$> arbitraryVersion - , return MVerAck - , MAddr <$> arbitraryAddr1 - , MInv <$> arbitraryInv1 - , MGetData <$> arbitraryGetData - , MNotFound <$> arbitraryNotFound - , MGetBlocks <$> arbitraryGetBlocks - , MGetHeaders <$> arbitraryGetHeaders - , MTx <$> arbitraryTx net - , MBlock <$> arbitraryBlock net - , MMerkleBlock <$> arbitraryMerkleBlock - , MHeaders <$> arbitraryHeaders - , return MGetAddr - , MFilterLoad <$> arbitraryFilterLoad - , MFilterAdd <$> arbitraryFilterAdd - , return MFilterClear - , MPing <$> arbitraryPing - , MPong <$> arbitraryPong - , MAlert <$> arbitraryAlert - , MReject <$> arbitraryReject - , return MSendHeaders - ] +arbitraryMessage :: Network -> Ctx -> Gen Message +arbitraryMessage net ctx = + oneof + [ MVersion <$> arbitraryVersion, + return MVerAck, + MAddr <$> arbitraryAddr1, + MInv <$> arbitraryInv1, + MGetData <$> arbitraryGetData, + MNotFound <$> arbitraryNotFound, + MGetBlocks <$> arbitraryGetBlocks, + MGetHeaders <$> arbitraryGetHeaders, + MTx <$> arbitraryTx net ctx, + MBlock <$> arbitraryBlock net ctx, + MMerkleBlock <$> arbitraryMerkleBlock, + MHeaders <$> arbitraryHeaders, + return MGetAddr, + MFilterLoad <$> arbitraryFilterLoad, + MFilterAdd <$> arbitraryFilterAdd, + return MFilterClear, + MPing <$> arbitraryPing, + MPong <$> arbitraryPong, + MAlert <$> arbitraryAlert, + MReject <$> arbitraryReject, + return MSendHeaders + ] diff --git a/src/Haskoin/Util/Arbitrary/Network.hs b/src/Haskoin/Util/Arbitrary/Network.hs index c8693818..2883f184 100644 --- a/src/Haskoin/Util/Arbitrary/Network.hs +++ b/src/Haskoin/Util/Arbitrary/Network.hs @@ -1,11 +1,10 @@ -{- | -Module : Haskoin.Test.Network -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Module : Haskoin.Test.Network +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Network where import qualified Data.ByteString as BS (empty, pack) @@ -28,20 +27,20 @@ arbitraryVarString = VarString <$> arbitraryBS -- | Arbitrary 'NetworkAddress'. arbitraryNetworkAddress :: Gen NetworkAddress arbitraryNetworkAddress = do - s <- arbitrary - a <- arbitrary - p <- arbitrary - d <- - oneof - [ do - b <- arbitrary - c <- arbitrary - d <- arbitrary - return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 - , return $ SockAddrInet (fromIntegral (p :: Word16)) a - ] - let n = sockToHostAddress d - return $ NetworkAddress s n + s <- arbitrary + a <- arbitrary + p <- arbitrary + d <- + oneof + [ do + b <- arbitrary + c <- arbitrary + d <- arbitrary + return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0, + return $ SockAddrInet (fromIntegral (p :: Word16)) a + ] + let n = sockToHostAddress d + return $ NetworkAddress s n -- | Arbitrary 'NetworkAddressTime'. arbitraryNetworkAddressTime :: Gen (Word32, NetworkAddress) @@ -62,52 +61,52 @@ arbitraryInv1 = Inv <$> listOf1 arbitraryInvVector -- | Arbitrary 'Version'. arbitraryVersion :: Gen Version arbitraryVersion = - Version <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryNetworkAddress - <*> arbitraryNetworkAddress - <*> arbitrary - <*> arbitraryVarString - <*> arbitrary - <*> arbitrary + Version + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryNetworkAddress + <*> arbitraryNetworkAddress + <*> arbitrary + <*> arbitraryVarString + <*> arbitrary + <*> arbitrary -- | Arbitrary non-empty 'Addr'. arbitraryAddr1 :: Gen Addr arbitraryAddr1 = Addr <$> listOf1 arbitraryNetworkAddressTime -{- | Arbitrary 'Alert' with random payload and signature. Signature is not - valid. --} +-- | Arbitrary 'Alert' with random payload and signature. Signature is not +-- valid. arbitraryAlert :: Gen Alert arbitraryAlert = Alert <$> arbitraryVarString <*> arbitraryVarString -- | Arbitrary 'Reject'. arbitraryReject :: Gen Reject arbitraryReject = do - m <- arbitraryMessageCommand - c <- arbitraryRejectCode - s <- arbitraryVarString - d <- - oneof - [ return BS.empty - , BS.pack <$> vectorOf 32 arbitrary - ] - return $ Reject m c s d + m <- arbitraryMessageCommand + c <- arbitraryRejectCode + s <- arbitraryVarString + d <- + oneof + [ return BS.empty, + BS.pack <$> vectorOf 32 arbitrary + ] + return $ Reject m c s d -- | Arbitrary 'RejectCode'. arbitraryRejectCode :: Gen RejectCode arbitraryRejectCode = - elements - [ RejectMalformed - , RejectInvalid - , RejectInvalid - , RejectDuplicate - , RejectNonStandard - , RejectDust - , RejectInsufficientFee - , RejectCheckpoint - ] + elements + [ RejectMalformed, + RejectInvalid, + RejectInvalid, + RejectDuplicate, + RejectNonStandard, + RejectDust, + RejectInsufficientFee, + RejectCheckpoint + ] -- | Arbitrary non-empty 'GetData'. arbitraryGetData :: Gen GetData @@ -128,28 +127,27 @@ arbitraryPong = Pong <$> arbitrary -- | Arbitrary bloom filter flags. arbitraryBloomFlags :: Gen BloomFlags arbitraryBloomFlags = - elements - [ BloomUpdateNone - , BloomUpdateAll - , BloomUpdateP2PubKeyOnly - ] + elements + [ BloomUpdateNone, + BloomUpdateAll, + BloomUpdateP2PubKeyOnly + ] -{- | Arbitrary bloom filter with its corresponding number of elements - and false positive rate. --} +-- | Arbitrary bloom filter with its corresponding number of elements +-- and false positive rate. arbitraryBloomFilter :: Gen (Int, Double, BloomFilter) arbitraryBloomFilter = do - n <- choose (0, 100000) - fp <- choose (1e-8, 1) - tweak <- arbitrary - fl <- arbitraryBloomFlags - return (n, fp, bloomCreate n fp tweak fl) + n <- choose (0, 100000) + fp <- choose (1e-8, 1) + tweak <- arbitrary + fl <- arbitraryBloomFlags + return (n, fp, bloomCreate n fp tweak fl) -- | Arbitrary 'FilterLoad'. arbitraryFilterLoad :: Gen FilterLoad arbitraryFilterLoad = do - (_, _, bf) <- arbitraryBloomFilter - return $ FilterLoad bf + (_, _, bf) <- arbitraryBloomFilter + return $ FilterLoad bf -- | Arbitrary 'FilterAdd'. arbitraryFilterAdd :: Gen FilterAdd @@ -158,26 +156,26 @@ arbitraryFilterAdd = FilterAdd <$> arbitraryBS -- | Arbitrary 'MessageCommand'. arbitraryMessageCommand :: Gen MessageCommand arbitraryMessageCommand = do - ASCIIString str <- arbitrary - elements - [ MCVersion - , MCVerAck - , MCAddr - , MCInv - , MCGetData - , MCNotFound - , MCGetBlocks - , MCGetHeaders - , MCTx - , MCBlock - , MCMerkleBlock - , MCHeaders - , MCGetAddr - , MCFilterLoad - , MCFilterAdd - , MCFilterClear - , MCPing - , MCPong - , MCAlert - , MCOther (C8.take 12 (C8.pack (filter (/= '\NUL') str))) - ] + ASCIIString str <- arbitrary + elements + [ MCVersion, + MCVerAck, + MCAddr, + MCInv, + MCGetData, + MCNotFound, + MCGetBlocks, + MCGetHeaders, + MCTx, + MCBlock, + MCMerkleBlock, + MCHeaders, + MCGetAddr, + MCFilterLoad, + MCFilterAdd, + MCFilterClear, + MCPing, + MCPong, + MCAlert, + MCOther (C8.take 12 (C8.pack (filter (/= '\NUL') str))) + ] diff --git a/src/Haskoin/Util/Arbitrary/Script.hs b/src/Haskoin/Util/Arbitrary/Script.hs index 2899e37f..3df072e0 100644 --- a/src/Haskoin/Util/Arbitrary/Script.hs +++ b/src/Haskoin/Util/Arbitrary/Script.hs @@ -1,23 +1,25 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} -{- | -Module : Haskoin.Test.Script -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Module : Haskoin.Test.Script +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Script where import Crypto.Secp256k1 -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.Maybe import Data.Word import Haskoin.Address -import Haskoin.Constants -import Haskoin.Data -import Haskoin.Keys.Common +import Haskoin.Crypto.Keys.Common +import Haskoin.Network.Constants +import Haskoin.Network.Data import Haskoin.Script import Haskoin.Transaction.Common import Haskoin.Util @@ -34,156 +36,156 @@ arbitraryScript = Script <$> listOf arbitraryScriptOp -- | Arbitrary 'ScriptOp' (push operations have random data). arbitraryScriptOp :: Gen ScriptOp arbitraryScriptOp = - oneof - -- Pushing Data - [ opPushData <$> arbitraryBS1 - , return OP_0 - , return OP_1NEGATE - , return OP_RESERVED - , return OP_1 - , return OP_2 - , return OP_3 - , return OP_4 - , return OP_5 - , return OP_6 - , return OP_7 - , return OP_8 - , return OP_9 - , return OP_10 - , return OP_11 - , return OP_12 - , return OP_13 - , return OP_14 - , return OP_15 - , return OP_16 - , -- Flow control - return OP_NOP - , return OP_VER - , return OP_IF - , return OP_NOTIF - , return OP_VERIF - , return OP_VERNOTIF - , return OP_ELSE - , return OP_ENDIF - , return OP_VERIFY - , return OP_RETURN - , -- Stack operations - return OP_TOALTSTACK - , return OP_FROMALTSTACK - , return OP_IFDUP - , return OP_DEPTH - , return OP_DROP - , return OP_DUP - , return OP_NIP - , return OP_OVER - , return OP_PICK - , return OP_ROLL - , return OP_ROT - , return OP_SWAP - , return OP_TUCK - , return OP_2DROP - , return OP_2DUP - , return OP_3DUP - , return OP_2OVER - , return OP_2ROT - , return OP_2SWAP - , -- Splice - return OP_CAT - , return OP_SUBSTR - , return OP_LEFT - , return OP_RIGHT - , return OP_SIZE - , -- Bitwise logic - return OP_INVERT - , return OP_AND - , return OP_OR - , return OP_XOR - , return OP_EQUAL - , return OP_EQUALVERIFY - , return OP_RESERVED1 - , return OP_RESERVED2 - , -- Arithmetic - return OP_1ADD - , return OP_1SUB - , return OP_2MUL - , return OP_2DIV - , return OP_NEGATE - , return OP_ABS - , return OP_NOT - , return OP_0NOTEQUAL - , return OP_ADD - , return OP_SUB - , return OP_MUL - , return OP_DIV - , return OP_MOD - , return OP_LSHIFT - , return OP_RSHIFT - , return OP_BOOLAND - , return OP_BOOLOR - , return OP_NUMEQUAL - , return OP_NUMEQUALVERIFY - , return OP_NUMNOTEQUAL - , return OP_LESSTHAN - , return OP_GREATERTHAN - , return OP_LESSTHANOREQUAL - , return OP_GREATERTHANOREQUAL - , return OP_MIN - , return OP_MAX - , return OP_WITHIN - , -- Crypto - return OP_RIPEMD160 - , return OP_SHA1 - , return OP_SHA256 - , return OP_HASH160 - , return OP_HASH256 - , return OP_CODESEPARATOR - , return OP_CHECKSIG - , return OP_CHECKSIGVERIFY - , return OP_CHECKMULTISIG - , return OP_CHECKMULTISIGVERIFY - , -- Expansion - return OP_NOP1 - , return OP_CHECKLOCKTIMEVERIFY - , return OP_CHECKSEQUENCEVERIFY - , return OP_NOP4 - , return OP_NOP5 - , return OP_NOP6 - , return OP_NOP7 - , return OP_NOP8 - , return OP_NOP9 - , return OP_NOP10 - , -- Bitcoin Cash Nov 2018 hard fork - return OP_CHECKDATASIG - , return OP_CHECKDATASIGVERIFY - , -- Bitcoin Cash May 2020 hard fork - return OP_REVERSEBYTES - , -- Other - return OP_PUBKEYHASH - , return OP_PUBKEY - , return $ OP_INVALIDOPCODE 0xff - ] + oneof + -- Pushing Data + [ opPushData <$> arbitraryBS1, + return OP_0, + return OP_1NEGATE, + return OP_RESERVED, + return OP_1, + return OP_2, + return OP_3, + return OP_4, + return OP_5, + return OP_6, + return OP_7, + return OP_8, + return OP_9, + return OP_10, + return OP_11, + return OP_12, + return OP_13, + return OP_14, + return OP_15, + return OP_16, + -- Flow control + return OP_NOP, + return OP_VER, + return OP_IF, + return OP_NOTIF, + return OP_VERIF, + return OP_VERNOTIF, + return OP_ELSE, + return OP_ENDIF, + return OP_VERIFY, + return OP_RETURN, + -- Stack operations + return OP_TOALTSTACK, + return OP_FROMALTSTACK, + return OP_IFDUP, + return OP_DEPTH, + return OP_DROP, + return OP_DUP, + return OP_NIP, + return OP_OVER, + return OP_PICK, + return OP_ROLL, + return OP_ROT, + return OP_SWAP, + return OP_TUCK, + return OP_2DROP, + return OP_2DUP, + return OP_3DUP, + return OP_2OVER, + return OP_2ROT, + return OP_2SWAP, + -- Splice + return OP_CAT, + return OP_SUBSTR, + return OP_LEFT, + return OP_RIGHT, + return OP_SIZE, + -- Bitwise logic + return OP_INVERT, + return OP_AND, + return OP_OR, + return OP_XOR, + return OP_EQUAL, + return OP_EQUALVERIFY, + return OP_RESERVED1, + return OP_RESERVED2, + -- Arithmetic + return OP_1ADD, + return OP_1SUB, + return OP_2MUL, + return OP_2DIV, + return OP_NEGATE, + return OP_ABS, + return OP_NOT, + return OP_0NOTEQUAL, + return OP_ADD, + return OP_SUB, + return OP_MUL, + return OP_DIV, + return OP_MOD, + return OP_LSHIFT, + return OP_RSHIFT, + return OP_BOOLAND, + return OP_BOOLOR, + return OP_NUMEQUAL, + return OP_NUMEQUALVERIFY, + return OP_NUMNOTEQUAL, + return OP_LESSTHAN, + return OP_GREATERTHAN, + return OP_LESSTHANOREQUAL, + return OP_GREATERTHANOREQUAL, + return OP_MIN, + return OP_MAX, + return OP_WITHIN, + -- Crypto + return OP_RIPEMD160, + return OP_SHA1, + return OP_SHA256, + return OP_HASH160, + return OP_HASH256, + return OP_CODESEPARATOR, + return OP_CHECKSIG, + return OP_CHECKSIGVERIFY, + return OP_CHECKMULTISIG, + return OP_CHECKMULTISIGVERIFY, + -- Expansion + return OP_NOP1, + return OP_CHECKLOCKTIMEVERIFY, + return OP_CHECKSEQUENCEVERIFY, + return OP_NOP4, + return OP_NOP5, + return OP_NOP6, + return OP_NOP7, + return OP_NOP8, + return OP_NOP9, + return OP_NOP10, + -- Bitcoin Cash Nov 2018 hard fork + return OP_CHECKDATASIG, + return OP_CHECKDATASIGVERIFY, + -- Bitcoin Cash May 2020 hard fork + return OP_REVERSEBYTES, + -- Other + return OP_PUBKEYHASH, + return OP_PUBKEY, + return $ OP_INVALIDOPCODE 0xff + ] -- | Arbtirary 'ScriptOp' with a value in @[OP_1 .. OP_16]@. arbitraryIntScriptOp :: Gen ScriptOp arbitraryIntScriptOp = - elements - [ OP_1 - , OP_2 - , OP_3 - , OP_4 - , OP_5 - , OP_6 - , OP_7 - , OP_8 - , OP_9 - , OP_10 - , OP_11 - , OP_12 - , OP_13 - , OP_14 - , OP_15 - , OP_16 - ] + elements + [ OP_1, + OP_2, + OP_3, + OP_4, + OP_5, + OP_6, + OP_7, + OP_8, + OP_9, + OP_10, + OP_11, + OP_12, + OP_13, + OP_14, + OP_15, + OP_16 + ] -- | Arbitrary 'PushDataType'. arbitraryPushDataType :: Gen PushDataType @@ -196,88 +198,86 @@ arbitrarySigHash = fromIntegral <$> (arbitrary :: Gen Word32) -- | Arbitrary valid 'SigHash'. arbitraryValidSigHash :: Network -> Gen SigHash arbitraryValidSigHash net = do - sh <- elements [sigHashAll, sigHashNone, sigHashSingle] - f1 <- - elements $ - if isJust (getSigHashForkId net) - then [id, setForkIdFlag] - else [id] - f2 <- elements [id, setAnyoneCanPayFlag] - return $ f1 $ f2 sh + sh <- elements [sigHashAll, sigHashNone, sigHashSingle] + f1 <- + elements $ + if isJust net.sigHashForkId + then [id, setForkIdFlag] + else [id] + f2 <- elements [id, setAnyoneCanPay] + return $ f1 $ f2 sh arbitrarySigHashFlag :: Gen SigHashFlag arbitrarySigHashFlag = - elements - [ SIGHASH_ALL - , SIGHASH_NONE - , SIGHASH_SINGLE - , SIGHASH_FORKID - , SIGHASH_ANYONECANPAY - ] + elements + [ SIGHASH_ALL, + SIGHASH_NONE, + SIGHASH_SINGLE, + SIGHASH_FORKID, + SIGHASH_ANYONECANPAY + ] -{- | Arbitrary message hash, private key and corresponding 'TxSignature'. The - signature is generated deterministically using a random message and a random - private key. --} -arbitraryTxSignature :: Network -> Gen (TxHash, SecKey, TxSignature) -arbitraryTxSignature net = do - (m, key, sig) <- arbitrarySignature - sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad - let txsig = TxSignature sig sh - return (TxHash m, key, txsig) +-- | Arbitrary message hash, private key and corresponding 'TxSignature'. The +-- signature is generated deterministically using a random message and a random +-- private key. +arbitraryTxSignature :: Network -> Ctx -> Gen (TxHash, SecKey, TxSignature) +arbitraryTxSignature net ctx = do + (m, key, sig) <- arbitrarySignature ctx + sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad + let txsig = TxSignature sig sh + return (TxHash m, key, txsig) where filterBad sh = - not $ - isSigHashUnknown sh - || isNothing (getSigHashForkId net) && hasForkIdFlag sh + not $ + isSigHashUnknown sh + || isNothing net.sigHashForkId && hasForkIdFlag sh -- | Arbitrary transaction signature that could also be empty. -arbitraryTxSignatureEmpty :: Network -> Gen TxSignature -arbitraryTxSignatureEmpty net = - frequency - [ (1, return TxSignatureEmpty) - , (10, lst3 <$> arbitraryTxSignature net) - ] +arbitraryTxSignatureEmpty :: Network -> Ctx -> Gen TxSignature +arbitraryTxSignatureEmpty net ctx = + frequency + [ (1, return TxSignatureEmpty), + (10, lst3 <$> arbitraryTxSignature net ctx) + ] -- | Arbitrary m of n parameters. arbitraryMSParam :: Gen (Int, Int) arbitraryMSParam = do - m <- choose (1, 16) - n <- choose (m, 16) - return (m, n) + m <- choose (1, 16) + n <- choose (m, 16) + return (m, n) -- | Arbitrary 'ScriptOutput' (Can by any valid type). -arbitraryScriptOutput :: Network -> Gen ScriptOutput -arbitraryScriptOutput net = - oneof $ - [ arbitraryPKOutput - , arbitraryPKHashOutput - , arbitraryMSOutput - , arbitrarySHOutput - , arbitraryDCOutput - ] - ++ if getSegWit net - then - [ arbitraryWPKHashOutput - , arbitraryWSHOutput - , arbitraryWitOutput - ] - else [] +arbitraryScriptOutput :: Network -> Ctx -> Gen ScriptOutput +arbitraryScriptOutput net ctx = + oneof $ + [ arbitraryPKOutput ctx, + arbitraryPKHashOutput, + arbitraryMSOutput ctx, + arbitrarySHOutput, + arbitraryDCOutput + ] + ++ if net.segWit + then + [ arbitraryWPKHashOutput, + arbitraryWSHOutput, + arbitraryWitOutput + ] + else [] -{- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS' - (Not 'PayScriptHash', 'DataCarrier', or SegWit) --} -arbitrarySimpleOutput :: Gen ScriptOutput -arbitrarySimpleOutput = - oneof - [ arbitraryPKOutput - , arbitraryPKHashOutput - , arbitraryMSOutput - ] +-- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS' +-- (Not 'PayScriptHash', 'DataCarrier', or SegWit) +arbitrarySimpleOutput :: Ctx -> Gen ScriptOutput +arbitrarySimpleOutput ctx = + oneof + [ arbitraryPKOutput ctx, + arbitraryPKHashOutput, + arbitraryMSOutput ctx + ] -- | Arbitrary 'ScriptOutput' of type 'PayPK' -arbitraryPKOutput :: Gen ScriptOutput -arbitraryPKOutput = PayPK . snd <$> arbitraryKeyPair +arbitraryPKOutput :: Ctx -> Gen ScriptOutput +arbitraryPKOutput ctx = PayPK . snd <$> arbitraryKeyPair ctx -- | Arbitrary 'ScriptOutput' of type 'PayPKHash' arbitraryPKHashOutput :: Gen ScriptOutput @@ -293,131 +293,128 @@ arbitraryWSHOutput = PayWitnessScriptHash <$> arbitraryHash256 arbitraryWitOutput :: Gen ScriptOutput arbitraryWitOutput = do - ver <- choose (1, 16) - len <- choose (2, 40) - ws <- vectorOf len arbitrary - let bs = B.pack ws - return $ PayWitness ver bs + ver <- choose (1, 16) + len <- choose (2, 40) + ws <- vectorOf len arbitrary + let bs = B.pack ws + return $ PayWitness ver bs -- | Arbitrary 'ScriptOutput' of type 'PayMS'. -arbitraryMSOutput :: Gen ScriptOutput -arbitraryMSOutput = do - (m, n) <- arbitraryMSParam - keys <- map snd <$> vectorOf n arbitraryKeyPair - return $ PayMulSig keys m +arbitraryMSOutput :: Ctx -> Gen ScriptOutput +arbitraryMSOutput ctx = do + (m, n) <- arbitraryMSParam + keys <- map snd <$> vectorOf n (arbitraryKeyPair ctx) + return $ PayMulSig keys m -- | Arbitrary 'ScriptOutput' of type 'PayMS', only using compressed keys. -arbitraryMSOutputC :: Gen ScriptOutput -arbitraryMSOutputC = do - (m, n) <- arbitraryMSParam - keys <- - map snd - <$> vectorOf n (arbitraryKeyPair `suchThat` (pubKeyCompressed . snd)) - return $ PayMulSig keys m +arbitraryMSOutputC :: Ctx -> Gen ScriptOutput +arbitraryMSOutputC ctx = do + (m, n) <- arbitraryMSParam + keys <- + map snd + <$> vectorOf n (arbitraryKeyPair ctx `suchThat` ((.compress) . snd)) + return $ PayMulSig keys m -- | Arbitrary 'ScriptOutput' of type 'PayScriptHash'. arbitrarySHOutput :: Gen ScriptOutput -arbitrarySHOutput = PayScriptHash . getAddrHash160 <$> arbitraryScriptAddress +arbitrarySHOutput = PayScriptHash . (.hash160) <$> arbitraryScriptAddress -- | Arbitrary 'ScriptOutput' of type 'DataCarrier'. arbitraryDCOutput :: Gen ScriptOutput arbitraryDCOutput = DataCarrier <$> arbitraryBS1 -- | Arbitrary 'ScriptInput'. -arbitraryScriptInput :: Network -> Gen ScriptInput -arbitraryScriptInput net = - oneof - [ arbitraryPKInput net - , arbitraryPKHashInput net - , arbitraryMSInput net - , arbitrarySHInput net - ] +arbitraryScriptInput :: Network -> Ctx -> Gen ScriptInput +arbitraryScriptInput net ctx = + oneof + [ arbitraryPKInput net ctx, + arbitraryPKHashInput net ctx, + arbitraryMSInput net ctx, + arbitrarySHInput net ctx + ] -{- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig' - (not 'ScriptHashInput') --} -arbitrarySimpleInput :: Network -> Gen ScriptInput -arbitrarySimpleInput net = - oneof - [ arbitraryPKInput net - , arbitraryPKHashInput net - , arbitraryMSInput net - ] +-- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig' +-- (not 'ScriptHashInput') +arbitrarySimpleInput :: Network -> Ctx -> Gen ScriptInput +arbitrarySimpleInput net ctx = + oneof + [ arbitraryPKInput net ctx, + arbitraryPKHashInput net ctx, + arbitraryMSInput net ctx + ] -- | Arbitrary 'ScriptInput' of type 'SpendPK'. -arbitraryPKInput :: Network -> Gen ScriptInput -arbitraryPKInput net = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net +arbitraryPKInput :: Network -> Ctx -> Gen ScriptInput +arbitraryPKInput net ctx = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net ctx -- | Arbitrary 'ScriptInput' of type 'SpendPK'. -arbitraryPKHashInput :: Network -> Gen ScriptInput -arbitraryPKHashInput net = do - sig <- arbitraryTxSignatureEmpty net - key <- snd <$> arbitraryKeyPair - return $ RegularInput $ SpendPKHash sig key +arbitraryPKHashInput :: Network -> Ctx -> Gen ScriptInput +arbitraryPKHashInput net ctx = do + sig <- arbitraryTxSignatureEmpty net ctx + key <- snd <$> arbitraryKeyPair ctx + return $ RegularInput $ SpendPKHash sig key -- | Like 'arbitraryPKHashInput' without empty signatures. -arbitraryPKHashInputFull :: Network -> Gen ScriptInput -arbitraryPKHashInputFull net = do - sig <- lst3 <$> arbitraryTxSignature net - key <- snd <$> arbitraryKeyPair - return $ RegularInput $ SpendPKHash sig key +arbitraryPKHashInputFull :: Network -> Ctx -> Gen ScriptInput +arbitraryPKHashInputFull net ctx = do + sig <- lst3 <$> arbitraryTxSignature net ctx + key <- snd <$> arbitraryKeyPair ctx + return $ RegularInput $ SpendPKHash sig key -- | Like above but only compressed. -arbitraryPKHashInputFullC :: Network -> Gen ScriptInput -arbitraryPKHashInputFullC net = do - sig <- lst3 <$> arbitraryTxSignature net - key <- fmap snd $ arbitraryKeyPair `suchThat` (pubKeyCompressed . snd) - return $ RegularInput $ SpendPKHash sig key +arbitraryPKHashInputFullC :: Network -> Ctx -> Gen ScriptInput +arbitraryPKHashInputFullC net ctx = do + sig <- lst3 <$> arbitraryTxSignature net ctx + key <- fmap snd $ arbitraryKeyPair ctx `suchThat` ((.compress) . snd) + return $ RegularInput $ SpendPKHash sig key -- | Arbitrary 'ScriptInput' of type 'SpendMulSig'. -arbitraryMSInput :: Network -> Gen ScriptInput -arbitraryMSInput net = do - m <- fst <$> arbitraryMSParam - sigs <- vectorOf m (arbitraryTxSignatureEmpty net) - return $ RegularInput $ SpendMulSig sigs +arbitraryMSInput :: Network -> Ctx -> Gen ScriptInput +arbitraryMSInput net ctx = do + m <- fst <$> arbitraryMSParam + sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx) + return $ RegularInput $ SpendMulSig sigs -- | Arbitrary 'ScriptInput' of type 'ScriptHashInput'. -arbitrarySHInput :: Network -> Gen ScriptInput -arbitrarySHInput net = do - i <- arbitrarySimpleInput net - ScriptHashInput (getRegularInput i) <$> arbitrarySimpleOutput +arbitrarySHInput :: Network -> Ctx -> Gen ScriptInput +arbitrarySHInput net ctx = do + i <- arbitrarySimpleInput net ctx + ScriptHashInput i.get <$> arbitrarySimpleOutput ctx -{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a - 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'. --} -arbitraryMulSigSHInput :: Network -> Gen ScriptInput -arbitraryMulSigSHInput net = - arbitraryMSOutput >>= \case - rdm@(PayMulSig _ m) -> do - sigs <- vectorOf m (arbitraryTxSignatureEmpty net) - return $ ScriptHashInput (SpendMulSig sigs) rdm - _ -> undefined +-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a +-- 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'. +arbitraryMulSigSHInput :: Network -> Ctx -> Gen ScriptInput +arbitraryMulSigSHInput net ctx = + arbitraryMSOutput ctx >>= \case + rdm@(PayMulSig _ m) -> do + sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx) + return $ ScriptHashInput (SpendMulSig sigs) rdm + _ -> undefined -{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a - 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'. --} -arbitraryMulSigSHInputC :: Network -> Gen ScriptInput -arbitraryMulSigSHInputC net = - arbitraryMSOutputC >>= \case - rdm@(PayMulSig _ m) -> do - sigs <- vectorOf m (arbitraryTxSignatureEmpty net) - return $ ScriptHashInput (SpendMulSig sigs) rdm - _ -> undefined +-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a +-- 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'. +arbitraryMulSigSHInputC :: Network -> Ctx -> Gen ScriptInput +arbitraryMulSigSHInputC net ctx = + arbitraryMSOutputC ctx >>= \case + rdm@(PayMulSig _ m) -> do + sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx) + return $ ScriptHashInput (SpendMulSig sigs) rdm + _ -> undefined -- | Like 'arbitraryMulSigSHCInput' with no empty signatures. -arbitraryMulSigSHInputFull :: Network -> Gen ScriptInput -arbitraryMulSigSHInputFull net = - arbitraryMSOutput >>= \case - rdm@(PayMulSig _ m) -> do - sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net) - return $ ScriptHashInput (SpendMulSig sigs) rdm - _ -> undefined +arbitraryMulSigSHInputFull :: Network -> Ctx -> Gen ScriptInput +arbitraryMulSigSHInputFull net ctx = + arbitraryMSOutput ctx >>= \case + rdm@(PayMulSig _ m) -> do + sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net ctx) + return $ ScriptHashInput (SpendMulSig sigs) rdm + _ -> undefined -- | Like 'arbitraryMulSigSHCInput' with no empty signatures. -arbitraryMulSigSHInputFullC :: Network -> Gen ScriptInput -arbitraryMulSigSHInputFullC net = - arbitraryMSOutputC >>= \case - rdm@(PayMulSig _ m) -> do - sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net) - return $ ScriptHashInput (SpendMulSig sigs) rdm - _ -> undefined +arbitraryMulSigSHInputFullC :: Network -> Ctx -> Gen ScriptInput +arbitraryMulSigSHInputFullC net ctx = + arbitraryMSOutputC ctx >>= \case + rdm@(PayMulSig _ m) -> do + sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net ctx) + return $ ScriptHashInput (SpendMulSig sigs) rdm + _ -> undefined diff --git a/src/Haskoin/Util/Arbitrary/Transaction.hs b/src/Haskoin/Util/Arbitrary/Transaction.hs index a6d6e296..ff65c8a1 100644 --- a/src/Haskoin/Util/Arbitrary/Transaction.hs +++ b/src/Haskoin/Util/Arbitrary/Transaction.hs @@ -1,24 +1,29 @@ -{- | -Module : Haskoin.Test.Transaction -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- | +-- Module : Haskoin.Test.Transaction +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Transaction where import Control.Monad -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Either (fromRight) import Data.List (nub, nubBy, permutations) import Data.Word (Word64) import Haskoin.Address -import Haskoin.Constants -import Haskoin.Data -import Haskoin.Keys.Common +import Haskoin.Crypto (Ctx) +import Haskoin.Crypto.Keys.Common +import Haskoin.Network.Constants +import Haskoin.Network.Data import Haskoin.Script import Haskoin.Transaction +import Haskoin.Util import Haskoin.Util.Arbitrary.Crypto import Haskoin.Util.Arbitrary.Keys import Haskoin.Util.Arbitrary.Script @@ -27,10 +32,10 @@ import Test.QuickCheck -- | Wrapped coin value for testing. newtype TestCoin = TestCoin {getTestCoin :: Word64} - deriving (Eq, Show) + deriving (Eq, Show) instance Coin TestCoin where - coinValue = getTestCoin + coinValue = getTestCoin -- | Arbitrary transaction hash (for non-existent transaction). arbitraryTxHash :: Gen TxHash @@ -38,244 +43,241 @@ arbitraryTxHash = TxHash <$> arbitraryHash256 -- | Arbitrary amount of Satoshi as 'Word64' (Between 1 and 21e14) arbitrarySatoshi :: Network -> Gen TestCoin -arbitrarySatoshi net = TestCoin <$> choose (1, getMaxSatoshi net) +arbitrarySatoshi net = TestCoin <$> choose (1, net.maxSatoshi) -- | Arbitrary 'OutPoint'. arbitraryOutPoint :: Gen OutPoint arbitraryOutPoint = OutPoint <$> arbitraryTxHash <*> arbitrary -- | Arbitrary 'TxOut'. -arbitraryTxOut :: Network -> Gen TxOut -arbitraryTxOut net = - TxOut <$> (getTestCoin <$> arbitrarySatoshi net) - <*> (encodeOutputBS <$> arbitraryScriptOutput net) +arbitraryTxOut :: Network -> Ctx -> Gen TxOut +arbitraryTxOut net ctx = + TxOut + <$> (getTestCoin <$> arbitrarySatoshi net) + <*> (marshal ctx <$> arbitraryScriptOutput net ctx) -- | Arbitrary 'TxIn'. -arbitraryTxIn :: Network -> Gen TxIn -arbitraryTxIn net = - TxIn <$> arbitraryOutPoint - <*> (encodeInputBS <$> arbitraryScriptInput net) - <*> arbitrary +arbitraryTxIn :: Network -> Ctx -> Gen TxIn +arbitraryTxIn net ctx = + TxIn + <$> arbitraryOutPoint + <*> (marshal (net, ctx) <$> arbitraryScriptInput net ctx) + <*> arbitrary -- | Arbitrary transaction. Can be regular or with witnesses. -arbitraryTx :: Network -> Gen Tx -arbitraryTx net = oneof [arbitraryLegacyTx net, arbitraryWitnessTx net] +arbitraryTx :: Network -> Ctx -> Gen Tx +arbitraryTx net ctx = + oneof [arbitraryLegacyTx net ctx, arbitraryWitnessTx net ctx] -- | Arbitrary regular transaction. -arbitraryLegacyTx :: Network -> Gen Tx -arbitraryLegacyTx net = arbitraryWLTx net False +arbitraryLegacyTx :: Network -> Ctx -> Gen Tx +arbitraryLegacyTx net ctx = arbitraryWLTx net ctx False -- | Arbitrary witness transaction (witness data is fake). -arbitraryWitnessTx :: Network -> Gen Tx -arbitraryWitnessTx net = arbitraryWLTx net True +arbitraryWitnessTx :: Network -> Ctx -> Gen Tx +arbitraryWitnessTx net ctx = arbitraryWLTx net ctx True -- | Arbitrary witness or legacy transaction. -arbitraryWLTx :: Network -> Bool -> Gen Tx -arbitraryWLTx net wit = do - ni <- choose (1, 5) - no <- choose (1, 5) - inps <- vectorOf ni (arbitraryTxIn net) - outs <- vectorOf no (arbitraryTxOut net) - let uniqueInps = nubBy (\a b -> prevOutput a == prevOutput b) inps - w <- - if wit - then vectorOf (length uniqueInps) (listOf arbitraryBS) - else return [] - Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary +arbitraryWLTx :: Network -> Ctx -> Bool -> Gen Tx +arbitraryWLTx net ctx wit = do + ni <- choose (1, 5) + no <- choose (1, 5) + inps <- vectorOf ni (arbitraryTxIn net ctx) + outs <- vectorOf no (arbitraryTxOut net ctx) + let uniqueInps = nubBy (\a b -> a.outpoint == b.outpoint) inps + w <- + if wit + then vectorOf (length uniqueInps) (listOf arbitraryBS) + else return [] + Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary -{- | Arbitrary transaction containing only inputs of type 'SpendPKHash', - 'SpendScriptHash' (multisig) and outputs of type 'PayPKHash' and 'PaySH'. - Only compressed public keys are used. --} -arbitraryAddrOnlyTx :: Network -> Gen Tx -arbitraryAddrOnlyTx net = do - ni <- choose (1, 5) - no <- choose (1, 5) - inps <- vectorOf ni (arbitraryAddrOnlyTxIn net) - outs <- vectorOf no (arbitraryAddrOnlyTxOut net) - Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary +-- | Arbitrary transaction containing only inputs of type 'SpendPKHash', +-- 'SpendScriptHash' (multisig) and outputs of type 'PayPKHash' and 'PaySH'. +-- Only compressed public keys are used. +arbitraryAddrOnlyTx :: Network -> Ctx -> Gen Tx +arbitraryAddrOnlyTx net ctx = do + ni <- choose (1, 5) + no <- choose (1, 5) + inps <- vectorOf ni (arbitraryAddrOnlyTxIn net ctx) + outs <- vectorOf no (arbitraryAddrOnlyTxOut net ctx) + Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary -- | Like 'arbitraryAddrOnlyTx' without empty signatures in the inputs. -arbitraryAddrOnlyTxFull :: Network -> Gen Tx -arbitraryAddrOnlyTxFull net = do - ni <- choose (1, 5) - no <- choose (1, 5) - inps <- vectorOf ni (arbitraryAddrOnlyTxInFull net) - outs <- vectorOf no (arbitraryAddrOnlyTxOut net) - Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary +arbitraryAddrOnlyTxFull :: Network -> Ctx -> Gen Tx +arbitraryAddrOnlyTxFull net ctx = do + ni <- choose (1, 5) + no <- choose (1, 5) + inps <- vectorOf ni (arbitraryAddrOnlyTxInFull net ctx) + outs <- vectorOf no (arbitraryAddrOnlyTxOut net ctx) + Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary -{- | Arbitrary TxIn that can only be of type 'SpendPKHash' or 'SpendScriptHash' - (multisig). Only compressed public keys are used. --} -arbitraryAddrOnlyTxIn :: Network -> Gen TxIn -arbitraryAddrOnlyTxIn net = do - inp <- oneof [arbitraryPKHashInput net, arbitraryMulSigSHInput net] - TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary +-- | Arbitrary TxIn that can only be of type 'SpendPKHash' or 'SpendScriptHash' +-- (multisig). Only compressed public keys are used. +arbitraryAddrOnlyTxIn :: Network -> Ctx -> Gen TxIn +arbitraryAddrOnlyTxIn net ctx = do + inp <- oneof [arbitraryPKHashInput net ctx, arbitraryMulSigSHInput net ctx] + TxIn <$> arbitraryOutPoint <*> pure (marshal (net, ctx) inp) <*> arbitrary -- | like 'arbitraryAddrOnlyTxIn' with no empty signatures. -arbitraryAddrOnlyTxInFull :: Network -> Gen TxIn -arbitraryAddrOnlyTxInFull net = do - inp <- - oneof [arbitraryPKHashInputFullC net, arbitraryMulSigSHInputFullC net] - TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary +arbitraryAddrOnlyTxInFull :: Network -> Ctx -> Gen TxIn +arbitraryAddrOnlyTxInFull net ctx = do + inp <- + oneof [arbitraryPKHashInputFullC net ctx, arbitraryMulSigSHInputFullC net ctx] + TxIn <$> arbitraryOutPoint <*> pure (marshal (net, ctx) inp) <*> arbitrary -- | Arbitrary 'TxOut' that can only be of type 'PayPKHash' or 'PaySH'. -arbitraryAddrOnlyTxOut :: Network -> Gen TxOut -arbitraryAddrOnlyTxOut net = do - v <- getTestCoin <$> arbitrarySatoshi net - out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput] - return $ TxOut v $ encodeOutputBS out +arbitraryAddrOnlyTxOut :: Network -> Ctx -> Gen TxOut +arbitraryAddrOnlyTxOut net ctx = do + v <- getTestCoin <$> arbitrarySatoshi net + out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput] + return $ TxOut v $ marshal ctx out -{- | Arbitrary 'SigInput' with the corresponding private keys used - to generate the 'ScriptOutput' or 'RedeemScript'. --} -arbitrarySigInput :: Network -> Gen (SigInput, [SecKeyI]) -arbitrarySigInput net = - oneof - [ wrapKey <$> arbitraryPKSigInput net - , wrapKey <$> arbitraryPKHashSigInput net - , arbitraryMSSigInput net - , arbitrarySHSigInput net - , wrapKey <$> arbitraryWPKHSigInput net - , arbitraryWSHSigInput net - ] +-- | Arbitrary 'SigInput' with the corresponding private keys used +-- to generate the 'ScriptOutput' or 'RedeemScript'. +arbitrarySigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey]) +arbitrarySigInput net ctx = + oneof + [ wrapKey <$> arbitraryPKSigInput net ctx, + wrapKey <$> arbitraryPKHashSigInput net ctx, + arbitraryMSSigInput net ctx, + arbitrarySHSigInput net ctx, + wrapKey <$> arbitraryWPKHSigInput net ctx, + arbitraryWSHSigInput net ctx + ] -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPK'. -arbitraryPKSigInput :: Network -> Gen (SigInput, SecKeyI) -arbitraryPKSigInput net = arbitraryAnyInput net False +arbitraryPKSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey) +arbitraryPKSigInput net ctx = arbitraryAnyInput net ctx False -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPKHash'. -arbitraryPKHashSigInput :: Network -> Gen (SigInput, SecKeyI) -arbitraryPKHashSigInput net = arbitraryAnyInput net True +arbitraryPKHashSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey) +arbitraryPKHashSigInput net ctx = arbitraryAnyInput net ctx True -- | Arbitrary 'SigInput'. -arbitraryAnyInput :: Network -> Bool -> Gen (SigInput, SecKeyI) -arbitraryAnyInput net pkh = do - (k, p) <- arbitraryKeyPair - let out - | pkh = PayPKHash $ getAddrHash160 $ pubKeyAddr p - | otherwise = PayPK p - (val, op, sh) <- arbitraryInputStuff net - return (SigInput out val op sh Nothing, k) +arbitraryAnyInput :: Network -> Ctx -> Bool -> Gen (SigInput, PrivateKey) +arbitraryAnyInput net ctx pkh = do + (k, p) <- arbitraryKeyPair ctx + let out + | pkh = PayPKHash (pubKeyAddr ctx p).hash160 + | otherwise = PayPK p + (val, op, sh) <- arbitraryInputStuff net + return (SigInput out val op sh Nothing, k) -- | Arbitrary value, out point and sighash for an input. arbitraryInputStuff :: Network -> Gen (Word64, OutPoint, SigHash) arbitraryInputStuff net = do - val <- getTestCoin <$> arbitrarySatoshi net - op <- arbitraryOutPoint - sh <- arbitraryValidSigHash net - return (val, op, sh) + val <- getTestCoin <$> arbitrarySatoshi net + op <- arbitraryOutPoint + sh <- arbitraryValidSigHash net + return (val, op, sh) -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayMulSig'. -arbitraryMSSigInput :: Network -> Gen (SigInput, [SecKeyI]) -arbitraryMSSigInput net = do - (m, n) <- arbitraryMSParam - ks <- vectorOf n arbitraryKeyPair - let out = PayMulSig (map snd ks) m - (val, op, sh) <- arbitraryInputStuff net - perm <- choose (0, n - 1) - let ksPerm = map fst $ take m $ permutations ks !! perm - return (SigInput out val op sh Nothing, ksPerm) +arbitraryMSSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey]) +arbitraryMSSigInput net ctx = do + (m, n) <- arbitraryMSParam + ks <- vectorOf n (arbitraryKeyPair ctx) + let out = PayMulSig (map snd ks) m + (val, op, sh) <- arbitraryInputStuff net + perm <- choose (0, n - 1) + let ksPerm = map fst $ take m $ permutations ks !! perm + return (SigInput out val op sh Nothing, ksPerm) -{- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a - 'RedeemScript'. --} -arbitrarySHSigInput :: Network -> Gen (SigInput, [SecKeyI]) -arbitrarySHSigInput net = do - (SigInput rdm val op sh _, ks) <- - oneof - [ wrapKey <$> arbitraryPKSigInput net - , wrapKey <$> arbitraryPKHashSigInput net - , arbitraryMSSigInput net - ] - let out = PayScriptHash $ getAddrHash160 $ payToScriptAddress rdm - return (SigInput out val op sh $ Just rdm, ks) +-- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a +-- 'RedeemScript'. +arbitrarySHSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey]) +arbitrarySHSigInput net ctx = do + (SigInput rdm val op sh _, ks) <- + oneof + [ wrapKey <$> arbitraryPKSigInput net ctx, + wrapKey <$> arbitraryPKHashSigInput net ctx, + arbitraryMSSigInput net ctx + ] + let out = PayScriptHash (payToScriptAddress ctx rdm).hash160 + return (SigInput out val op sh $ Just rdm, ks) -arbitraryWPKHSigInput :: Network -> Gen (SigInput, SecKeyI) -arbitraryWPKHSigInput net = do - (k, p) <- arbitraryKeyPair - (val, op, sh) <- arbitraryInputStuff net - let out = PayWitnessPKHash . getAddrHash160 $ pubKeyAddr p - return (SigInput out val op sh Nothing, k) +arbitraryWPKHSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey) +arbitraryWPKHSigInput net ctx = do + (k, p) <- arbitraryKeyPair ctx + (val, op, sh) <- arbitraryInputStuff net + let out = PayWitnessPKHash (pubKeyAddr ctx p).hash160 + return (SigInput out val op sh Nothing, k) -arbitraryWSHSigInput :: Network -> Gen (SigInput, [SecKeyI]) -arbitraryWSHSigInput net = do - (SigInput rdm val op sh _, ks) <- - oneof - [ wrapKey <$> arbitraryPKSigInput net - , wrapKey <$> arbitraryPKHashSigInput net - , arbitraryMSSigInput net - ] - let out = PayWitnessScriptHash . getAddrHash256 $ payToWitnessScriptAddress rdm - return (SigInput out val op sh $ Just rdm, ks) +arbitraryWSHSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey]) +arbitraryWSHSigInput net ctx = do + (SigInput rdm val op sh _, ks) <- + oneof + [ wrapKey <$> arbitraryPKSigInput net ctx, + wrapKey <$> arbitraryPKHashSigInput net ctx, + arbitraryMSSigInput net ctx + ] + let out = PayWitnessScriptHash (payToWitnessScriptAddress ctx rdm).hash256 + return (SigInput out val op sh $ Just rdm, ks) -{- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be - passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'. --} -arbitrarySigningData :: Network -> Gen (Tx, [SigInput], [SecKeyI]) -arbitrarySigningData net = do - v <- arbitrary - ni <- choose (1, 5) - no <- choose (1, 5) - sigis <- vectorOf ni (arbitrarySigInput net) - let uSigis = nubBy (\(a, _) (b, _) -> sigInputOP a == sigInputOP b) sigis - inps <- forM uSigis $ \(s, _) -> TxIn (sigInputOP s) BS.empty <$> arbitrary - outs <- vectorOf no (arbitraryTxOut net) - l <- arbitrary - perm <- choose (0, length inps - 1) - let tx = Tx v (permutations inps !! perm) outs [] l - keys = concatMap snd uSigis - return (tx, map fst uSigis, keys) +-- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be +-- passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'. +arbitrarySigningData :: Network -> Ctx -> Gen (Tx, [SigInput], [PrivateKey]) +arbitrarySigningData net ctx = do + v <- arbitrary + ni <- choose (1, 5) + no <- choose (1, 5) + sigis <- vectorOf ni (arbitrarySigInput net ctx) + let uSigis = nubBy (\(a, _) (b, _) -> a.outpoint == b.outpoint) sigis + inps <- forM uSigis $ \(s, _) -> TxIn s.outpoint BS.empty <$> arbitrary + outs <- vectorOf no (arbitraryTxOut net ctx) + l <- arbitrary + perm <- choose (0, length inps - 1) + let tx = Tx v (permutations inps !! perm) outs [] l + keys = concatMap snd uSigis + return (tx, map fst uSigis, keys) -- | Arbitrary transaction with empty inputs. -arbitraryEmptyTx :: Network -> Gen Tx -arbitraryEmptyTx net = do - v <- arbitrary - no <- choose (1, 5) - ni <- choose (1, 5) - outs <- vectorOf no (arbitraryTxOut net) - ops <- vectorOf ni arbitraryOutPoint - t <- arbitrary - s <- arbitrary - return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t +arbitraryEmptyTx :: Network -> Ctx -> Gen Tx +arbitraryEmptyTx net ctx = do + v <- arbitrary + no <- choose (1, 5) + ni <- choose (1, 5) + outs <- vectorOf no (arbitraryTxOut net ctx) + ops <- vectorOf ni arbitraryOutPoint + t <- arbitrary + s <- arbitrary + return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t -- | Arbitrary partially-signed transactions. arbitraryPartialTxs :: - Network -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -arbitraryPartialTxs net = do - tx <- arbitraryEmptyTx net - res <- - forM (map prevOutput $ txIn tx) $ \op -> do - (so, val, rdmM, prvs, m, n) <- arbitraryData - txs <- mapM (singleSig so val rdmM tx op . secKeyData) prvs - return (txs, (so, val, op, m, n)) - return (concatMap fst res, map snd res) + Network -> Ctx -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) +arbitraryPartialTxs net ctx = do + tx <- arbitraryEmptyTx net ctx + res <- + forM (map (.outpoint) tx.inputs) $ \op -> do + (so, val, rdmM, prvs, m, n) <- arbitraryData + txs <- mapM (singleSig so val rdmM tx op . (.key)) prvs + return (txs, (so, val, op, m, n)) + return (concatMap fst res, map snd res) where singleSig so val rdmM tx op prv = do - sh <- arbitraryValidSigHash net - let sigi = SigInput so val op sh rdmM - return . fromRight (error "Could not decode transaction") $ - signTx net tx [sigi] [prv] + sh <- arbitraryValidSigHash net + let sigi = SigInput so val op sh rdmM + return . fromRight (error "Could not decode transaction") $ + signTx net ctx tx [sigi] [prv] arbitraryData = do - (m, n) <- arbitraryMSParam - val <- getTestCoin <$> arbitrarySatoshi net - nPrv <- choose (m, n) - keys <- vectorOf n arbitraryKeyPair - perm <- choose (0, length keys - 1) - let pubKeys = map snd keys - prvKeys = take nPrv $ permutations (map fst keys) !! perm - let so = PayMulSig pubKeys m - elements - [ (so, val, Nothing, prvKeys, m, n) - , - ( PayScriptHash $ getAddrHash160 $ payToScriptAddress so - , val - , Just so - , prvKeys - , m - , n - ) - ] + (m, n) <- arbitraryMSParam + val <- getTestCoin <$> arbitrarySatoshi net + nPrv <- choose (m, n) + keys <- vectorOf n (arbitraryKeyPair ctx) + perm <- choose (0, length keys - 1) + let pubKeys = map snd keys + prvKeys = take nPrv $ permutations (map fst keys) !! perm + let so = PayMulSig pubKeys m + elements + [ (so, val, Nothing, prvKeys, m, n), + ( PayScriptHash (payToScriptAddress ctx so).hash160, + val, + Just so, + prvKeys, + m, + n + ) + ] -wrapKey :: (SigInput, SecKeyI) -> (SigInput, [SecKeyI]) +wrapKey :: (SigInput, PrivateKey) -> (SigInput, [PrivateKey]) wrapKey (s, k) = (s, [k]) diff --git a/src/Haskoin/Util/Arbitrary/Util.hs b/src/Haskoin/Util/Arbitrary/Util.hs index 26f3bdce..cfd56b8d 100644 --- a/src/Haskoin/Util/Arbitrary/Util.hs +++ b/src/Haskoin/Util/Arbitrary/Util.hs @@ -1,16 +1,15 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Test.Util -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Haskoin.Util.Arbitrary.Util ( - arbitraryBS, +-- | +-- Module : Haskoin.Test.Util +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +module Haskoin.Util.Arbitrary.Util + ( arbitraryBS, arbitraryBS1, arbitraryBSn, arbitraryBSS, @@ -30,15 +29,16 @@ module Haskoin.Util.Arbitrary.Util ( testNetJson, arbitraryNetData, genNetData, -) where + ) +where import Control.Monad (forM_, (<=<)) import qualified Data.Aeson as A import qualified Data.Aeson.Encoding as A import qualified Data.Aeson.Types as A import Data.ByteString (ByteString, pack) -import qualified Data.ByteString.Short as BSS import Data.ByteString.Lazy (fromStrict, toStrict) +import qualified Data.ByteString.Short as BSS import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -48,8 +48,8 @@ import Data.Time.Clock (UTCTime (..)) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import qualified Data.Typeable as T import Data.Word (Word32) -import Haskoin.Constants -import Haskoin.Data +import Haskoin.Network.Constants +import Haskoin.Network.Data import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck @@ -81,16 +81,16 @@ arbitraryBSSn n = BSS.pack <$> vectorOf n arbitrary -- | Arbitrary UTCTime that generates dates after 01 Jan 1970 01:00:00 CET arbitraryUTCTime :: Gen UTCTime arbitraryUTCTime = do - w <- arbitrary :: Gen Word32 - return $ posixSecondsToUTCTime $ realToFrac w + w <- arbitrary :: Gen Word32 + return $ posixSecondsToUTCTime $ realToFrac w -- | Generate a Maybe from a Gen a arbitraryMaybe :: Gen a -> Gen (Maybe a) arbitraryMaybe g = - frequency - [ (1, return Nothing) - , (5, Just <$> g) - ] + frequency + [ (1, return Nothing), + (5, Just <$> g) + ] -- | Generate an Network arbitraryNetwork :: Gen Network @@ -99,51 +99,55 @@ arbitraryNetwork = elements allNets -- Helpers for creating Serial and JSON Identity tests data SerialBox - = forall a. - (Show a, Eq a, T.Typeable a, Serial a) => - SerialBox (Gen a) + = forall a. + (Show a, Eq a, T.Typeable a, Serial a) => + SerialBox (Gen a) data ReadBox - = forall a. - (Read a, Show a, Eq a, T.Typeable a) => - ReadBox (Gen a) + = forall a. + (Read a, Show a, Eq a, T.Typeable a) => + ReadBox (Gen a) data JsonBox - = forall a. - (Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) => - JsonBox (Gen a) + = forall a. + (Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) => + JsonBox (Gen a) data NetBox - = forall a. - (Show a, Eq a, T.Typeable a) => - NetBox - ( Network -> a -> A.Value - , Network -> a -> A.Encoding - , Network -> A.Value -> A.Parser a - , Gen (Network, a) - ) + = forall a. + (Show a, Eq a, T.Typeable a) => + NetBox + ( Network -> a -> A.Value, + Network -> a -> A.Encoding, + Network -> A.Value -> A.Parser a, + Gen (Network, a) + ) testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec testIdentity serialVals readVals jsonVals netVals = do - describe "Binary Encoding" $ - forM_ serialVals $ \(SerialBox g) -> testSerial g - describe "Read/Show Encoding" $ - forM_ readVals $ \(ReadBox g) -> testRead g - describe "Data.Aeson Encoding" $ - forM_ jsonVals $ \(JsonBox g) -> testJson g - describe "Data.Aeson Encoding with Network" $ - forM_ netVals $ \(NetBox (j, e, p, g)) -> testNetJson j e p g + describe "Binary Encoding" $ + forM_ serialVals $ + \(SerialBox g) -> testSerial g + describe "Read/Show Encoding" $ + forM_ readVals $ + \(ReadBox g) -> testRead g + describe "Data.Aeson Encoding" $ + forM_ jsonVals $ + \(JsonBox g) -> testJson g + describe "Data.Aeson Encoding with Network" $ + forM_ netVals $ + \(NetBox (j, e, p, g)) -> testNetJson j e p g -- | Generate binary identity tests testSerial :: - (Eq a, Show a, T.Typeable a, Serial a) => Gen a -> Spec + (Eq a, Show a, T.Typeable a, Serial a) => Gen a -> Spec testSerial gen = - prop ("Binary encoding/decoding identity for " <> name) $ - forAll gen $ \x -> do - (runGetL deserialize . runPutL . serialize) x `shouldBe` x - (runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x - (runGetS deserialize . runPutS . serialize) x `shouldBe` Right x - (runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x + prop ("Binary encoding/decoding identity for " <> name) $ + forAll gen $ \x -> do + (runGetL deserialize . runPutL . serialize) x `shouldBe` x + (runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x + (runGetS deserialize . runPutS . serialize) x `shouldBe` Right x + (runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x where name = show $ T.typeRep $ proxy gen proxy :: Gen a -> Proxy a @@ -151,10 +155,11 @@ testSerial gen = -- | Generate Read/Show identity tests testRead :: - (Eq a, Read a, Show a, T.Typeable a) => Gen a -> Spec + (Eq a, Read a, Show a, T.Typeable a) => Gen a -> Spec testRead gen = - prop ("read/show identity for " <> name) $ - forAll gen $ \x -> (read . show) x `shouldBe` x + prop ("read/show identity for " <> name) $ + forAll gen $ + \x -> (read . show) x `shouldBe` x where name = show $ T.typeRep $ proxy gen proxy :: Gen a -> Proxy a @@ -162,34 +167,36 @@ testRead gen = -- | Generate Data.Aeson identity tests testJson :: - (Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec + (Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec testJson gen = do - prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $ - forAll gen (`shouldSatisfy` jsonID) - prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $ - forAll gen (`shouldSatisfy` encodingID) + prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $ + forAll gen (`shouldSatisfy` jsonID) + prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $ + forAll gen (`shouldSatisfy` encodingID) where name = show $ T.typeRep $ proxy gen proxy :: Gen a -> Proxy a proxy = const Proxy jsonID x = (A.fromJSON . A.toJSON) (toMap x) == A.Success (toMap x) encodingID x = - (A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x) - == Just (toMap x) + (A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x) + == Just (toMap x) -- | Generate Data.Aeson identity tests for type that need the @Network@ testNetJson :: - (Eq a, Show a, T.Typeable a) => - (Network -> a -> A.Value) -> - (Network -> a -> A.Encoding) -> - (Network -> A.Value -> A.Parser a) -> - Gen (Network, a) -> - Spec + (Eq a, Show a, T.Typeable a) => + (Network -> a -> A.Value) -> + (Network -> a -> A.Encoding) -> + (Network -> A.Value -> A.Parser a) -> + Gen (Network, a) -> + Spec testNetJson j e p g = do - prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $ - forAll g $ \(net, x) -> dec net (encVal net x) `shouldBe` Just x - prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $ - forAll g $ \(net, x) -> dec net (encEnc net x) `shouldBe` Just x + prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $ + forAll g $ + \(net, x) -> dec net (encVal net x) `shouldBe` Just x + prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $ + forAll g $ + \(net, x) -> dec net (encEnc net x) `shouldBe` Just x where encVal net = A.encode . toMap . j net encEnc net = A.encodingToLazyByteString . toMapE . e net @@ -198,17 +205,17 @@ testNetJson j e p g = do proxy :: (Network -> a -> A.Value) -> Proxy a proxy = const Proxy -arbitraryNetData :: Arbitrary a => Gen (Network, a) +arbitraryNetData :: (Arbitrary a) => Gen (Network, a) arbitraryNetData = do - net <- arbitraryNetwork - x <- arbitrary - return (net, x) + net <- arbitraryNetwork + x <- arbitrary + return (net, x) genNetData :: Gen a -> Gen (Network, a) genNetData gen = do - net <- arbitraryNetwork - x <- gen - return (net, x) + net <- arbitraryNetwork + x <- gen + return (net, x) toMap :: a -> Map.Map String a toMap = Map.singleton "object" diff --git a/src/Haskoin/Util/Helpers.hs b/src/Haskoin/Util/Helpers.hs new file mode 100644 index 00000000..e277346f --- /dev/null +++ b/src/Haskoin/Util/Helpers.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Haskoin.Util +-- Copyright : No rights reserved +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- This module defines various utility functions used across the library. +module Haskoin.Util.Helpers + ( -- * ByteString Helpers + bsToInteger, + integerToBS, + hexEncoding, + hexBuilder, + encodeHex, + encodeHexLazy, + decodeHex, + decodeHexLazy, + getBits, + + -- * Maybe & Either Helpers + eitherToMaybe, + maybeToEither, + liftEither, + liftMaybe, + + -- * Other Helpers + updateIndex, + matchTemplate, + convertBits, + + -- * Triples + fst3, + snd3, + lst3, + + -- * JSON Utilities + dropFieldLabel, + dropSumLabels, + + -- * Serialization Helpers + putList, + getList, + putMaybe, + getMaybe, + putLengthBytes, + getLengthBytes, + putInteger, + getInteger, + putInt32be, + getInt32be, + putInt64be, + getInt64be, + getIntMap, + putIntMap, + getTwo, + putTwo, + + -- * Test Helpers + prepareContext, + customCerealID, + readTestFile, + readTestFileParser, + ) +where + +import Control.Monad +import Control.Monad.Except (ExceptT (..), liftEither) +import Crypto.Secp256k1 +import Data.Aeson (eitherDecodeFileStrict) +import Data.Aeson.Encoding +import Data.Aeson.Types +import Data.Base16.Types +import Data.Bits +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Base16 +import Data.ByteString.Builder +import Data.ByteString.Lazy qualified as LB +import Data.ByteString.Lazy.Base16 qualified as LB16 +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Char (toLower) +import Data.Int +import Data.IntMap (IntMap) +import Data.IntMap qualified as IntMap +import Data.List +import Data.Serialize qualified as S +import Data.Text (Text) +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as LT +import Data.Text.Lazy.Encoding qualified as LT +import Data.Word +import Test.Hspec + +-- ByteString helpers + +-- | Decode a big endian 'Integer' from a 'ByteString'. +bsToInteger :: ByteString -> Integer +bsToInteger = B.foldr f 0 . B.reverse + where + f w n = toInteger w .|. shiftL n 8 + +-- | Encode an 'Integer' to a 'ByteString' as big endian. +integerToBS :: Integer -> ByteString +integerToBS 0 = B.pack [0] +integerToBS i + | i > 0 = B.reverse $ B.unfoldr f i + | otherwise = error "integerToBS not defined for negative values" + where + f 0 = Nothing + f x = Just (fromInteger x :: Word8, x `shiftR` 8) + +hexEncoding :: LB.ByteString -> Encoding +hexEncoding b = + unsafeToEncoding $ + char7 '"' <> hexBuilder b <> char7 '"' + +hexBuilder :: LB.ByteString -> Builder +hexBuilder = lazyByteStringHex + +encodeHex :: ByteString -> Text +encodeHex = extractBase16 . encodeBase16 + +-- | Encode as string of human-readable hex characters. +encodeHexLazy :: LB.ByteString -> LT.Text +encodeHexLazy = extractBase16 . LB16.encodeBase16 + +decodeHex :: Text -> Maybe ByteString +decodeHex t = + if isBase16 u8 + then Just . decodeBase16 $ assertBase16 u8 + else Nothing + where + u8 = T.encodeUtf8 t + +-- | Decode string of human-readable hex characters. +decodeHexLazy :: LT.Text -> Maybe LB.ByteString +decodeHexLazy t = + if LB16.isBase16 u8 + then Just . LB16.decodeBase16 $ assertBase16 u8 + else Nothing + where + u8 = LT.encodeUtf8 t + +-- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString' +-- will be smallest required to hold that many bits, padded with zeroes to the +-- right. +getBits :: Int -> ByteString -> ByteString +getBits b bs + | r == 0 = B.take q bs + | otherwise = i `B.snoc` l + where + (q, r) = b `quotRem` 8 + s = B.take (q + 1) bs + i = B.init s + l = B.last s .&. (0xff `shiftL` (8 - r)) -- zero unneeded bits + +-- Maybe and Either monad helpers + +-- | Transform an 'Either' value into a 'Maybe' value. 'Right' is mapped to +-- 'Just' and 'Left' is mapped to 'Nothing'. The value inside 'Left' is lost. +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Right b) = Just b +eitherToMaybe _ = Nothing + +-- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to +-- 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required. +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither err = maybe (Left err) Right + +-- | Lift a 'Maybe' computation into the 'ExceptT' monad. +liftMaybe :: (Monad m) => b -> Maybe a -> ExceptT b m a +liftMaybe err = liftEither . maybeToEither err + +-- Various helpers + +-- | Applies a function to only one element of a list defined by its index. If +-- the index is out of the bounds of the list, the original list is returned. +updateIndex :: + -- | index of the element to change + Int -> + -- | list of elements + [a] -> + -- | function to apply + (a -> a) -> + -- | result with one element changed + [a] +updateIndex i xs f + | i < 0 || i >= length xs = xs + | otherwise = l ++ (f h : r) + where + (l, h : r) = splitAt i xs + +-- | Use the list @[b]@ as a template and try to match the elements of @[a]@ +-- against it. For each element of @[b]@ return the (first) matching element of +-- @[a]@, or 'Nothing'. Output list has same size as @[b]@ and contains results +-- in same order. Elements of @[a]@ can only appear once. +matchTemplate :: + -- | input list + [a] -> + -- | list to serve as a template + [b] -> + -- | comparison function + (a -> b -> Bool) -> + [Maybe a] +matchTemplate [] bs _ = replicate (length bs) Nothing +matchTemplate _ [] _ = [] +matchTemplate as (b : bs) f = case break (`f` b) as of + (l, r : rs) -> Just r : matchTemplate (l ++ rs) bs f + _ -> Nothing : matchTemplate as bs f + +-- | Returns the first value of a triple. +fst3 :: (a, b, c) -> a +fst3 (a, _, _) = a + +-- | Returns the second value of a triple. +snd3 :: (a, b, c) -> b +snd3 (_, b, _) = b + +-- | Returns the last value of a triple. +lst3 :: (a, b, c) -> c +lst3 (_, _, c) = c + +-- | Field label goes lowercase and first @n@ characters get removed. +dropFieldLabel :: Int -> Options +dropFieldLabel n = + defaultOptions + { fieldLabelModifier = map toLower . drop n + } + +-- | Transformation from 'dropFieldLabel' is applied with argument @f@, plus +-- constructor tags are lowercased and first @c@ characters removed. @tag@ is +-- used as the name of the object field name that will hold the transformed +-- constructor tag as its value. +dropSumLabels :: Int -> Int -> String -> Options +dropSumLabels c f tag = + (dropFieldLabel f) + { constructorTagModifier = map toLower . drop c, + sumEncoding = defaultTaggedObject {tagFieldName = tag} + } + +-- | Convert from one power-of-two base to another, as long as it fits in a +-- 'Word'. +convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool) +convertBits pad frombits tobits i = (reverse yout, rem') + where + (xacc, xbits, xout) = foldl' outer (0, 0, []) i + (yout, rem') + | pad && xbits /= 0 = + let xout' = (xacc `shiftL` (tobits - xbits)) .&. maxv : xout + in (xout', False) + | pad = (xout, False) + | xbits /= 0 = (xout, True) + | otherwise = (xout, False) + maxv = 1 `shiftL` tobits - 1 + max_acc = 1 `shiftL` (frombits + tobits - 1) - 1 + outer (acc, bits, out) it = + let acc' = ((acc `shiftL` frombits) .|. it) .&. max_acc + bits' = bits + frombits + (out', bits'') = inner acc' out bits' + in (acc', bits'', out') + inner acc out bits + | bits >= tobits = + let bits' = bits - tobits + out' = ((acc `shiftR` bits') .&. maxv) : out + in inner acc out' bits' + | otherwise = (out, bits) + +-- +-- Serialization helpers +-- + +putInt32be :: (MonadPut m) => Int32 -> m () +putInt32be n + | n < 0 = putWord32be (complement (fromIntegral (abs n)) + 1) + | otherwise = putWord32be (fromIntegral (abs n)) + +getInt32be :: (MonadGet m) => m Int32 +getInt32be = do + n <- getWord32be + if testBit n 31 + then return (negate (complement (fromIntegral n) + 1)) + else return (fromIntegral n) + +putInt64be :: (MonadPut m) => Int64 -> m () +putInt64be n + | n < 0 = putWord64be (complement (fromIntegral (abs n)) + 1) + | otherwise = putWord64be (fromIntegral (abs n)) + +getInt64be :: (MonadGet m) => m Int64 +getInt64be = do + n <- getWord64be + if testBit n 63 + then return (negate (complement (fromIntegral n) + 1)) + else return (fromIntegral n) + +putInteger :: (MonadPut m) => Integer -> m () +putInteger n + | n >= lo && n <= hi = do + putWord8 0x00 + putInt32be (fromIntegral n) + | otherwise = do + putWord8 0x01 + putWord8 (fromIntegral (signum n)) + let len = (nrBits (abs n) + 7) `div` 8 + putWord64be (fromIntegral len) + mapM_ putWord8 (unroll (abs n)) + where + lo = fromIntegral (minBound :: Int32) + hi = fromIntegral (maxBound :: Int32) + +getInteger :: (MonadGet m) => m Integer +getInteger = + getWord8 >>= \case + 0 -> fromIntegral <$> getInt32be + _ -> do + sign <- getWord8 + bytes <- getList getWord8 + let v = roll bytes + return $! if sign == 0x01 then v else -v + +putMaybe :: (MonadPut m) => (a -> m ()) -> Maybe a -> m () +putMaybe f Nothing = putWord8 0x00 +putMaybe f (Just x) = putWord8 0x01 >> f x + +getMaybe :: (MonadGet m) => m a -> m (Maybe a) +getMaybe f = + getWord8 >>= \case + 0x00 -> return Nothing + 0x01 -> Just <$> f + _ -> fail "Not a Maybe" + +putLengthBytes :: (MonadPut m) => ByteString -> m () +putLengthBytes bs = do + putWord64be (fromIntegral (B.length bs)) + putByteString bs + +getLengthBytes :: (MonadGet m) => m ByteString +getLengthBytes = do + len <- fromIntegral <$> getWord64be + getByteString len + +-- +-- Fold and unfold an Integer to and from a list of its bytes +-- +unroll :: (Integral a, Bits a) => a -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: (Integral a, Bits a) => [Word8] -> a +roll = foldr unstep 0 + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + +nrBits :: (Ord a, Integral a) => a -> Int +nrBits k = + let expMax = until (\e -> 2 ^ e > k) (* 2) 1 + findNr :: Int -> Int -> Int + findNr lo hi + | mid == lo = hi + | 2 ^ mid <= k = findNr mid hi + | 2 ^ mid > k = findNr lo mid + where + mid = (lo + hi) `div` 2 + in findNr (expMax `div` 2) expMax + +-- | Read as a list of pairs of int and element. +getIntMap :: (MonadGet m) => m Int -> m a -> m (IntMap a) +getIntMap i m = IntMap.fromList <$> getList (getTwo i m) + +putIntMap :: (MonadPut m) => (Int -> m ()) -> (a -> m ()) -> IntMap a -> m () +putIntMap f g = putList (putTwo f g) . IntMap.toAscList + +putTwo :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> (a, b) -> m () +putTwo f g (x, y) = f x >> g y + +getTwo :: (MonadGet m) => m a -> m b -> m (a, b) +getTwo f g = (,) <$> f <*> g + +putList :: (MonadPut m) => (a -> m ()) -> [a] -> m () +putList f ls = do + putWord64be (fromIntegral (length ls)) + mapM_ f ls + +getList :: (MonadGet m) => m a -> m [a] +getList f = do + l <- fromIntegral <$> getWord64be + replicateM l f + +-- +-- Test Helpers +-- + +prepareContext :: (Ctx -> SpecWith a) -> SpecWith a +prepareContext go = do + ctx <- runIO $ do + ctx <- createContext + randomizeContext ctx + return ctx + afterAll_ (destroyContext ctx) (go ctx) + +customCerealID :: (Eq a) => S.Get a -> S.Putter a -> a -> Bool +customCerealID g p a = (S.runGet g . S.runPut . p) a == Right a + +readTestFile :: (FromJSON a) => FilePath -> IO a +readTestFile fp = + eitherDecodeFileStrict ("data/" <> fp) >>= either (error . message) return + where + message aesonErr = "Could not read test file " <> fp <> ": " <> aesonErr + +readTestFileParser :: (Value -> Parser a) -> FilePath -> IO a +readTestFileParser p fp = do + v <- readTestFile fp + case parse p v of + Error s -> error s + Success x -> return x diff --git a/src/Haskoin/Util/Marshal.hs b/src/Haskoin/Util/Marshal.hs new file mode 100644 index 00000000..2c4bfe37 --- /dev/null +++ b/src/Haskoin/Util/Marshal.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ImportQualifiedPost #-} + +module Haskoin.Util.Marshal where + +import Control.Monad +import Crypto.Secp256k1 +import Data.Aeson +import Data.Aeson.Encoding +import Data.Aeson.Types +import Data.ByteString +import Data.ByteString.Builder +import Data.ByteString.Lazy qualified as Lazy +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial + +class Marshal s a | a -> s where + marshalPut :: (MonadPut m) => s -> a -> m () + marshalGet :: (MonadGet m) => s -> m a + +marshal :: (Marshal s a) => s -> a -> ByteString +marshal s = runPutS . marshalPut s + +marshalLazy :: (Marshal s a) => s -> a -> Lazy.ByteString +marshalLazy s = runPutL . marshalPut s + +unmarshal :: (Marshal s a) => s -> ByteString -> Either String a +unmarshal = runGetS . marshalGet + +unmarshalLazy :: (Marshal s a) => s -> Lazy.ByteString -> a +unmarshalLazy = runGetL . marshalGet + +class MarshalJSON s a | a -> s where + marshalValue :: s -> a -> Value + marshalEncoding :: s -> a -> Encoding + marshalEncoding x = value . marshalValue x + unmarshalValue :: s -> Value -> Parser a + +marshalJSON :: (MarshalJSON s a) => s -> a -> Lazy.ByteString +marshalJSON s = toLazyByteString . fromEncoding . marshalEncoding s + +unmarshalJSON :: (MarshalJSON s a) => s -> Lazy.ByteString -> Maybe a +unmarshalJSON s = parseMaybe (unmarshalValue s) <=< decode \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index cda93374..d9a0490a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,8 @@ -resolver: lts-21.0 +resolver: lts-21.4 nix: packages: - secp256k1 - pkg-config extra-deps: - base16-1.0@sha256:9b72a280a7af75a5026fa25a1b8ae18ec10200a070947723f1fd61dc8d407862,2472 - - secp256k1-haskell-0.7.0@sha256:1585601c67d7c62c698402ffe8462de216a499608521a8136d0aa15f0a03a23f,2140 \ No newline at end of file + - secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082 diff --git a/stack.yaml.lock b/stack.yaml.lock index 32ad4cc1..3c2bafd8 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -12,15 +12,15 @@ packages: original: hackage: base16-1.0@sha256:9b72a280a7af75a5026fa25a1b8ae18ec10200a070947723f1fd61dc8d407862,2472 - completed: - hackage: secp256k1-haskell-0.7.0@sha256:1585601c67d7c62c698402ffe8462de216a499608521a8136d0aa15f0a03a23f,2140 + hackage: secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082 pantry-tree: - sha256: a7726275193ac4ef14c9d97378222d3ca494524c48354edf69214513def7d48d - size: 599 + sha256: 7846a02f6292cb0179cdf7252b3832f74b3109079e45248c931791f951355702 + size: 600 original: - hackage: secp256k1-haskell-0.7.0@sha256:1585601c67d7c62c698402ffe8462de216a499608521a8136d0aa15f0a03a23f,2140 + hackage: secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082 snapshots: - completed: - sha256: 1867d84255dff8c87373f5dd03e5a5cb1c10a99587e26c8793e750c54e83ffdc - size: 639139 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/0.yaml - original: lts-21.0 + sha256: caa77fdbc5b9f698262b21ee78030133272ec53116ad6ddbefdc4c321f668e0c + size: 640014 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/4.yaml + original: lts-21.4 diff --git a/test/Haskoin/Address/Bech32Spec.hs b/test/Haskoin/Address/Bech32Spec.hs index e821dda3..671f129e 100644 --- a/test/Haskoin/Address/Bech32Spec.hs +++ b/test/Haskoin/Address/Bech32Spec.hs @@ -1,18 +1,17 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} -module Haskoin.Address.Bech32Spec ( - spec, -) where +module Haskoin.Address.Bech32Spec (spec) where import Control.Monad import Data.Bits (xor) import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Data.ByteString qualified as ByteString import Data.Char (chr, ord, toLower) import Data.Maybe import Data.String.Conversions import Data.Text (Text, append, pack, snoc, uncons) -import qualified Data.Text as T +import Data.Text qualified as Text import Data.Word (Word8) import Haskoin.Address import Haskoin.Address.Bech32 @@ -21,238 +20,225 @@ import Test.HUnit import Test.Hspec spec = do - describe "bech32 checksum" $ do - it "should be valid" $ - forM_ validChecksums (uncurry testValidChecksum) - it "should be invalid" $ - forM_ invalidChecksums testInvalidChecksum - it "should be case-insensitive" $ - all (== Just "test12hrzfj") $ - map (flip (bech32Encode Bech32) []) hrpCaseVariants - describe "bech32 address" $ do - it "should be valid" $ - forM_ validChecksums (uncurry testValidChecksum) - it "should be invalid" $ - forM_ invalidChecksums testInvalidChecksum - it "should be case-insensitive" $ - all (== Just "test12hrzfj") $ - map (flip (bech32Encode Bech32) []) hrpCaseVariants - describe "bech32 encoding/decoding" $ do - it "should not encode long data string" $ - assert . isNothing $ - bech32Encode Bech32 "bc" (replicate 82 (word5 (1 :: Word8))) - it "should not encode bad version number" $ - assert $ isNothing $ segwitEncode "bc" 17 [] - it "should not encode invalid length for version 0" $ - assert $ isNothing $ segwitEncode "bc" 0 (replicate 30 1) - it "should relax length restrictions for versions other than 0" $ - assert $ isJust $ segwitEncode "bc" 1 (replicate 30 1) - it "should not encode another long data string" $ - assert $ isNothing $ segwitEncode "bc" 1 (replicate 41 1) - it "should not encode empty human readable part" $ - assert $ isNothing $ bech32Encode Bech32 "" [] - it "should not decode empty human-readable part" $ - assert $ isNothing $ bech32Decode "10a06t8" - it "human-readable part should be case-insensitive" $ - bech32Encode Bech32 "HRP" [] `shouldBe` bech32Encode Bech32 "hrp" [] + describe "bech32 checksum" $ do + it "should be valid" $ + forM_ validChecksums (uncurry testValidChecksum) + it "should be invalid" $ + forM_ invalidChecksums testInvalidChecksum + it "should be case-insensitive" $ + all ((== Just "test12hrzfj") . flip (bech32Encode Bech32) []) hrpCaseVariants + describe "bech32 address" $ do + it "should be valid" $ + forM_ validChecksums (uncurry testValidChecksum) + it "should be invalid" $ + forM_ invalidChecksums testInvalidChecksum + it "should be case-insensitive" $ + all ((== Just "test12hrzfj") . flip (bech32Encode Bech32) []) hrpCaseVariants + describe "bech32 encoding/decoding" $ do + it "should not encode long data string" $ + assert . isNothing $ + bech32Encode Bech32 "bc" (replicate 82 (word5 (1 :: Word8))) + it "should not encode bad version number" $ + assert $ + isNothing $ + segwitEncode "bc" 17 [] + it "should not encode invalid length for version 0" $ + assert $ + isNothing $ + segwitEncode "bc" 0 (replicate 30 1) + it "should relax length restrictions for versions other than 0" $ + assert $ + isJust $ + segwitEncode "bc" 1 (replicate 30 1) + it "should not encode another long data string" $ + assert $ + isNothing $ + segwitEncode "bc" 1 (replicate 41 1) + it "should not encode empty human readable part" $ + assert $ + isNothing $ + bech32Encode Bech32 "" [] + it "should not decode empty human-readable part" $ + assert $ + isNothing $ + bech32Decode "10a06t8" + it "human-readable part should be case-insensitive" $ + bech32Encode Bech32 "HRP" [] `shouldBe` bech32Encode Bech32 "hrp" [] testValidChecksum :: Bech32Encoding -> Bech32 -> Assertion testValidChecksum enc checksum = case bech32Decode checksum of - Nothing -> assertFailure (show checksum) - Just (enc', resultHRP, resultData) -> do - assertEqual (show checksum ++ " encoding incorrect") enc enc' - -- test that a corrupted checksum fails decoding. - let (hrp, rest) = T.breakOnEnd "1" checksum - Just (first, rest') = uncons rest - checksumCorrupted = (hrp `snoc` chr (ord first `xor` 1)) `append` rest' - assertBool (show checksum ++ " corrupted") $ - isNothing (bech32Decode checksumCorrupted) - -- test that re-encoding the decoded checksum results in the same checksum. - let checksumEncoded = bech32Encode enc' resultHRP resultData - expectedChecksum = Just $ T.toLower checksum - assertEqual - (show checksum ++ " re-encode") - expectedChecksum - checksumEncoded + Nothing -> assertFailure (show checksum) + Just (enc', resultHRP, resultData) -> do + assertEqual (show checksum ++ " encoding incorrect") enc enc' + -- test that a corrupted checksum fails decoding. + let (hrp, rest) = Text.breakOnEnd "1" checksum + Just (first, rest') = uncons rest + checksumCorrupted = (hrp `snoc` chr (ord first `xor` 1)) `append` rest' + assertBool (show checksum ++ " corrupted") $ + isNothing (bech32Decode checksumCorrupted) + -- test that re-encoding the decoded checksum results in the same checksum. + let checksumEncoded = bech32Encode enc' resultHRP resultData + expectedChecksum = Just $ Text.toLower checksum + assertEqual + (show checksum ++ " re-encode") + expectedChecksum + checksumEncoded testInvalidChecksum :: Bech32 -> Assertion testInvalidChecksum checksum = - assertBool (show checksum) (isNothing $ bech32Decode checksum) + assertBool (show checksum) (isNothing $ bech32Decode checksum) testValidAddress :: (Text, Text) -> Assertion testValidAddress (address, hexscript) = do - let address' = T.toLower address - hrp = T.take 2 address' - case segwitDecode hrp address of - Nothing -> - assertFailure (T.unpack address <> ": decode failed") - Just (witver, witprog) -> do - assertEqual - (show address) - (decodeHex hexscript) - (Just $ segwitScriptPubkey witver witprog) - assertEqual - (show address) - (Just address') - (segwitEncode hrp witver witprog) + let address' = Text.toLower address + hrp = Text.take 2 address' + case segwitDecode hrp address of + Nothing -> + assertFailure (Text.unpack address <> ": decode failed") + Just (witver, witprog) -> do + assertEqual + (show address) + (decodeHex hexscript) + (Just $ segwitScriptPubkey witver witprog) + assertEqual + (show address) + (Just address') + (segwitEncode hrp witver witprog) testInvalidAddress :: Text -> Assertion testInvalidAddress address = do - assertBool (show address) (isNothing $ segwitDecode "bc" address) - assertBool (show address) (isNothing $ segwitDecode "tb" address) + assertBool (show address) (isNothing $ segwitDecode "bc" address) + assertBool (show address) (isNothing $ segwitDecode "tb" address) segwitScriptPubkey :: Word8 -> [Word8] -> ByteString segwitScriptPubkey witver witprog = - B.pack $ witver' : fromIntegral (length witprog) : witprog + ByteString.pack $ witver' : fromIntegral (length witprog) : witprog where witver' = if witver == 0 then 0 else witver + 0x50 validChecksums :: [(Bech32Encoding, Text)] validChecksums = - [ - ( Bech32 - , "A12UEL5L" - ) - , - ( Bech32 - , "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs" - ) - , - ( Bech32 - , "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw" - ) - , - ( Bech32 - , "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j" - ) - , - ( Bech32 - , "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w" - ) - , - ( Bech32m - , "A1LQFN3A" - ) - , - ( Bech32m - , "a1lqfn3a" - ) - , - ( Bech32m - , "an83characterlonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11sg7hg6" - ) - , - ( Bech32m - , "abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx" - ) - , - ( Bech32m - , "11llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllludsr8" - ) - , - ( Bech32m - , "split1checkupstagehandshakeupstreamerranterredcaperredlc445v" - ) - , - ( Bech32m - , "?1v759aa" - ) - ] + [ ( Bech32, + "A12UEL5L" + ), + ( Bech32, + "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs" + ), + ( Bech32, + "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw" + ), + ( Bech32, + "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j" + ), + ( Bech32, + "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w" + ), + ( Bech32m, + "A1LQFN3A" + ), + ( Bech32m, + "a1lqfn3a" + ), + ( Bech32m, + "an83characterlonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11sg7hg6" + ), + ( Bech32m, + "abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx" + ), + ( Bech32m, + "11llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllludsr8" + ), + ( Bech32m, + "split1checkupstagehandshakeupstreamerranterredcaperredlc445v" + ), + ( Bech32m, + "?1v759aa" + ) + ] invalidChecksums :: [Text] invalidChecksums = - [ " 1nwldj5" - , "\DEL1axkwrx" - , "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx" - , "pzry9x0s0muk" - , "1pzry9x0s0muk" - , "x1b4n0q5v" - , "li1dgmt3" - , "de1lg7wt\xFF" - ] + [ " 1nwldj5", + "\DEL1axkwrx", + "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx", + "pzry9x0s0muk", + "1pzry9x0s0muk", + "x1b4n0q5v", + "li1dgmt3", + "de1lg7wt\xFF" + ] validAddresses :: [(Text, Text)] validAddresses = - [ - ( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4" - , "0014751e76e8199196d454941c45d1b3a323f1433bd6" - ) - , - ( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7" - , "00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262" - ) - , - ( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy" - , "0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433" - ) - , - ( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4" - , "0014751e76e8199196d454941c45d1b3a323f1433bd6" - ) - , - ( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7" - , "00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262" - ) - , - ( "bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kt5nd6y" - , "5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6" - ) - , - ( "BC1SW50QGDZ25J" - , "6002751e" - ) - , - ( "bc1zw508d6qejxtdg4y5r3zarvaryvaxxpcs" - , "5210751e76e8199196d454941c45d1b3a323" - ) - , - ( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy" - , "0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433" - ) - , - ( "tb1pqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesf3hn0c" - , "5120000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433" - ) - , - ( "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqzk5jj0" - , "512079be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" - ) - ] + [ ( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4", + "0014751e76e8199196d454941c45d1b3a323f1433bd6" + ), + ( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7", + "00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262" + ), + ( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy", + "0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433" + ), + ( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4", + "0014751e76e8199196d454941c45d1b3a323f1433bd6" + ), + ( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7", + "00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262" + ), + ( "bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kt5nd6y", + "5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6" + ), + ( "BC1SW50QGDZ25J", + "6002751e" + ), + ( "bc1zw508d6qejxtdg4y5r3zarvaryvaxxpcs", + "5210751e76e8199196d454941c45d1b3a323" + ), + ( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy", + "0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433" + ), + ( "tb1pqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesf3hn0c", + "5120000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433" + ), + ( "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqzk5jj0", + "512079be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" + ) + ] invalidAddresses :: [Text] invalidAddresses = - [ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty" - , "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5" - , "BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2" - , "bc1rw5uspcuh" - , "bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90" - , "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P" - , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7" - , "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du" - , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv" - , "bc1gmk9yu" - , "tc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq5zuyut" - , "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqh2y7hd" - , "tb1z0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqglt7rf" - , "BC1S0XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ54WELL" - , "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kemeawh" - , "tb1q0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq24jc47" - , "bc1p38j9r5y49hruaue7wxjce0updqjuyyx0kh56v8s25huc6995vvpql3jow4" - , "BC130XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ7ZWS8R" - , "bc1pw5dgrnzv" - , "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v8n0nx0muaewav253zgeav" - , "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq47Zagq" - , "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v07qwwzcrf" - , "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j" - ] + [ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty", + "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5", + "BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2", + "bc1rw5uspcuh", + "bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90", + "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P", + "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7", + "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du", + "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv", + "bc1gmk9yu", + "tc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq5zuyut", + "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqh2y7hd", + "tb1z0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqglt7rf", + "BC1S0XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ54WELL", + "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kemeawh", + "tb1q0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq24jc47", + "bc1p38j9r5y49hruaue7wxjce0updqjuyyx0kh56v8s25huc6995vvpql3jow4", + "BC130XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ7ZWS8R", + "bc1pw5dgrnzv", + "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v8n0nx0muaewav253zgeav", + "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq47Zagq", + "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v07qwwzcrf", + "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j" + ] hrpCaseVariants :: [Text] -hrpCaseVariants = map T.pack hrpTestPermutations +hrpCaseVariants = map Text.pack hrpTestPermutations hrpTestPermutations :: [String] hrpTestPermutations = do - a <- ['t', 'T'] - b <- ['e', 'E'] - c <- ['s', 'S'] - d <- ['t', 'T'] - return [a, b, c, d] + a <- ['t', 'T'] + b <- ['e', 'E'] + c <- ['s', 'S'] + d <- ['t', 'T'] + return [a, b, c, d] diff --git a/test/Haskoin/Address/CashAddrSpec.hs b/test/Haskoin/Address/CashAddrSpec.hs index 11c640c0..63fc43b0 100644 --- a/test/Haskoin/Address/CashAddrSpec.hs +++ b/test/Haskoin/Address/CashAddrSpec.hs @@ -1,347 +1,315 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} module Haskoin.Address.CashAddrSpec (spec) where import Control.Monad -import qualified Data.ByteString.Char8 as C +import Data.ByteString.Char8 qualified as Char8 import Data.Maybe import Data.String.Conversions import Data.Text (Text) import Haskoin.Address -import Haskoin.Constants +import Haskoin.Network.Constants import Haskoin.Util import Test.HUnit import Test.Hspec spec :: Spec spec = do - describe "cashaddr checksum test vectors" $ do - it "prefix:x64nx6hz" $ do - let mpb = cash32decode "prefix:x64nx6hz" - mpb `shouldBe` Just ("prefix", "") - it "p:gpf8m4h7" $ do - let mpb = cash32decode "p:gpf8m4h7" - mpb `shouldBe` Just ("p", "") - it "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" $ do - let mpb = - cash32decode - "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" - mpb - `shouldBe` Just - ( "bitcoincash" - , "\NULD2\DC4\199BT\182\&5\207\132e:V\215\198u\190w\223" - ) - it "bchtest:testnetaddress4d6njnut" $ do - let mpb = cash32decode "bchtest:testnetaddress4d6njnut" - mpb `shouldBe` Just ("bchtest", "^`\185\229}kG\152") - it "bchreg:555555555555555555555555555555555555555555555udxmlmrz" $ do - let mpb = - cash32decode - "bchreg:555555555555555555555555555555555555555555555udxmlmrz" - mpb - `shouldBe` Just - ( "bchreg" - , "\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)J" - ) - describe "cashaddr to base58 translation test vectors" $ do - it "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" $ do - let addr = - addrToText bch - =<< textToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" - addr - `shouldBe` Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" - it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do - let addr = - addrToText bch - =<< textToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" - addr - `shouldBe` Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" - it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do - let addr = - addrToText bch - =<< textToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" - addr - `shouldBe` Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" - it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do - let addr = - addrToText bch - =<< textToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" - addr - `shouldBe` Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" - it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do - let addr = - addrToText bch - =<< textToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" - addr - `shouldBe` Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" - it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do - let addr = - addrToText bch - =<< textToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" - addr - `shouldBe` Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" - describe "base58 to cashaddr translation test vectors" $ do - it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" - addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" - it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" - addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" - it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" - addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" - it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" - addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" - it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" - addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" - it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" - addr `shouldBe` Just "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" - describe "cashaddr larger test vectors" $ - forM_ (zip [0 ..] vectors) $ \(i, vec) -> - it ("cashaddr test vector " <> show (i :: Int)) $ testCashAddr vec + describe "cashaddr checksum test vectors" $ do + it "prefix:x64nx6hz" $ do + let mpb = cash32decode "prefix:x64nx6hz" + mpb `shouldBe` Just ("prefix", "") + it "p:gpf8m4h7" $ do + let mpb = cash32decode "p:gpf8m4h7" + mpb `shouldBe` Just ("p", "") + it "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" $ do + let mpb = + cash32decode + "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" + mpb + `shouldBe` Just + ( "bitcoincash", + "\NULD2\DC4\199BT\182\&5\207\132e:V\215\198u\190w\223" + ) + it "bchtest:testnetaddress4d6njnut" $ do + let mpb = cash32decode "bchtest:testnetaddress4d6njnut" + mpb `shouldBe` Just ("bchtest", "^`\185\229}kG\152") + it "bchreg:555555555555555555555555555555555555555555555udxmlmrz" $ do + let mpb = + cash32decode + "bchreg:555555555555555555555555555555555555555555555udxmlmrz" + mpb + `shouldBe` Just + ( "bchreg", + "\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)J" + ) + describe "cashaddr to base58 translation test vectors" $ do + it "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" $ do + let addr = + addrToText bch + =<< textToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" + addr + `shouldBe` Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" + it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do + let addr = + addrToText bch + =<< textToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" + addr + `shouldBe` Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" + it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do + let addr = + addrToText bch + =<< textToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" + addr + `shouldBe` Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" + it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do + let addr = + addrToText bch + =<< textToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" + addr + `shouldBe` Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" + it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do + let addr = + addrToText bch + =<< textToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" + addr + `shouldBe` Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" + it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do + let addr = + addrToText bch + =<< textToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" + addr + `shouldBe` Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" + describe "base58 to cashaddr translation test vectors" $ do + it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do + let addr = + addrToText btc + =<< textToAddr + bch + "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" + addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" + it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do + let addr = + addrToText btc + =<< textToAddr + bch + "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" + addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" + it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do + let addr = + addrToText btc + =<< textToAddr + bch + "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" + addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" + it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do + let addr = + addrToText btc + =<< textToAddr + bch + "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" + addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" + it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do + let addr = + addrToText btc + =<< textToAddr + bch + "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" + addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" + it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do + let addr = + addrToText btc + =<< textToAddr + bch + "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" + addr `shouldBe` Just "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" + describe "cashaddr larger test vectors" $ + forM_ (zip [0 ..] vectors) $ \(i, vec) -> + it ("cashaddr test vector " <> show (i :: Int)) $ testCashAddr vec {- Various utilities -} testCashAddr :: (Int, CashVersion, Cash32, Text) -> Assertion testCashAddr (len, typ, addr, hex) = do - let mbs = decodeHex hex - assertBool "Could not decode hex payload from test vector" (isJust mbs) - let mlow = cash32decode addr - assertBool "Could not decode low level address" (isJust mlow) - let Just (_, lbs) = mlow - assertEqual "Low-level payload size incorrect" len (C.length lbs - 1) - assertEqual "Low-level payload doesn't match" bs (C.tail lbs) - let mdec = cash32decodeType addr - assertBool ("Could not decode test address: " <> cs addr) (isJust mdec) - assertEqual "Length doesn't match" len (C.length pay) - assertEqual "Version doesn't match" typ ver - assertEqual "Payload doesn't match" bs pay + let mbs = decodeHex hex + assertBool "Could not decode hex payload from test vector" (isJust mbs) + let mlow = cash32decode addr + assertBool "Could not decode low level address" (isJust mlow) + let Just (_, lbs) = mlow + assertEqual "Low-level payload size incorrect" len (Char8.length lbs - 1) + assertEqual "Low-level payload doesn't match" bs (Char8.tail lbs) + let mdec = cash32decodeType addr + assertBool ("Could not decode test address: " <> cs addr) (isJust mdec) + assertEqual "Length doesn't match" len (Char8.length pay) + assertEqual "Version doesn't match" typ ver + assertEqual "Payload doesn't match" bs pay where Just bs = decodeHex hex Just (_, ver, pay) = cash32decodeType addr -{- | All vectors starting with @pref@ had the wrong version in the spec - document. --} +-- | All vectors starting with @pref@ had the wrong version in the spec +-- document. vectors :: [(Int, CashVersion, Text, Text)] vectors = - [ - ( 20 - , 0 - , "bitcoincash:qr6m7j9njldwwzlg9v7v53unlr4jkmx6eylep8ekg2" - , "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" - ) - , - ( 20 - , 1 - , "bchtest:pr6m7j9njldwwzlg9v7v53unlr4jkmx6eyvwc0uz5t" - , "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" - ) - , - ( 20 - , 1 - , "pref:pr6m7j9njldwwzlg9v7v53unlr4jkmx6ey65nvtks5" - , "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" - ) - , - ( 20 - , 15 - , "prefix:0r6m7j9njldwwzlg9v7v53unlr4jkmx6ey3qnjwsrf" - , "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" - ) - , - ( 24 - , 0 - , "bitcoincash:q9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2ws4mr9g0" - , "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" - ) - , - ( 24 - , 1 - , "bchtest:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2u94tsynr" - , "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" - ) - , - ( 24 - , 1 - , "pref:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2khlwwk5v" - , "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" - ) - , - ( 24 - , 15 - , "prefix:09adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2p29kc2lp" - , "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" - ) - , - ( 28 - , 0 - , "bitcoincash:qgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcw59jxxuz" - , "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" - ) - , - ( 28 - , 1 - , "bchtest:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcvs7md7wt" - , "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" - ) - , - ( 28 - , 1 - , "pref:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcrsr6gzkn" - , "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" - ) - , - ( 28 - , 15 - , "prefix:0gagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkc5djw8s9g" - , "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" - ) - , - ( 32 - , 0 - , "bitcoincash:qvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq5nlegake" - , "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" - ) - , - ( 32 - , 1 - , "bchtest:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq7fqng6m6" - , "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" - ) - , - ( 32 - , 1 - , "pref:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq4k9m7qf9" - , "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" - ) - , - ( 32 - , 15 - , "prefix:0vch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxqsh6jgp6w" - , "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" - ) - , - ( 40 - , 0 - , "bitcoincash:qnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv39gr3uvz" - , "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" - ) - , - ( 40 - , 1 - , "bchtest:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvmgm6ynej" - , "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" - ) - , - ( 40 - , 1 - , "pref:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv0vx5z0w3" - , "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" - ) - , - ( 40 - , 15 - , "prefix:0nq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvwsvctzqy" - , "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" - ) - , - ( 48 - , 0 - , "bitcoincash:qh3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqex2w82sl" - , "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" - ) - , - ( 48 - , 1 - , "bchtest:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqnzf7mt6x" - , "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" - ) - , - ( 48 - , 1 - , "pref:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqjntdfcwg" - , "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" - ) - , - ( 48 - , 15 - , "prefix:0h3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqakcssnmn" - , "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" - ) - , - ( 56 - , 0 - , "bitcoincash:qmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqscw8jd03f" - , "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" - ) - , - ( 56 - , 1 - , "bchtest:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqs6kgdsg2g" - , "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" - ) - , - ( 56 - , 1 - , "pref:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsammyqffl" - , "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" - ) - , - ( 56 - , 15 - , "prefix:0mvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsgjrqpnw8" - , "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" - ) - , - ( 64 - , 0 - , "bitcoincash:qlg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mtky5sv5w" - , "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" - ) - , - ( 64 - , 1 - , "bchtest:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mc773cwez" - , "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" - ) - , - ( 64 - , 1 - , "pref:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mg7pj3lh8" - , "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" - ) - , - ( 64 - , 15 - , "prefix:0lg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96ms92w6845" - , "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" - ) - ] + [ ( 20, + 0, + "bitcoincash:qr6m7j9njldwwzlg9v7v53unlr4jkmx6eylep8ekg2", + "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" + ), + ( 20, + 1, + "bchtest:pr6m7j9njldwwzlg9v7v53unlr4jkmx6eyvwc0uz5t", + "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" + ), + ( 20, + 1, + "pref:pr6m7j9njldwwzlg9v7v53unlr4jkmx6ey65nvtks5", + "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" + ), + ( 20, + 15, + "prefix:0r6m7j9njldwwzlg9v7v53unlr4jkmx6ey3qnjwsrf", + "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" + ), + ( 24, + 0, + "bitcoincash:q9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2ws4mr9g0", + "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" + ), + ( 24, + 1, + "bchtest:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2u94tsynr", + "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" + ), + ( 24, + 1, + "pref:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2khlwwk5v", + "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" + ), + ( 24, + 15, + "prefix:09adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2p29kc2lp", + "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" + ), + ( 28, + 0, + "bitcoincash:qgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcw59jxxuz", + "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" + ), + ( 28, + 1, + "bchtest:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcvs7md7wt", + "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" + ), + ( 28, + 1, + "pref:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcrsr6gzkn", + "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" + ), + ( 28, + 15, + "prefix:0gagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkc5djw8s9g", + "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" + ), + ( 32, + 0, + "bitcoincash:qvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq5nlegake", + "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" + ), + ( 32, + 1, + "bchtest:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq7fqng6m6", + "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" + ), + ( 32, + 1, + "pref:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq4k9m7qf9", + "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" + ), + ( 32, + 15, + "prefix:0vch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxqsh6jgp6w", + "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" + ), + ( 40, + 0, + "bitcoincash:qnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv39gr3uvz", + "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" + ), + ( 40, + 1, + "bchtest:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvmgm6ynej", + "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" + ), + ( 40, + 1, + "pref:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv0vx5z0w3", + "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" + ), + ( 40, + 15, + "prefix:0nq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvwsvctzqy", + "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" + ), + ( 48, + 0, + "bitcoincash:qh3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqex2w82sl", + "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" + ), + ( 48, + 1, + "bchtest:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqnzf7mt6x", + "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" + ), + ( 48, + 1, + "pref:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqjntdfcwg", + "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" + ), + ( 48, + 15, + "prefix:0h3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqakcssnmn", + "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" + ), + ( 56, + 0, + "bitcoincash:qmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqscw8jd03f", + "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" + ), + ( 56, + 1, + "bchtest:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqs6kgdsg2g", + "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" + ), + ( 56, + 1, + "pref:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsammyqffl", + "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" + ), + ( 56, + 15, + "prefix:0mvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsgjrqpnw8", + "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" + ), + ( 64, + 0, + "bitcoincash:qlg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mtky5sv5w", + "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" + ), + ( 64, + 1, + "bchtest:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mc773cwez", + "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" + ), + ( 64, + 1, + "pref:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mg7pj3lh8", + "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" + ), + ( 64, + 15, + "prefix:0lg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96ms92w6845", + "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" + ) + ] diff --git a/test/Haskoin/AddressSpec.hs b/test/Haskoin/AddressSpec.hs index 11f4f452..ae9297de 100644 --- a/test/Haskoin/AddressSpec.hs +++ b/test/Haskoin/AddressSpec.hs @@ -1,16 +1,17 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} module Haskoin.AddressSpec (spec) where import Data.ByteString (ByteString) -import qualified Data.ByteString as BS (append, empty, pack) +import Data.ByteString qualified as B import Data.Maybe (fromJust, isJust) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Haskoin.Address -import Haskoin.Constants -import Haskoin.Data -import Haskoin.Keys +import Haskoin.Crypto +import Haskoin.Network.Constants +import Haskoin.Network.Data import Haskoin.Util import Haskoin.Util.Arbitrary import Test.HUnit @@ -26,178 +27,172 @@ readVals = [ReadBox arbitraryAddressAll] netVals :: [NetBox] netVals = - [NetBox (addrToJSON, addrToEncoding, addrFromJSON, arbitraryNetAddress)] + [NetBox (marshalValue, marshalEncoding, unmarshalValue, arbitraryNetAddress)] spec :: Spec -spec = do - testIdentity serialVals readVals [] netVals - describe "Address properties" $ do - prop "encodes and decodes base58 bytestring" $ - forAll arbitraryBS $ \bs -> - decodeBase58 (encodeBase58 bs) == Just bs - prop "encodes and decodes base58 bytestring with checksum" $ - forAll arbitraryBS $ \bs -> - decodeBase58Check (encodeBase58Check bs) == Just bs - prop "textToAddr . addrToText identity" $ - forAll arbitraryNetAddress $ \(net, a) -> - (textToAddr net =<< addrToText net a) == Just a - prop "outputAddress . addressToOutput identity" $ - forAll arbitraryAddress $ \a -> - outputAddress (addressToOutput a) == Just a - describe "Address vectors" $ do - it "Passes Base58 vectors 1" $ - mapM_ testVector vectors - it "Passes Base58 vectors 2" $ - mapM_ testBase58Vector base58Vectors - it "Passes Base58 invalid decoding vectors" $ - mapM_ testBase58InvalidVector base58InvalidVectors - it "Passes Base58Check invalid decoding vectors" $ - mapM_ testBase58ChkInvalidVector base58ChkInvalidVectors - it "Passes addresses witness p2sh(pwpkh) vectors" $ - mapM_ testCompatWitnessVector compatWitnessVectors +spec = prepareContext $ \ctx -> do + testIdentity serialVals readVals [] netVals + describe "Address properties" $ do + prop "encodes and decodes base58 bytestring" $ + forAll arbitraryBS $ \bs -> + decodeBase58 (encodeBase58 bs) == Just bs + prop "encodes and decodes base58 bytestring with checksum" $ + forAll arbitraryBS $ \bs -> + decodeBase58Check (encodeBase58Check bs) == Just bs + prop "textToAddr . addrToText identity" $ + forAll arbitraryNetAddress $ \(net, a) -> + (textToAddr net =<< addrToText net a) == Just a + prop "outputAddress . addressToOutput identity" $ + forAll arbitraryAddress $ \a -> + outputAddress ctx (addressToOutput a) == Just a + describe "Address vectors" $ do + it "Passes Base58 vectors 1" $ + mapM_ testVector vectors + it "Passes Base58 vectors 2" $ + mapM_ testBase58Vector base58Vectors + it "Passes Base58 invalid decoding vectors" $ + mapM_ testBase58InvalidVector base58InvalidVectors + it "Passes Base58Check invalid decoding vectors" $ + mapM_ testBase58ChkInvalidVector base58ChkInvalidVectors + it "Passes addresses witness p2sh(pwpkh) vectors" $ + mapM_ (testCompatWitnessVector ctx) compatWitnessVectors testVector :: (ByteString, Text, Text) -> Assertion testVector (bs, e, chk) = do - assertEqual "encodeBase58" e b58 - assertEqual "encodeBase58Check" chk b58Chk - assertEqual "decodeBase58" (Just bs) (decodeBase58 b58) - assertEqual "decodeBase58Check" (Just bs) (decodeBase58Check b58Chk) + assertEqual "encodeBase58" e b58 + assertEqual "encodeBase58Check" chk b58Chk + assertEqual "decodeBase58" (Just bs) (decodeBase58 b58) + assertEqual "decodeBase58Check" (Just bs) (decodeBase58Check b58Chk) where b58 = encodeBase58 bs b58Chk = encodeBase58Check bs vectors :: [(ByteString, Text, Text)] vectors = - [ (BS.empty, "", "3QJmnh") - , (BS.pack [0], "1", "1Wh4bh") - , (BS.pack [0, 0, 0, 0], "1111", "11114bdQda") - , (BS.pack [0, 0, 1, 0, 0], "11LUw", "113CUwsFVuo") - , (BS.pack [255], "5Q", "VrZDWwe") - , - ( BS.pack [0, 0, 0, 0] `BS.append` BS.pack [1 .. 255] - , "1111cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5N\ - \sBgNiFpWgAnEx6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vcc\ - \XWqKDvGv3u1GxFKPuAkn8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMv\ - \H3ZNLmP5fSG6DGbbi2tuwMWPthr4boWwCxf7ewSgNQeacyozhK\ - \DDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTcaB723LchjeKun7M\ - \uGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2pQPmHz4\ - \xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY" - , "111151KWPPBRzdWPr1ASeu172gVgLf1YfUp6VJyk6K9t4cLqYt\ - \FHcMa2iX8S3NJEprUcW7W5LvaPRpz7UG7puBj5STE3nKhCGt5e\ - \ckYq7mMn5nT7oTTic2BAX6zDdqrmGCnkszQkzkz8e5QLGDjf7K\ - \eQgtEDm4UER6DMSdBjFQVa6cHrrJn9myVyyhUrsVnfUk2WmNFZ\ - \vkWv3Tnvzo2cJ1xW62XDfUgYz1pd97eUGGPuXvDFfLsBVd1dfd\ - \UhPwxW7pMPgdWHTmg5uqKGFF6vE4xXpAqZTbTxRZjCDdTn68c2\ - \wrcxApm8hq3JX65Hix7VtcD13FF8b7BzBtwjXq1ze6NMjKgUcq\ - \pJTN9vt" - ) - ] + [ (B.empty, "", "3QJmnh"), + (B.pack [0], "1", "1Wh4bh"), + (B.pack [0, 0, 0, 0], "1111", "11114bdQda"), + (B.pack [0, 0, 1, 0, 0], "11LUw", "113CUwsFVuo"), + (B.pack [255], "5Q", "VrZDWwe"), + ( B.pack [0, 0, 0, 0] `B.append` B.pack [1 .. 255], + "1111cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5N\ + \sBgNiFpWgAnEx6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vcc\ + \XWqKDvGv3u1GxFKPuAkn8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMv\ + \H3ZNLmP5fSG6DGbbi2tuwMWPthr4boWwCxf7ewSgNQeacyozhK\ + \DDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTcaB723LchjeKun7M\ + \uGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2pQPmHz4\ + \xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY", + "111151KWPPBRzdWPr1ASeu172gVgLf1YfUp6VJyk6K9t4cLqYt\ + \FHcMa2iX8S3NJEprUcW7W5LvaPRpz7UG7puBj5STE3nKhCGt5e\ + \ckYq7mMn5nT7oTTic2BAX6zDdqrmGCnkszQkzkz8e5QLGDjf7K\ + \eQgtEDm4UER6DMSdBjFQVa6cHrrJn9myVyyhUrsVnfUk2WmNFZ\ + \vkWv3Tnvzo2cJ1xW62XDfUgYz1pd97eUGGPuXvDFfLsBVd1dfd\ + \UhPwxW7pMPgdWHTmg5uqKGFF6vE4xXpAqZTbTxRZjCDdTn68c2\ + \wrcxApm8hq3JX65Hix7VtcD13FF8b7BzBtwjXq1ze6NMjKgUcq\ + \pJTN9vt" + ) + ] -- Test vectors from: -- https://github.com/bitcoin/bitcoin/blob/master/src/test/data/base58_encode_decode.json testBase58Vector :: (Text, Text) -> Assertion testBase58Vector (a, b) = do - assertEqual "encodeBase58 match" b (encodeBase58 bsA) - assertEqual "decodeBase58 match" a (encodeHex bsB) - assertEqual "bytestring match" bsA bsB + assertEqual "encodeBase58 match" b (encodeBase58 bsA) + assertEqual "decodeBase58 match" a (encodeHex bsB) + assertEqual "bytestring match" bsA bsB where bsA = fromJust $ decodeHex a bsB = fromJust $ decodeBase58 b base58Vectors :: [(Text, Text)] base58Vectors = - [ ("", "") - , ("61", "2g") - , ("626262", "a3gV") - , ("636363", "aPEr") - , - ( "73696d706c792061206c6f6e6720737472696e67" - , "2cFupjhnEsSn59qHXstmK2ffpLv2" - ) - , - ( "00eb15231dfceb60925886b67d065299925915aeb172c06647" - , "1NS17iag9jJgTHD1VXjvLCEnZuQ3rJDE9L" - ) - , ("516b6fcd0f", "ABnLTmg") - , ("bf4f89001e670274dd", "3SEo3LWLoPntC") - , ("572e4794", "3EFU7m") - , ("ecac89cad93923c02321", "EJDM8drfXA6uyA") - , ("10c8511e", "Rt5zm") - , ("00000000000000000000", "1111111111") - , - ( "000111d38e5fc9071ffcd20b4a763cc9ae4f252bb4e48fd66a835e252a\ - \da93ff480d6dd43dc62a641155a5" - , "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" - ) - , - ( "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c\ - \1d1e1f202122232425262728292a2b2c2d2e2f30313233343536373839\ - \3a3b3c3d3e3f404142434445464748494a4b4c4d4e4f50515253545556\ - \5758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f70717273\ - \7475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f90\ - \9192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacad\ - \aeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9ca\ - \cbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7\ - \e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff" - , "1cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5NsBgNiFpWgAn\ - \Ex6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vccXWqKDvGv3u1GxFKPuAk\ - \n8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMvH3ZNLmP5fSG6DGbbi2tuwMWPthr\ - \4boWwCxf7ewSgNQeacyozhKDDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTc\ - \aB723LchjeKun7MuGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2\ - \pQPmHz4xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY" - ) - ] + [ ("", ""), + ("61", "2g"), + ("626262", "a3gV"), + ("636363", "aPEr"), + ( "73696d706c792061206c6f6e6720737472696e67", + "2cFupjhnEsSn59qHXstmK2ffpLv2" + ), + ( "00eb15231dfceb60925886b67d065299925915aeb172c06647", + "1NS17iag9jJgTHD1VXjvLCEnZuQ3rJDE9L" + ), + ("516b6fcd0f", "ABnLTmg"), + ("bf4f89001e670274dd", "3SEo3LWLoPntC"), + ("572e4794", "3EFU7m"), + ("ecac89cad93923c02321", "EJDM8drfXA6uyA"), + ("10c8511e", "Rt5zm"), + ("00000000000000000000", "1111111111"), + ( "000111d38e5fc9071ffcd20b4a763cc9ae4f252bb4e48fd66a835e252a\ + \da93ff480d6dd43dc62a641155a5", + "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" + ), + ( "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c\ + \1d1e1f202122232425262728292a2b2c2d2e2f30313233343536373839\ + \3a3b3c3d3e3f404142434445464748494a4b4c4d4e4f50515253545556\ + \5758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f70717273\ + \7475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f90\ + \9192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacad\ + \aeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9ca\ + \cbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7\ + \e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff", + "1cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5NsBgNiFpWgAn\ + \Ex6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vccXWqKDvGv3u1GxFKPuAk\ + \n8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMvH3ZNLmP5fSG6DGbbi2tuwMWPthr\ + \4boWwCxf7ewSgNQeacyozhKDDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTc\ + \aB723LchjeKun7MuGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2\ + \pQPmHz4xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY" + ) + ] -- Test vectors from: -- https://github.com/bitcoin/bitcoin/blob/master/src/test/base58_tests.cpp testBase58InvalidVector :: (Text, Maybe Text) -> Assertion testBase58InvalidVector (a, resM) = - assertEqual "decodeBase58 invalid match" resM (encodeHex <$> decodeBase58 a) + assertEqual "decodeBase58 invalid match" resM (encodeHex <$> decodeBase58 a) base58InvalidVectors :: [(Text, Maybe Text)] base58InvalidVectors = - [ ("invalid", Nothing) - , ("\0invalid", Nothing) - , ("good", Just "768320") - , ("bad0IOl", Nothing) - , ("goodbad0IOl", Nothing) - , ("good\0bad0IOl", Nothing) + [ ("invalid", Nothing), + ("\0invalid", Nothing), + ("good", Just "768320"), + ("bad0IOl", Nothing), + ("goodbad0IOl", Nothing), + ("good\0bad0IOl", Nothing) -- Haskoin does not remove white spaces before decoding base58 strings -- , (" \t\n\v\f\r skip \r\f\v\n\t a", Nothing) -- , (" \t\n\v\f\r skip \r\f\v\n\t ", Just "971a55") - ] + ] testBase58ChkInvalidVector :: (Text, Maybe Text) -> Assertion testBase58ChkInvalidVector (a, resM) = - assertEqual - "decodeBase58Check invalid match" - resM - (encodeHex <$> decodeBase58Check a) + assertEqual + "decodeBase58Check invalid match" + resM + (encodeHex <$> decodeBase58Check a) base58ChkInvalidVectors :: [(Text, Maybe Text)] base58ChkInvalidVectors = - [ ("3vQB7B6MrGQZaxCuFg4oh", Just "68656c6c6f20776f726c64") - , ("3vQB7B6MrGQZaxCuFg4oi", Nothing) - , ("3vQB7B6MrGQZaxCuFg4oh0IOl", Nothing) - , ("3vQB7B6MrGQZaxCuFg4oh\00IOl", Nothing) - ] + [ ("3vQB7B6MrGQZaxCuFg4oh", Just "68656c6c6f20776f726c64"), + ("3vQB7B6MrGQZaxCuFg4oi", Nothing), + ("3vQB7B6MrGQZaxCuFg4oh0IOl", Nothing), + ("3vQB7B6MrGQZaxCuFg4oh\00IOl", Nothing) + ] -testCompatWitnessVector :: (Network, Text, Text) -> Assertion -testCompatWitnessVector (net, seckey, addr) = do - let seckeyM = fromWif net seckey - assertBool "decode seckey" (isJust seckeyM) - let pubkey = derivePubKeyI (fromJust seckeyM) - let addrM = addrToText btcTest (pubKeyCompatWitnessAddr pubkey) - assertBool "address can be encoded" (isJust addrM) - assertEqual "witness address matches" addr (fromJust addrM) +testCompatWitnessVector :: Ctx -> (Network, Text, Text) -> Assertion +testCompatWitnessVector ctx (net, seckey, addr) = do + let seckeyM = fromWif net seckey + assertBool "decode seckey" (isJust seckeyM) + let pubkey = derivePublicKey ctx (fromJust seckeyM) + let addrM = addrToText btcTest (pubKeyCompatWitnessAddr ctx pubkey) + assertBool "address can be encoded" (isJust addrM) + assertEqual "witness address matches" addr (fromJust addrM) compatWitnessVectors :: [(Network, Text, Text)] compatWitnessVectors = - [ - ( btcTest - , "cNUnpYpMsJXYCERYBciJnsWBpcYEFjdcbq6dxj4SskGhs7uHuJ7Q" - , "2N6PDTueBHvXzW61B4oe5SW1D3v2Z3Vpbvw" - ) - ] + [ ( btcTest, + "cNUnpYpMsJXYCERYBciJnsWBpcYEFjdcbq6dxj4SskGhs7uHuJ7Q", + "2N6PDTueBHvXzW61B4oe5SW1D3v2Z3Vpbvw" + ) + ] diff --git a/test/Haskoin/BlockSpec.hs b/test/Haskoin/BlockSpec.hs index 4b744373..e4974f2f 100644 --- a/test/Haskoin/BlockSpec.hs +++ b/test/Haskoin/BlockSpec.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -module Haskoin.BlockSpec ( - spec, -) where +module Haskoin.BlockSpec + ( spec, + ) +where import Control.Monad.State.Strict import Data.Either (fromRight) @@ -12,9 +15,11 @@ import Data.String.Conversions (cs) import Data.Text (Text) import Data.Word (Word32) import Haskoin.Block -import Haskoin.Constants -import Haskoin.Data +import Haskoin.Crypto +import Haskoin.Network.Constants +import Haskoin.Network.Data import Haskoin.Transaction +import Haskoin.Util import Haskoin.Util.Arbitrary import Test.HUnit hiding (State) import Test.Hspec @@ -22,36 +27,36 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Printf (printf) -serialVals :: [SerialBox] -serialVals = - [ SerialBox (arbitraryBlock =<< arbitraryNetwork) - , SerialBox arbitraryBlockHash - , SerialBox arbitraryBlockHeader - , SerialBox arbitraryGetBlocks - , SerialBox arbitraryGetHeaders - , SerialBox arbitraryHeaders - , SerialBox arbitraryMerkleBlock - , SerialBox arbitraryBlockNode - ] +serialVals :: Ctx -> [SerialBox] +serialVals ctx = + [ SerialBox (flip arbitraryBlock ctx =<< arbitraryNetwork), + SerialBox arbitraryBlockHash, + SerialBox arbitraryBlockHeader, + SerialBox arbitraryGetBlocks, + SerialBox arbitraryGetHeaders, + SerialBox arbitraryHeaders, + SerialBox arbitraryMerkleBlock, + SerialBox arbitraryBlockNode + ] -readVals :: [ReadBox] -readVals = - [ ReadBox (arbitraryBlock =<< arbitraryNetwork) - , ReadBox arbitraryBlockHash - , ReadBox arbitraryBlockHeader - , ReadBox arbitraryGetBlocks - , ReadBox arbitraryGetHeaders - , ReadBox arbitraryHeaders - , ReadBox arbitraryMerkleBlock - , ReadBox arbitraryBlockNode - ] +readVals :: Ctx -> [ReadBox] +readVals ctx = + [ ReadBox (flip arbitraryBlock ctx =<< arbitraryNetwork), + ReadBox arbitraryBlockHash, + ReadBox arbitraryBlockHeader, + ReadBox arbitraryGetBlocks, + ReadBox arbitraryGetHeaders, + ReadBox arbitraryHeaders, + ReadBox arbitraryMerkleBlock, + ReadBox arbitraryBlockNode + ] -jsonVals :: [JsonBox] -jsonVals = - [ JsonBox (arbitraryBlock =<< arbitraryNetwork) - , JsonBox arbitraryBlockHash - , JsonBox arbitraryBlockHeader - ] +jsonVals :: Ctx -> [JsonBox] +jsonVals ctx = + [ JsonBox (flip arbitraryBlock ctx =<< arbitraryNetwork), + JsonBox arbitraryBlockHash, + JsonBox arbitraryBlockHeader + ] myTime :: Timestamp myTime = 1499083075 @@ -59,66 +64,66 @@ myTime = 1499083075 withChain :: Network -> State HeaderMemory a -> a withChain net f = evalState f (initialChain net) -chain :: BlockHeaders m => Network -> BlockHeader -> Int -> m () +chain :: (BlockHeaders m) => Network -> BlockHeader -> Int -> m () chain net bh i = do - bnsE <- connectBlocks net myTime bhs - either error (const $ return ()) bnsE + bnsE <- connectBlocks net myTime bhs + either error (const $ return ()) bnsE where bhs = appendBlocks net 6 bh i spec :: Spec -spec = do - testIdentity serialVals readVals jsonVals [] - describe "blockchain headers" $ do - it "gets best block on bchRegTest" $ - let net = bchRegTest - bb = - withChain net $ do - chain net (getGenesisHeader net) 100 - getBestBlockHeader - in nodeHeight bb `shouldBe` 100 - it "builds a block locator on bchRegTest" $ - let net = bchRegTest - loc = - withChain net $ do - chain net (getGenesisHeader net) 100 - bb <- getBestBlockHeader - blockLocatorNodes bb - heights = map nodeHeight loc - in heights `shouldBe` [100, 99 .. 90] <> [88, 84, 76, 60, 28, 0] - it "follows split chains on bchRegTest" $ - let net = bchRegTest - bb = withChain net $ splitChain net >> getBestBlockHeader - in nodeHeight bb `shouldBe` 4035 - describe "block hash" $ do - prop "encodes and decodes block hash" $ - forAll arbitraryBlockHash $ \h -> - hexToBlockHash (blockHashToHex h) == Just h - prop "from string block hash" $ - forAll arbitraryBlockHash $ \h -> - fromString (cs $ blockHashToHex h) == h - describe "merkle trees" $ do - prop "builds tree of right width at height 1" testTreeWidth - prop "builds tree of right width at height 0" testBaseWidth - prop "builds and extracts partial merkle tree" $ - forAll arbitraryNetwork $ \net -> - forAll - (listOf1 ((,) <$> arbitraryTxHash <*> arbitrary)) - (buildExtractTree net) - it "merkle root test vectors" $ mapM_ runMerkleVector merkleVectors - describe "compact number" $ do - it "compact number local vectors" testCompact - it "compact number imported vectors" testCompactBitcoinCore - describe "asert" $ - mapM_ - ( \x -> - asertTests $ - "test_vectors_aserti3-2d_run" ++ printf "%02d" x ++ ".txt" - ) - [(1 :: Int) .. 12] - describe "helper functions" $ do - it "computes bitcoin block subsidy correctly" (testSubsidy btc) - it "computes regtest block subsidy correctly" (testSubsidy btcRegTest) +spec = prepareContext $ \ctx -> do + testIdentity (serialVals ctx) (readVals ctx) (jsonVals ctx) [] + describe "blockchain headers" $ do + it "gets best block on bchRegTest" $ + let net = bchRegTest + bb = + withChain net $ do + chain net net.genesisHeader 100 + getBestBlockHeader + in bb.height `shouldBe` 100 + it "builds a block locator on bchRegTest" $ + let net = bchRegTest + loc = + withChain net $ do + chain net net.genesisHeader 100 + bb <- getBestBlockHeader + blockLocatorNodes bb + heights = map (.height) loc + in heights `shouldBe` [100, 99 .. 90] <> [88, 84, 76, 60, 28, 0] + it "follows split chains on bchRegTest" $ + let net = bchRegTest + bb = withChain net $ splitChain net >> getBestBlockHeader + in bb.height `shouldBe` 4035 + describe "block hash" $ do + prop "encodes and decodes block hash" $ + forAll arbitraryBlockHash $ \h -> + hexToBlockHash (blockHashToHex h) == Just h + prop "from string block hash" $ + forAll arbitraryBlockHash $ \h -> + fromString (cs $ blockHashToHex h) == h + describe "merkle trees" $ do + prop "builds tree of right width at height 1" testTreeWidth + prop "builds tree of right width at height 0" testBaseWidth + prop "builds and extracts partial merkle tree" $ + forAll arbitraryNetwork $ \net -> + forAll + (listOf1 ((,) <$> arbitraryTxHash <*> arbitrary)) + (buildExtractTree net) + it "merkle root test vectors" $ mapM_ runMerkleVector merkleVectors + describe "compact number" $ do + it "compact number local vectors" testCompact + it "compact number imported vectors" testCompactBitcoinCore + describe "asert" $ + mapM_ + ( \x -> + asertTests $ + "test_vectors_aserti3-2d_run" ++ printf "%02d" x ++ ".txt" + ) + [(1 :: Int) .. 12] + describe "helper functions" $ do + it "computes bitcoin block subsidy correctly" (testSubsidy btc) + it "computes regtest block subsidy correctly" (testSubsidy btcRegTest) -- 0 → → 2015 → → → → → → → 4031 -- ↓ @@ -127,40 +132,40 @@ spec = do -- → → 2185 splitChain :: Network -> State HeaderMemory () splitChain net = do - start <- go 1 (getGenesisHeader net) 2015 - e 2015 (head start) - tail1 <- go 2 (nodeHeader $ head start) 2016 - e 4031 (head tail1) - tail2 <- go 3 (nodeHeader $ head start) 20 - e 2035 (head tail2) - tail3 <- go 4 (nodeHeader $ head tail2) 2000 - e 4035 (head tail3) - tail4 <- go 5 (nodeHeader $ head tail2) 150 - e 2185 (head tail4) - sp1 <- splitPoint (head tail1) (head tail3) - unless (sp1 == head start) $ - error $ - "Split point wrong between blocks 4031 and 4035: " - ++ show (nodeHeight sp1) - sp2 <- splitPoint (head tail4) (head tail3) - unless (sp2 == head tail2) $ - error $ - "Split point wrong between blocks 2185 and 4035: " - ++ show (nodeHeight sp2) + start <- go 1 net.genesisHeader 2015 + e 2015 (head start) + tail1 <- go 2 (head start).header 2016 + e 4031 (head tail1) + tail2 <- go 3 (head start).header 20 + e 2035 (head tail2) + tail3 <- go 4 (head tail2).header 2000 + e 4035 (head tail3) + tail4 <- go 5 (head tail2).header 150 + e 2185 (head tail4) + sp1 <- splitPoint (head tail1) (head tail3) + unless (sp1 == head start) $ + error $ + "Split point wrong between blocks 4031 and 4035: " + ++ show sp1.height + sp2 <- splitPoint (head tail4) (head tail3) + unless (sp2 == head tail2) $ + error $ + "Split point wrong between blocks 2185 and 4035: " + ++ show sp2.height where - e n bn = - unless (nodeHeight bn == n) $ - error $ - "Node height " - ++ show (nodeHeight bn) - ++ " of first chunk should be " - ++ show n + e n bn@BlockNode {} = + unless (bn.height == n) $ + error $ + "Node height " + ++ show bn.height + ++ " of first chunk should be " + ++ show n go seed start n = do - let bhs = appendBlocks net seed start n - bnE <- connectBlocks net myTime bhs - case bnE of - Right bn -> return bn - Left ex -> error ex + let bhs = appendBlocks net seed start n + bnE <- connectBlocks net myTime bhs + case bnE of + Right bn -> return bn + Left ex -> error ex {- Merkle Trees -} @@ -172,214 +177,208 @@ testBaseWidth i = i /= 0 ==> calcTreeWidth (abs i) 0 == abs i buildExtractTree :: Network -> [(TxHash, Bool)] -> Bool buildExtractTree net txs = - r == buildMerkleRoot (map fst txs) && m == map fst (filter snd txs) + r == buildMerkleRoot (map fst txs) && m == map fst (filter snd txs) where (f, h) = buildPartialMerkle txs (r, m) = - fromRight (error "Could not extract matches from Merkle tree") $ - extractMatches net f h (length txs) + fromRight (error "Could not extract matches from Merkle tree") $ + extractMatches net f h (length txs) testCompact :: Assertion testCompact = do - assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000) - assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456) - assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000) - assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de) - assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000)) - assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00) + assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000) + assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456) + assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000) + assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de) + assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000)) + assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00) testCompactBitcoinCore :: Assertion testCompactBitcoinCore = do - assertEqual "zero" (0, False) (decodeCompact 0x00000000) - assertEqual - "zero (encode · decode)" - 0x00000000 - (encodeCompact . fst $ decodeCompact 0x00000000) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000) - assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456) - assertEqual - "vector 1 (encode · decode)" - 0x01120000 - (encodeCompact . fst $ decodeCompact 0x01123456) - assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80) - assertEqual - "vector 2 (negative) (decode)" - (-0x7e, False) - (decodeCompact 0x01fedcba) - assertEqual - "vector 2 (negative) (encode · decode)" - 0x01fe0000 - (encodeCompact . fst $ decodeCompact 0x01fedcba) - assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456) - assertEqual - "vector 3 (encode · decode)" - 0x02123400 - (encodeCompact . fst $ decodeCompact 0x02123456) - assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456) - assertEqual - "vector 4 (encode · decode)" - 0x03123456 - (encodeCompact . fst $ decodeCompact 0x03123456) - assertEqual - "vector 5 (decode)" - (0x12345600, False) - (decodeCompact 0x04123456) - assertEqual - "vector 5 (encode · decode)" - 0x04123456 - (encodeCompact . fst $ decodeCompact 0x04123456) - assertEqual - "vector 6 (decode)" - (-0x12345600, False) - (decodeCompact 0x04923456) - assertEqual - "vector 6 (encode · decode)" - 0x04923456 - (encodeCompact . fst $ decodeCompact 0x04923456) - assertEqual - "vector 7 (decode)" - (0x92340000, False) - (decodeCompact 0x05009234) - assertEqual - "vector 7 (encode · decode)" - 0x05009234 - (encodeCompact . fst $ decodeCompact 0x05009234) - assertEqual - "vector 8 (decode)" - ( 0x1234560000000000000000000000000000000000000000000000000000000000 - , False - ) - (decodeCompact 0x20123456) - assertEqual - "vector 8 (encode · decode)" - 0x20123456 - (encodeCompact . fst $ decodeCompact 0x20123456) - assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456) - assertBool - "vector 9 (decode) (positive)" - ((> 0) . fst $ decodeCompact 0xff123456) + assertEqual "zero" (0, False) (decodeCompact 0x00000000) + assertEqual + "zero (encode · decode)" + 0x00000000 + (encodeCompact . fst $ decodeCompact 0x00000000) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000) + assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456) + assertEqual + "vector 1 (encode · decode)" + 0x01120000 + (encodeCompact . fst $ decodeCompact 0x01123456) + assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80) + assertEqual + "vector 2 (negative) (decode)" + (-0x7e, False) + (decodeCompact 0x01fedcba) + assertEqual + "vector 2 (negative) (encode · decode)" + 0x01fe0000 + (encodeCompact . fst $ decodeCompact 0x01fedcba) + assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456) + assertEqual + "vector 3 (encode · decode)" + 0x02123400 + (encodeCompact . fst $ decodeCompact 0x02123456) + assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456) + assertEqual + "vector 4 (encode · decode)" + 0x03123456 + (encodeCompact . fst $ decodeCompact 0x03123456) + assertEqual + "vector 5 (decode)" + (0x12345600, False) + (decodeCompact 0x04123456) + assertEqual + "vector 5 (encode · decode)" + 0x04123456 + (encodeCompact . fst $ decodeCompact 0x04123456) + assertEqual + "vector 6 (decode)" + (-0x12345600, False) + (decodeCompact 0x04923456) + assertEqual + "vector 6 (encode · decode)" + 0x04923456 + (encodeCompact . fst $ decodeCompact 0x04923456) + assertEqual + "vector 7 (decode)" + (0x92340000, False) + (decodeCompact 0x05009234) + assertEqual + "vector 7 (encode · decode)" + 0x05009234 + (encodeCompact . fst $ decodeCompact 0x05009234) + assertEqual + "vector 8 (decode)" + ( 0x1234560000000000000000000000000000000000000000000000000000000000, + False + ) + (decodeCompact 0x20123456) + assertEqual + "vector 8 (encode · decode)" + 0x20123456 + (encodeCompact . fst $ decodeCompact 0x20123456) + assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456) + assertBool + "vector 9 (decode) (positive)" + ((> 0) . fst $ decodeCompact 0xff123456) runMerkleVector :: (Text, [Text]) -> Assertion runMerkleVector (r, hs) = - assertBool "merkle vector" $ - buildMerkleRoot (map f hs) == getTxHash (f r) + assertBool "merkle vector" $ + buildMerkleRoot (map f hs) == (f r).get where f = fromJust . hexToTxHash merkleVectors :: [(Text, [Text])] merkleVectors = - -- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1 - [ - ( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f" - , - [ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52" - , "1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9" - , "a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41" - , "d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f" - , "5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6" - , "ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc" - , "056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3" - , "05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66" - , "b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f" - , "3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4" - , "2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3" - ] - ) - , -- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4 + -- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1 + [ ( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f", + [ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52", + "1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9", + "a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41", + "d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f", + "5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6", + "ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc", + "056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3", + "05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66", + "b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f", + "3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4", + "2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3" + ] + ), + -- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4 - ( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c" - , - [ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e" - , "20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51" - , "d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a" - , "ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e" - , "9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471" - , "86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3" - , "11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030" - , "2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13" - , "37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2" - , "0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8" - ] - ) - , -- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048 + ( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c", + [ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e", + "20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51", + "d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a", + "ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e", + "9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471", + "86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3", + "11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030", + "2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13", + "37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2", + "0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8" + ] + ), + -- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048 - ( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098" - , ["0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098"] - ) - , -- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c + ( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098", + ["0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098"] + ), + -- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c - ( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c" - , - [ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028" - , "45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b" - ] - ) - , -- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e + ( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c", + [ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028", + "45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b" + ] + ), + -- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e - ( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c" - , - [ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549" - , "11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb" - , "d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633" - ] - ) - , -- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021 + ( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c", + [ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549", + "11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb", + "d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633" + ] + ), + -- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021 - ( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2" - , - [ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81" - , "24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92" - , "e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27" - , "540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a" - , "324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924" - , "e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2" - , "a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95" - , "7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4" - , "2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d" - , "3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f" - , "de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909" - , "c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d" - , "77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53" - , "4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b" - , "38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174" - , "648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494" - , "9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4" - , "6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa" - , "f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d" - , "e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6" - , "c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9" - , "6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55" - , "98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776" - , "2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d" - , "ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666" - , "410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f" - , "e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9" - , "a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4" - , "8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f" - ] - ) - ] + ( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2", + [ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81", + "24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92", + "e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27", + "540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a", + "324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924", + "e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2", + "a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95", + "7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4", + "2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d", + "3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f", + "de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909", + "c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d", + "77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53", + "4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b", + "38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174", + "648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494", + "9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4", + "6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa", + "f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d", + "e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6", + "c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9", + "6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55", + "98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776", + "2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d", + "ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666", + "410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f", + "e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9", + "a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4", + "8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f" + ] + ) + ] testSubsidy :: Network -> Assertion testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0 where go previous_subsidy halvings = do - let height = halvings * getHalvingInterval net - subsidy = computeSubsidy net height - if halvings >= 64 - then subsidy `shouldBe` 0 - else do - subsidy `shouldBe` (previous_subsidy `div` 2) - go subsidy (halvings + 1) + let height = halvings * net.halvingInterval + subsidy = computeSubsidy net height + if halvings >= 64 + then subsidy `shouldBe` 0 + else do + subsidy `shouldBe` (previous_subsidy `div` 2) + go subsidy (halvings + 1) data AsertBlock = AsertBlock Int Integer Integer Word32 @@ -387,34 +386,34 @@ data AsertVector = AsertVector String Integer Integer Word32 [AsertBlock] readAsertVector :: FilePath -> IO AsertVector readAsertVector p = do - (d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p) - let desc = drop 16 d - anchor_height = read (words ah !! 3) - anchor_parent_time = read (words apt !! 4) - anchor_nbits = read (words ab !! 3) - blocks = map (f . words) (init xs) - return $ - AsertVector - desc - anchor_height - anchor_parent_time - anchor_nbits - blocks + (d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p) + let desc = drop 16 d + anchor_height = read (words ah !! 3) + anchor_parent_time = read (words apt !! 4) + anchor_nbits = read (words ab !! 3) + blocks = map (f . words) (init xs) + return $ + AsertVector + desc + anchor_height + anchor_parent_time + anchor_nbits + blocks where f [i, h, t, g] = AsertBlock (read i) (read h) (read t) (read g) f _ = undefined asertTests :: FilePath -> SpecWith () asertTests file = do - v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file - it d $ testAsertBits v + v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file + it d $ testAsertBits v testAsertBits :: AsertVector -> Assertion testAsertBits (AsertVector _ anchor_height anchor_parent_time anchor_bits blocks) = - forM_ blocks $ \(AsertBlock _ h t g) -> - computeAsertBits - (2 * 24 * 60 * 60) - anchor_bits - (t - anchor_parent_time) - (h - anchor_height) - `shouldBe` g + forM_ blocks $ \(AsertBlock _ h t g) -> + computeAsertBits + (2 * 24 * 60 * 60) + anchor_bits + (t - anchor_parent_time) + (h - anchor_height) + `shouldBe` g diff --git a/test/Haskoin/Crypto/HashSpec.hs b/test/Haskoin/Crypto/HashSpec.hs index a97992c7..60541bf4 100644 --- a/test/Haskoin/Crypto/HashSpec.hs +++ b/test/Haskoin/Crypto/HashSpec.hs @@ -1,13 +1,16 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} module Haskoin.Crypto.HashSpec (spec) where import Data.Bits import Data.ByteString (ByteString) import Data.ByteString.Builder -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Short as BSS +import Data.ByteString.Char8 qualified as Char8 +import Data.ByteString.Lazy qualified as Lazy +import Data.ByteString.Short qualified as Short import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -27,51 +30,52 @@ import Test.QuickCheck serialVals :: [SerialBox] serialVals = - [ SerialBox arbitraryBS - , SerialBox arbitraryHash160 - , SerialBox arbitraryHash256 - , SerialBox arbitraryHash512 - ] + [ SerialBox arbitraryBS, + SerialBox arbitraryHash160, + SerialBox arbitraryHash256, + SerialBox arbitraryHash512 + ] readVals :: [ReadBox] readVals = - [ ReadBox arbitraryBS - , ReadBox arbitraryBSS - , ReadBox arbitraryHash160 - , ReadBox arbitraryHash256 - , ReadBox arbitraryHash512 - ] + [ ReadBox arbitraryBS, + ReadBox arbitraryBSS, + ReadBox arbitraryHash160, + ReadBox arbitraryHash256, + ReadBox arbitraryHash512 + ] spec :: Spec spec = - describe "Hash" $ do - testIdentity serialVals readVals [] [] - describe "Property Tests" $ do - prop "join512( split512(h) ) == h" $ - forAll arbitraryHash256 $ forAll arbitraryHash256 . joinSplit512 - prop "decodeCompact . encodeCompact i == i" decEncCompact - prop "from string Hash512" $ - forAll arbitraryHash512 $ \h -> - fromString (cs $ encodeHex $ runPutS $ serialize h) == h - prop "from string Hash256" $ - forAll arbitraryHash256 $ \h -> - fromString (cs $ encodeHex $ runPutS $ serialize h) == h - prop "from string Hash160" $ - forAll arbitraryHash160 $ \h -> - fromString (cs $ encodeHex $ runPutS $ serialize h) == h - describe "Test Vectors" $ do - it "Passes RIPEMD160 test vectors" $ - mapM_ (testVector ripemd160 getHash160) ripemd160Vectors - it "Passes SHA1 test vectors" $ - mapM_ (testVector sha1 getHash160) sha1Vectors - it "Passes SHA256 test vectors" $ - mapM_ (testVector sha256 getHash256) sha256Vectors - it "Passes SHA512 test vectors" $ - mapM_ (testVector sha512 getHash512) sha512Vectors - it "Passes HMAC_SHA256 test vectors" $ - mapM_ (testHMACVector hmac256 getHash256) hmacSha256Vectors - it "Passes HMAC_SHA512 test vectors" $ - mapM_ (testHMACVector hmac512 getHash512) hmacSha512Vectors + describe "Hash" $ do + testIdentity serialVals readVals [] [] + describe "Property Tests" $ do + prop "join512( split512(h) ) == h" $ + forAll arbitraryHash256 $ + forAll arbitraryHash256 . joinSplit512 + prop "decodeCompact . encodeCompact i == i" decEncCompact + prop "from string Hash512" $ + forAll arbitraryHash512 $ \h -> + fromString (cs $ encodeHex $ runPutS $ serialize h) == h + prop "from string Hash256" $ + forAll arbitraryHash256 $ \h -> + fromString (cs $ encodeHex $ runPutS $ serialize h) == h + prop "from string Hash160" $ + forAll arbitraryHash160 $ \h -> + fromString (cs $ encodeHex $ runPutS $ serialize h) == h + describe "Test Vectors" $ do + it "Passes RIPEMD160 test vectors" $ + mapM_ (testVector ripemd160 (.get)) ripemd160Vectors + it "Passes SHA1 test vectors" $ + mapM_ (testVector sha1 (.get)) sha1Vectors + it "Passes SHA256 test vectors" $ + mapM_ (testVector sha256 (.get)) sha256Vectors + it "Passes SHA512 test vectors" $ + mapM_ (testVector sha512 (.get)) sha512Vectors + it "Passes HMAC_SHA256 test vectors" $ + mapM_ (testHMACVector hmac256 (.get)) hmacSha256Vectors + it "Passes HMAC_SHA512 test vectors" $ + mapM_ (testHMACVector hmac512 (.get)) hmacSha512Vectors joinSplit512 :: Hash256 -> Hash256 -> Bool joinSplit512 a b = split512 (join512 (a, b)) == (a, b) @@ -80,358 +84,317 @@ joinSplit512 a b = split512 (join512 (a, b)) == (a, b) -- to the old one. decEncCompact :: Integer -> Bool decEncCompact i - -- Integer completely fits inside the mantisse - | abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False) - -- Otherwise precision will be lost and the decoded result will - -- be smaller than the original number - | i >= 0 = fst (decodeCompact (encodeCompact i)) < i - | otherwise = fst (decodeCompact (encodeCompact i)) > i + -- Integer completely fits inside the mantisse + | abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False) + -- Otherwise precision will be lost and the decoded result will + -- be smaller than the original number + | i >= 0 = fst (decodeCompact (encodeCompact i)) < i + | otherwise = fst (decodeCompact (encodeCompact i)) > i -- Test vectors from: -- https://github.com/bitcoin/bitcoin/blob/master/src/test/crypto_tests.cpp testVector :: - (ByteString -> a) -> - (a -> BSS.ShortByteString) -> - (ByteString, Text) -> - Assertion + (ByteString -> a) -> + (a -> Short.ShortByteString) -> + (ByteString, Text) -> + Assertion testVector f1 f2 (i, res) = - assertEqual "Hash matches" res (encodeHex (BSS.fromShort $ f2 $ f1 i)) + assertEqual "Hash matches" res (encodeHex (Short.fromShort $ f2 $ f1 i)) testHMACVector :: - (ByteString -> ByteString -> a) -> - (a -> BSS.ShortByteString) -> - (Text, Text, Text) -> - Assertion + (ByteString -> ByteString -> a) -> + (a -> Short.ShortByteString) -> + (Text, Text, Text) -> + Assertion testHMACVector f1 f2 (k, m, res) = - assertEqual "Hash matches" res (encodeHex (BSS.fromShort $ f2 $ f1 bsK bsM)) + assertEqual "Hash matches" res (encodeHex (Short.fromShort $ f2 $ f1 bsK bsM)) where bsK = fromJust $ decodeHex k bsM = fromJust $ decodeHex m longTestString :: ByteString longTestString = - BL.toStrict $! toLazyByteString $! go [0 .. 199999] + Lazy.toStrict $! toLazyByteString $! go [0 .. 199999] where go :: [Word32] -> Builder go [] = mempty go (i : is) = - let i1 = fromIntegral $! i - i2 = fromIntegral $! i `shiftR` 4 - i3 = fromIntegral $! i `shiftR` 8 - i4 = fromIntegral $! i `shiftR` 12 - i5 = fromIntegral $! i `shiftR` 16 - in word8 i1 <> word8 i2 <> word8 i3 <> word8 i4 <> word8 i5 <> go is + let i1 = fromIntegral $! i + i2 = fromIntegral $! i `shiftR` 4 + i3 = fromIntegral $! i `shiftR` 8 + i4 = fromIntegral $! i `shiftR` 12 + i5 = fromIntegral $! i `shiftR` 16 + in word8 i1 <> word8 i2 <> word8 i3 <> word8 i4 <> word8 i5 <> go is ripemd160Vectors :: [(ByteString, Text)] ripemd160Vectors = - [ ("", "9c1185a5c5e9fc54612808977ee8f548b2258d31") - , ("abc", "8eb208f7e05d987a9b044a8e98c6b087f15a0bfc") - , ("message digest", "5d0689ef49d2fae572b881b123a85ffa21595f36") - , ("secure hash algorithm", "20397528223b6a5f4cbc2808aba0464e645544f9") - , - ( "RIPEMD160 is considered to be safe" - , "a7d78608c7af8a8e728778e81576870734122b66" - ) - , - ( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" - , "12a053384a9c0c88e405a06c27dcf49ada62eb2b" - ) - , - ( "For this sample, this 63-byte string will be used as input data" - , "de90dbfee14b63fb5abf27c2ad4a82aaa5f27a11" - ) - , - ( "This is exactly 64 bytes long, not counting the terminating byte" - , "eda31d51d3a623b81e19eb02e24ff65d27d67b37" - ) - , (C.replicate 1000000 'a', "52783243c1697bdbe16d37f97f68f08325dc1528") - , (longTestString, "464243587bd146ea835cdf57bdae582f25ec45f1") - ] + [ ("", "9c1185a5c5e9fc54612808977ee8f548b2258d31"), + ("abc", "8eb208f7e05d987a9b044a8e98c6b087f15a0bfc"), + ("message digest", "5d0689ef49d2fae572b881b123a85ffa21595f36"), + ("secure hash algorithm", "20397528223b6a5f4cbc2808aba0464e645544f9"), + ( "RIPEMD160 is considered to be safe", + "a7d78608c7af8a8e728778e81576870734122b66" + ), + ( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq", + "12a053384a9c0c88e405a06c27dcf49ada62eb2b" + ), + ( "For this sample, this 63-byte string will be used as input data", + "de90dbfee14b63fb5abf27c2ad4a82aaa5f27a11" + ), + ( "This is exactly 64 bytes long, not counting the terminating byte", + "eda31d51d3a623b81e19eb02e24ff65d27d67b37" + ), + (Char8.replicate 1000000 'a', "52783243c1697bdbe16d37f97f68f08325dc1528"), + (longTestString, "464243587bd146ea835cdf57bdae582f25ec45f1") + ] sha1Vectors :: [(ByteString, Text)] sha1Vectors = - [ ("", "da39a3ee5e6b4b0d3255bfef95601890afd80709") - , ("abc", "a9993e364706816aba3e25717850c26c9cd0d89d") - , ("message digest", "c12252ceda8be8994d5fa0290a47231c1d16aae3") - , ("secure hash algorithm", "d4d6d2f0ebe317513bbd8d967d89bac5819c2f60") - , - ( "SHA1 is considered to be safe" - , "f2b6650569ad3a8720348dd6ea6c497dee3a842a" - ) - , - ( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" - , "84983e441c3bd26ebaae4aa1f95129e5e54670f1" - ) - , - ( "For this sample, this 63-byte string will be used as input data" - , "4f0ea5cd0585a23d028abdc1a6684e5a8094dc49" - ) - , - ( "This is exactly 64 bytes long, not counting the terminating byte" - , "fb679f23e7d1ce053313e66e127ab1b444397057" - ) - , (C.replicate 1000000 'a', "34aa973cd4c4daa4f61eeb2bdbad27316534016f") - , (longTestString, "b7755760681cbfd971451668f32af5774f4656b5") - ] + [ ("", "da39a3ee5e6b4b0d3255bfef95601890afd80709"), + ("abc", "a9993e364706816aba3e25717850c26c9cd0d89d"), + ("message digest", "c12252ceda8be8994d5fa0290a47231c1d16aae3"), + ("secure hash algorithm", "d4d6d2f0ebe317513bbd8d967d89bac5819c2f60"), + ( "SHA1 is considered to be safe", + "f2b6650569ad3a8720348dd6ea6c497dee3a842a" + ), + ( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq", + "84983e441c3bd26ebaae4aa1f95129e5e54670f1" + ), + ( "For this sample, this 63-byte string will be used as input data", + "4f0ea5cd0585a23d028abdc1a6684e5a8094dc49" + ), + ( "This is exactly 64 bytes long, not counting the terminating byte", + "fb679f23e7d1ce053313e66e127ab1b444397057" + ), + (Char8.replicate 1000000 'a', "34aa973cd4c4daa4f61eeb2bdbad27316534016f"), + (longTestString, "b7755760681cbfd971451668f32af5774f4656b5") + ] sha256Vectors :: [(ByteString, Text)] sha256Vectors = - [ ("", "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855") - , - ( "abc" - , "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" - ) - , - ( "message digest" - , "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" - ) - , - ( "secure hash algorithm" - , "f30ceb2bb2829e79e4ca9753d35a8ecc00262d164cc077080295381cbd643f0d" - ) - , - ( "SHA256 is considered to be safe" - , "6819d915c73f4d1e77e4e1b52d1fa0f9cf9beaead3939f15874bd988e2a23630" - ) - , - ( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" - , "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1" - ) - , - ( "For this sample, this 63-byte string will be used as input data" - , "f08a78cbbaee082b052ae0708f32fa1e50c5c421aa772ba5dbb406a2ea6be342" - ) - , - ( "This is exactly 64 bytes long, not counting the terminating byte" - , "ab64eff7e88e2e46165e29f2bce41826bd4c7b3552f6b382a9e7d3af47c245f8" - ) - , - ( "As Bitcoin relies on 80 byte header hashes, we want to have an example for that." - , "7406e8de7d6e4fffc573daef05aefb8806e7790f55eab5576f31349743cca743" - ) - , - ( C.replicate 1000000 'a' - , "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0" - ) - , - ( longTestString - , "a316d55510b49662420f49d145d42fb83f31ef8dc016aa4e32df049991a91e26" - ) - ] + [ ("", "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"), + ( "abc", + "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" + ), + ( "message digest", + "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" + ), + ( "secure hash algorithm", + "f30ceb2bb2829e79e4ca9753d35a8ecc00262d164cc077080295381cbd643f0d" + ), + ( "SHA256 is considered to be safe", + "6819d915c73f4d1e77e4e1b52d1fa0f9cf9beaead3939f15874bd988e2a23630" + ), + ( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq", + "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1" + ), + ( "For this sample, this 63-byte string will be used as input data", + "f08a78cbbaee082b052ae0708f32fa1e50c5c421aa772ba5dbb406a2ea6be342" + ), + ( "This is exactly 64 bytes long, not counting the terminating byte", + "ab64eff7e88e2e46165e29f2bce41826bd4c7b3552f6b382a9e7d3af47c245f8" + ), + ( "As Bitcoin relies on 80 byte header hashes, we want to have an example for that.", + "7406e8de7d6e4fffc573daef05aefb8806e7790f55eab5576f31349743cca743" + ), + ( Char8.replicate 1000000 'a', + "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0" + ), + ( longTestString, + "a316d55510b49662420f49d145d42fb83f31ef8dc016aa4e32df049991a91e26" + ) + ] sha512Vectors :: [(ByteString, Text)] sha512Vectors = - [ - ( "" - , "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d1\ - \3c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e" - ) - , - ( "abc" - , "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a219299\ - \2a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f" - ) - , - ( "message digest" - , "107dbf389d9e9f71a3a95f6c055b9251bc5268c2be16d6c13492ea45b0199f3309e164\ - \55ab1e96118e8a905d5597b72038ddb372a89826046de66687bb420e7c" - ) - , - ( "secure hash algorithm" - , "7746d91f3de30c68cec0dd693120a7e8b04d8073cb699bdce1a3f64127bca7a3d5db50\ - \2e814bb63c063a7a5043b2df87c61133395f4ad1edca7fcf4b30c3236e" - ) - , - ( "SHA512 is considered to be safe" - , "099e6468d889e1c79092a89ae925a9499b5408e01b66cb5b0a3bd0dfa51a99646b4a39\ - \01caab1318189f74cd8cf2e941829012f2449df52067d3dd5b978456c2" - ) - , - ( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" - , "204a8fc6dda82f0a0ced7beb8e08a41657c16ef468b228a8279be331a703c33596fd15\ - \c13b1b07f9aa1d3bea57789ca031ad85c7a71dd70354ec631238ca3445" - ) - , - ( "For this sample, this 63-byte string will be used as input data" - , "b3de4afbc516d2478fe9b518d063bda6c8dd65fc38402dd81d1eb7364e72fb6e6663cf\ - \6d2771c8f5a6da09601712fb3d2a36c6ffea3e28b0818b05b0a8660766" - ) - , - ( "This is exactly 64 bytes long, not counting the terminating byte" - , "70aefeaa0e7ac4f8fe17532d7185a289bee3b428d950c14fa8b713ca09814a387d2458\ - \70e007a80ad97c369d193e41701aa07f3221d15f0e65a1ff970cedf030" - ) - , - ( "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmn\ - \opjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" - , "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d28\ - \9e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" - ) - , - ( C.replicate 1000000 'a' - , "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973ebde0ff2\ - \44877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b" - ) - , - ( longTestString - , "40cac46c147e6131c5193dd5f34e9d8bb4951395f27b08c558c65ff4ba2de59437de8c\ - \3ef5459d76a52cedc02dc499a3c9ed9dedbfb3281afd9653b8a112fafc" - ) - ] + [ ( "", + "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d1\ + \3c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e" + ), + ( "abc", + "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a219299\ + \2a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f" + ), + ( "message digest", + "107dbf389d9e9f71a3a95f6c055b9251bc5268c2be16d6c13492ea45b0199f3309e164\ + \55ab1e96118e8a905d5597b72038ddb372a89826046de66687bb420e7c" + ), + ( "secure hash algorithm", + "7746d91f3de30c68cec0dd693120a7e8b04d8073cb699bdce1a3f64127bca7a3d5db50\ + \2e814bb63c063a7a5043b2df87c61133395f4ad1edca7fcf4b30c3236e" + ), + ( "SHA512 is considered to be safe", + "099e6468d889e1c79092a89ae925a9499b5408e01b66cb5b0a3bd0dfa51a99646b4a39\ + \01caab1318189f74cd8cf2e941829012f2449df52067d3dd5b978456c2" + ), + ( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq", + "204a8fc6dda82f0a0ced7beb8e08a41657c16ef468b228a8279be331a703c33596fd15\ + \c13b1b07f9aa1d3bea57789ca031ad85c7a71dd70354ec631238ca3445" + ), + ( "For this sample, this 63-byte string will be used as input data", + "b3de4afbc516d2478fe9b518d063bda6c8dd65fc38402dd81d1eb7364e72fb6e6663cf\ + \6d2771c8f5a6da09601712fb3d2a36c6ffea3e28b0818b05b0a8660766" + ), + ( "This is exactly 64 bytes long, not counting the terminating byte", + "70aefeaa0e7ac4f8fe17532d7185a289bee3b428d950c14fa8b713ca09814a387d2458\ + \70e007a80ad97c369d193e41701aa07f3221d15f0e65a1ff970cedf030" + ), + ( "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmn\ + \opjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu", + "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d28\ + \9e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" + ), + ( Char8.replicate 1000000 'a', + "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973ebde0ff2\ + \44877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b" + ), + ( longTestString, + "40cac46c147e6131c5193dd5f34e9d8bb4951395f27b08c558c65ff4ba2de59437de8c\ + \3ef5459d76a52cedc02dc499a3c9ed9dedbfb3281afd9653b8a112fafc" + ) + ] -- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231 hmacSha256Vectors :: [(Text, Text, Text)] hmacSha256Vectors = - [ - ( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" - , "4869205468657265" - , "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" - ) - , - ( "4a656665" - , "7768617420646f2079612077616e7420666f72206e6f7468696e673f" - , "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843" - ) - , - ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" - , "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\ - \dddddddddddddddddddddddddddddd" - , "773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe" - ) - , - ( "0102030405060708090a0b0c0d0e0f10111213141516171819" - , "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\ - \cdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" - , "82558a389a443c0ea4cc819899f2083a85f0faa3e578f8077a2e3ff46729665b" - ) - , - ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" - , "54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a65204b\ - \6579202d2048617368204b6579204669727374" - , "60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54" - ) - , - ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" - , "5468697320697320612074657374207573696e672061206c6172676572207468616e20\ - \626c6f636b2d73697a65206b657920616e642061206c6172676572207468616e20626c\ - \6f636b2d73697a6520646174612e20546865206b6579206e6565647320746f20626520\ - \686173686564206265666f7265206265696e6720757365642062792074686520484d41\ - \4320616c676f726974686d2e" - , "9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2" - ) - , -- Test case with key length 63 bytes. + [ ( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b", + "4869205468657265", + "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" + ), + ( "4a656665", + "7768617420646f2079612077616e7420666f72206e6f7468696e673f", + "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843" + ), + ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", + "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\ + \dddddddddddddddddddddddddddddd", + "773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe" + ), + ( "0102030405060708090a0b0c0d0e0f10111213141516171819", + "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\ + \cdcdcdcdcdcdcdcdcdcdcdcdcdcdcd", + "82558a389a443c0ea4cc819899f2083a85f0faa3e578f8077a2e3ff46729665b" + ), + ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", + "54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a65204b\ + \6579202d2048617368204b6579204669727374", + "60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54" + ), + ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", + "5468697320697320612074657374207573696e672061206c6172676572207468616e20\ + \626c6f636b2d73697a65206b657920616e642061206c6172676572207468616e20626c\ + \6f636b2d73697a6520646174612e20546865206b6579206e6565647320746f20626520\ + \686173686564206265666f7265206265696e6720757365642062792074686520484d41\ + \4320616c676f726974686d2e", + "9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2" + ), + -- Test case with key length 63 bytes. - ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\ - \654a6566654a6566654a6566654a6566654a6566654a6566654a6566" - , "7768617420646f2079612077616e7420666f72206e6f7468696e673f" - , "9de4b546756c83516720a4ad7fe7bdbeac4298c6fdd82b15f895a6d10b0769a6" - ) - , -- Test case with key length 64 bytes. + ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\ + \654a6566654a6566654a6566654a6566654a6566654a6566654a6566", + "7768617420646f2079612077616e7420666f72206e6f7468696e673f", + "9de4b546756c83516720a4ad7fe7bdbeac4298c6fdd82b15f895a6d10b0769a6" + ), + -- Test case with key length 64 bytes. - ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\ - \654a6566654a6566654a6566654a6566654a6566654a6566654a656665" - , "7768617420646f2079612077616e7420666f72206e6f7468696e673f" - , "528c609a4c9254c274585334946b7c2661bad8f1fc406b20f6892478d19163dd" - ) - , -- Test case with key length 65 bytes. + ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\ + \654a6566654a6566654a6566654a6566654a6566654a6566654a656665", + "7768617420646f2079612077616e7420666f72206e6f7468696e673f", + "528c609a4c9254c274585334946b7c2661bad8f1fc406b20f6892478d19163dd" + ), + -- Test case with key length 65 bytes. - ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\ - \654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a" - , "7768617420646f2079612077616e7420666f72206e6f7468696e673f" - , "d06af337f359a2330deffb8e3cbe4b5b7aa8ca1f208528cdbd245d5dc63c4483" - ) - ] + ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\ + \654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a", + "7768617420646f2079612077616e7420666f72206e6f7468696e673f", + "d06af337f359a2330deffb8e3cbe4b5b7aa8ca1f208528cdbd245d5dc63c4483" + ) + ] -- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231 hmacSha512Vectors :: [(Text, Text, Text)] hmacSha512Vectors = - [ - ( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" - , "4869205468657265" - , "87aa7cdea5ef619d4ff0b4241a1d6cb02379f4e2ce4ec2787ad0b30545e17cde\ - \daa833b7d6b8a702038b274eaea3f4e4be9d914eeb61f1702e696c203a126854" - ) - , - ( "4a656665" - , "7768617420646f2079612077616e7420666f72206e6f7468696e673f" - , "164b7a7bfcf819e2e395fbe73b56e0a387bd64222e831fd610270cd7ea250554\ - \9758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737" - ) - , - ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" - , "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\ - \dddddddddddddddddddddddddddddddddddd" - , "fa73b0089d56a284efb0f0756c890be9b1b5dbdd8ee81a3655f83e33b2279d39\ - \bf3e848279a722c806b485a47e67c807b946a337bee8942674278859e13292fb" - ) - , - ( "0102030405060708090a0b0c0d0e0f10111213141516171819" - , "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\ - \cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" - , "b0ba465637458c6990e5a8c5f61d4af7e576d97ff94b872de76f8050361ee3db\ - \a91ca5c11aa25eb4d679275cc5788063a5f19741120c4f2de2adebeb10a298dd" - ) - , - ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaa" - , "54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a\ - \65204b6579202d2048617368204b6579204669727374" - , "80b24263c7c1a3ebb71493c1dd7be8b49b46d1f41b4aeec1121b013783f8f352\ - \6b56d037e05f2598bd0fd2215d6a1e5295e64f73f63f0aec8b915a985d786598" - ) - , - ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ - \aaaaaa" - , "5468697320697320612074657374207573696e672061206c6172676572207468\ - \616e20626c6f636b2d73697a65206b657920616e642061206c61726765722074\ - \68616e20626c6f636b2d73697a6520646174612e20546865206b6579206e6565\ - \647320746f20626520686173686564206265666f7265206265696e6720757365\ - \642062792074686520484d414320616c676f726974686d2e" - , "e37b6a775dc87dbaa4dfa9f96e5e3ffddebd71f8867289865df5a32d20cdc944\ - \b6022cac3c4982b10d5eeb55c3e4de15134676fb6de0446065c97440fa8c6a58" - ) - , -- Test case with key length 127 bytes. + [ ( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b", + "4869205468657265", + "87aa7cdea5ef619d4ff0b4241a1d6cb02379f4e2ce4ec2787ad0b30545e17cde\ + \daa833b7d6b8a702038b274eaea3f4e4be9d914eeb61f1702e696c203a126854" + ), + ( "4a656665", + "7768617420646f2079612077616e7420666f72206e6f7468696e673f", + "164b7a7bfcf819e2e395fbe73b56e0a387bd64222e831fd610270cd7ea250554\ + \9758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737" + ), + ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", + "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\ + \dddddddddddddddddddddddddddddddddddd", + "fa73b0089d56a284efb0f0756c890be9b1b5dbdd8ee81a3655f83e33b2279d39\ + \bf3e848279a722c806b485a47e67c807b946a337bee8942674278859e13292fb" + ), + ( "0102030405060708090a0b0c0d0e0f10111213141516171819", + "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\ + \cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd", + "b0ba465637458c6990e5a8c5f61d4af7e576d97ff94b872de76f8050361ee3db\ + \a91ca5c11aa25eb4d679275cc5788063a5f19741120c4f2de2adebeb10a298dd" + ), + ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaa", + "54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a\ + \65204b6579202d2048617368204b6579204669727374", + "80b24263c7c1a3ebb71493c1dd7be8b49b46d1f41b4aeec1121b013783f8f352\ + \6b56d037e05f2598bd0fd2215d6a1e5295e64f73f63f0aec8b915a985d786598" + ), + ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \aaaaaa", + "5468697320697320612074657374207573696e672061206c6172676572207468\ + \616e20626c6f636b2d73697a65206b657920616e642061206c61726765722074\ + \68616e20626c6f636b2d73697a6520646174612e20546865206b6579206e6565\ + \647320746f20626520686173686564206265666f7265206265696e6720757365\ + \642062792074686520484d414320616c676f726974686d2e", + "e37b6a775dc87dbaa4dfa9f96e5e3ffddebd71f8867289865df5a32d20cdc944\ + \b6022cac3c4982b10d5eeb55c3e4de15134676fb6de0446065c97440fa8c6a58" + ), + -- Test case with key length 127 bytes. - ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566" - , "7768617420646f2079612077616e7420666f72206e6f7468696e673f" - , "267424dfb8eeb999f3e5ec39a4fe9fd14c923e6187e0897063e5c9e02b2e624a\ - \c04413e762977df71a9fb5d562b37f89dfdfb930fce2ed1fa783bbc2a203d80e" - ) - , -- Test case with key length 128 bytes. + ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566", + "7768617420646f2079612077616e7420666f72206e6f7468696e673f", + "267424dfb8eeb999f3e5ec39a4fe9fd14c923e6187e0897063e5c9e02b2e624a\ + \c04413e762977df71a9fb5d562b37f89dfdfb930fce2ed1fa783bbc2a203d80e" + ), + -- Test case with key length 128 bytes. - ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665" - , "7768617420646f2079612077616e7420666f72206e6f7468696e673f" - , "43aaac07bb1dd97c82c04df921f83b16a68d76815cd1a30d3455ad43a3d80484\ - \2bb35462be42cc2e4b5902de4d204c1c66d93b47d1383e3e13a3788687d61258" - ) - , -- Test case with key length 129 bytes. + ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665", + "7768617420646f2079612077616e7420666f72206e6f7468696e673f", + "43aaac07bb1dd97c82c04df921f83b16a68d76815cd1a30d3455ad43a3d80484\ + \2bb35462be42cc2e4b5902de4d204c1c66d93b47d1383e3e13a3788687d61258" + ), + -- Test case with key length 129 bytes. - ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ - \4a" - , "7768617420646f2079612077616e7420666f72206e6f7468696e673f" - , "0b273325191cfc1b4b71d5075c8fcad67696309d292b1dad2cd23983a35feb8e\ - \fb29795e79f2ef27f68cb1e16d76178c307a67beaad9456fac5fdffeadb16e2c" - ) - ] + ( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\ + \4a", + "7768617420646f2079612077616e7420666f72206e6f7468696e673f", + "0b273325191cfc1b4b71d5075c8fcad67696309d292b1dad2cd23983a35feb8e\ + \fb29795e79f2ef27f68cb1e16d76178c307a67beaad9456fac5fdffeadb16e2c" + ) + ] diff --git a/test/Haskoin/Crypto/Keys/ExtendedSpec.hs b/test/Haskoin/Crypto/Keys/ExtendedSpec.hs new file mode 100644 index 00000000..5789cc60 --- /dev/null +++ b/test/Haskoin/Crypto/Keys/ExtendedSpec.hs @@ -0,0 +1,608 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Haskoin.Crypto.Keys.ExtendedSpec (spec) where + +import Control.Monad (forM_) +import Data.Aeson as A +import Data.Bits ((.&.)) +import Data.ByteString.Lazy.Char8 qualified as B8 +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Either (isLeft) +import Data.Maybe (fromJust, isJust, isNothing) +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32) +import Haskoin.Address +import Haskoin.Crypto +import Haskoin.Network.Constants +import Haskoin.Util +import Haskoin.Util.Arbitrary +import Test.HUnit +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck hiding ((.&.)) + +serialVals :: [SerialBox] +serialVals = + [ SerialBox arbitraryDerivPath, + SerialBox arbitraryHardPath, + SerialBox arbitrarySoftPath + ] + +readVals :: Ctx -> [ReadBox] +readVals ctx = + [ ReadBox arbitraryDerivPath, + ReadBox arbitraryHardPath, + ReadBox arbitrarySoftPath, + ReadBox arbitraryXPrvKey, + ReadBox (snd <$> arbitraryXPubKey ctx), + ReadBox arbitraryParsedPath, + ReadBox arbitraryBip32PathIndex + ] + +jsonVals :: [JsonBox] +jsonVals = + [ JsonBox arbitraryDerivPath, + JsonBox arbitraryHardPath, + JsonBox arbitrarySoftPath, + JsonBox arbitraryParsedPath + ] + +netVals :: Ctx -> [NetBox] +netVals ctx = + [ NetBox + ( marshalValue, + marshalEncoding, + unmarshalValue, + genNetData arbitraryXPrvKey + ), + NetBox + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + genNetData (snd <$> arbitraryXPubKey ctx) + ) + ] + +spec :: Spec +spec = prepareContext $ \ctx -> do + testIdentity serialVals (readVals ctx) jsonVals (netVals ctx) + describe "Custom identity tests" $ do + prop "encodes and decodes extended private key" $ + forAll arbitraryNetwork $ \net -> + forAll arbitraryXPrvKey $ + customCerealID (marshalGet net) (marshalPut net) + prop "encodes and decodes extended public key" $ + forAll arbitraryNetwork $ \net -> + forAll (arbitraryXPubKey ctx) $ + customCerealID (marshalGet (net, ctx)) (marshalPut (net, ctx)) . snd + describe "bip32 subkey derivation vector 1" $ vectorSpec ctx m1 vector1 + describe "bip32 subkey derivation vector 2" $ vectorSpec ctx m2 vector2 + describe "bip32 subkey derivation vector 3" $ vectorSpec ctx m3 vector3 + describe "bip32 subkey derivation using string path" $ do + it "either derivations" $ testApplyPath ctx + it "either derivations" $ testBadApplyPath ctx + it "dublic derivations" $ testDerivePubPath ctx + it "private derivations" $ testDerivePrvPath ctx + it "path parsing" testParsePath + it "from json" testFromJsonPath + it "to json" testToJsonPath + describe "Derivation Paths" $ do + prop "from string derivation path" $ + forAll arbitraryDerivPath $ + \p -> fromString (cs $ pathToStr p) == p + prop "from string hard derivation path" $ + forAll arbitraryHardPath $ + \p -> fromString (cs $ pathToStr p) == p + prop "from string soft derivation path" $ + forAll arbitrarySoftPath $ + \p -> fromString (cs $ pathToStr p) == p + prop "from and to lists of derivation paths" $ + forAll arbitraryDerivPath $ + \p -> listToPath (pathToList p) == p + prop "from and to lists of hard derivation paths" $ + forAll arbitraryHardPath $ \p -> + toHard (listToPath $ pathToList p) == Just p + prop "from and to lists of soft derivation paths" $ + forAll arbitrarySoftPath $ \p -> + toSoft (listToPath $ pathToList p) == Just p + describe "Extended Keys" $ do + let net = btc + prop "computes pubkey of a subkey is subkey of the pubkey" $ + forAll arbitraryXPrvKey $ + pubKeyOfSubKeyIsSubKeyOfPubKey ctx + prop "exports and imports extended private key" $ + forAll arbitraryXPrvKey $ \k -> + xPrvImport net (xPrvExport net k) == Just k + prop "exports and imports extended public key" $ + forAll (arbitraryXPubKey ctx) $ \(_, k) -> + xPubImport net ctx (xPubExport net ctx k) == Just k + +pubKeyOfSubKeyIsSubKeyOfPubKey :: Ctx -> XPrvKey -> Word32 -> Bool +pubKeyOfSubKeyIsSubKeyOfPubKey ctx k i = + deriveXPubKey ctx (prvSubKey ctx k i') == pubSubKey ctx (deriveXPubKey ctx k) i' + where + i' = fromIntegral $ i .&. 0x7fffffff -- make it a public derivation + +testFromJsonPath :: Assertion +testFromJsonPath = + sequence_ $ do + path <- jsonPathVectors + return $ + assertEqual + path + (Just [fromString path :: DerivPath]) + (A.decode $ B8.pack $ "[\"" ++ path ++ "\"]") + +testToJsonPath :: Assertion +testToJsonPath = + sequence_ $ do + path <- jsonPathVectors + return $ + assertEqual + path + (B8.pack $ "[\"" ++ path ++ "\"]") + (A.encode [fromString path :: ParsedPath]) + +jsonPathVectors :: [String] +jsonPathVectors = + [ "m", + "m/0", + "m/0'", + "M/0'", + "m/2147483647", + "M/2147483647", + "m/1/2/3/4/5/6/7/8", + "M/1/2/3/4/5/6/7/8", + "m/1'/2'/3/4", + "M/1'/2'/3/4" + ] + +testParsePath :: Assertion +testParsePath = + sequence_ $ do + (path, t) <- parsePathVectors + return $ assertBool path (t $ parsePath path) + +parsePathVectors :: [(String, Maybe ParsedPath -> Bool)] +parsePathVectors = + [ ("m", isJust), + ("m/0'", isJust), + ("M/0'", isJust), + ("m/2147483648", isNothing), + ("m/2147483647", isJust), + ("M/2147483648", isNothing), + ("M/2147483647", isJust), + ("M/-1", isNothing), + ("M/-2147483648", isNothing), + ("m/1/2/3/4/5/6/7/8", isJust), + ("M/1/2/3/4/5/6/7/8", isJust), + ("m/1'/2'/3/4", isJust), + ("M/1'/2'/3/4", isJust), + ("m/1/2'/3/4'", isJust), + ("M/1/2'/3/4'", isJust), + ("meh", isNothing), + ("infinity", isNothing), + ("NaN", isNothing) + ] + +testApplyPath :: Ctx -> Assertion +testApplyPath ctx = + sequence_ $ do + (key, path, final) <- applyPathVectors ctx + return $ + assertEqual path final $ + applyPath ctx (fromJust $ parsePath path) key + +testBadApplyPath :: Ctx -> Assertion +testBadApplyPath ctx = + sequence_ $ do + (key, path) <- badApplyPathVectors ctx + return $ + assertBool path $ + isLeft $ + applyPath ctx (fromJust $ parsePath path) key + +testDerivePubPath :: Ctx -> Assertion +testDerivePubPath ctx = + sequence_ $ do + (key, path, final) <- derivePubPathVectors ctx + return $ + assertEqual path final $ + derivePubPath ctx (fromString path :: SoftPath) key + +testDerivePrvPath :: Ctx -> Assertion +testDerivePrvPath ctx = + sequence_ $ do + (key, path, final) <- derivePrvPathVectors ctx + return $ + assertEqual path final $ + derivePath ctx (fromString path :: DerivPath) key + +derivePubPathVectors :: Ctx -> [(XPubKey, String, XPubKey)] +derivePubPathVectors ctx = + [ (xpub, "M", xpub), + (xpub, "M/8", pubSubKey ctx xpub 8), + (xpub, "M/8/30/1", foldl (pubSubKey ctx) xpub [8, 30, 1]) + ] + where + xprv = + fromJust $ + xPrvImport + btc + "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ + \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + xpub = deriveXPubKey ctx xprv + +derivePrvPathVectors :: Ctx -> [(XPrvKey, String, XPrvKey)] +derivePrvPathVectors ctx = + [ (xprv, "m", xprv), + (xprv, "M", xprv), + (xprv, "m/8'", hardSubKey ctx xprv 8), + (xprv, "M/8'", hardSubKey ctx xprv 8), + ( xprv, + "m/8'/30/1", + foldl (prvSubKey ctx) (hardSubKey ctx xprv 8) [30, 1] + ), + ( xprv, + "M/8'/30/1", + foldl (prvSubKey ctx) (hardSubKey ctx xprv 8) [30, 1] + ), + ( xprv, + "m/3/20", + foldl (prvSubKey ctx) xprv [3, 20] + ), + ( xprv, + "M/3/20", + foldl (prvSubKey ctx) xprv [3, 20] + ) + ] + where + xprv = + fromJust $ + xPrvImport + btc + "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ + \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + +applyPathVectors :: Ctx -> [(XKey, String, Either String XKey)] +applyPathVectors ctx = + [ (XPrv xprv btc, "m", Right (XPrv xprv btc)), + (XPrv xprv btc, "M", Right (XPub xpub btc)), + (XPrv xprv btc, "m/8'", Right (XPrv (hardSubKey ctx xprv 8) btc)), + ( XPrv xprv btc, + "M/8'", + Right (XPub (deriveXPubKey ctx (hardSubKey ctx xprv 8)) btc) + ), + ( XPrv xprv btc, + "m/8'/30/1", + Right (XPrv (foldl (prvSubKey ctx) (hardSubKey ctx xprv 8) [30, 1]) btc) + ), + ( XPrv xprv btc, + "M/8'/30/1", + Right + ( XPub + (deriveXPubKey ctx (foldl (prvSubKey ctx) (hardSubKey ctx xprv 8) [30, 1])) + btc + ) + ), + (XPrv xprv btc, "m/3/20", Right (XPrv (foldl (prvSubKey ctx) xprv [3, 20]) btc)), + ( XPrv xprv btc, + "M/3/20", + Right (XPub (deriveXPubKey ctx (foldl (prvSubKey ctx) xprv [3, 20])) btc) + ), + ( XPub xpub btc, + "M/3/20", + Right (XPub (deriveXPubKey ctx (foldl (prvSubKey ctx) xprv [3, 20])) btc) + ) + ] + where + xprv = + fromJust $ + xPrvImport + btc + "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ + \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + xpub = deriveXPubKey ctx xprv + +badApplyPathVectors :: Ctx -> [(XKey, String)] +badApplyPathVectors ctx = + [ (XPub xpub btc, "m/8'"), + (XPub xpub btc, "M/8'"), + (XPub xpub btc, "M/1/2/3'/4/5") + ] + where + xprv = + fromJust $ + xPrvImport + btc + "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ + \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + xpub = deriveXPubKey ctx xprv + +-- BIP 0032 Test Vectors +-- https://en.bitcoin.it/wiki/BIP_0032_TestVectors + +bip44Addr :: DerivPath +bip44Addr = Deriv :| 44 :| 0 :| 0 :/ 0 :/ 0 + +vectorSpec :: Ctx -> TestKey -> [TestVector] -> Spec +vectorSpec ctx mTxt vecTxt = + forM_ (parseVector ctx mTxt vecTxt) $ \(d, m, v) -> + it ("chain " <> cs d) $ runVector ctx m v + +runVector :: Ctx -> XPrvKey -> TestVector -> Assertion +runVector ctx m v = do + assertBool "xPrvID" $ encodeHex ((runPutS . serialize) (xPrvID ctx m)) == head v + assertBool "xPrvFP" $ encodeHex ((runPutS . serialize) (xPrvFP ctx m)) == v !! 1 + assertBool "xPrvAddr" $ + addrToText btc (xPubAddr ctx $ deriveXPubKey ctx m) == Just (v !! 2) + assertBool "bip44Addr" $ + addrToText btc (xPubAddr ctx $ deriveXPubKey ctx $ derivePath ctx bip44Addr m) + == Just (v !! 3) + assertBool "prvKey" $ encodeHex m.key.get == v !! 4 + assertBool "xPrvWIF" $ xPrvWif btc m == v !! 5 + assertBool "pubKey" $ + encodeHex (exportPubKey ctx True (deriveXPubKey ctx m).key) == v !! 6 + assertBool "chain code" $ encodeHex (runPutS (serialize m.chain)) == v !! 7 + assertBool "Hex PubKey" $ + encodeHex (marshal (btc, ctx) (deriveXPubKey ctx m)) == v !! 8 + assertBool "Hex PrvKey" $ encodeHex (marshal btc m) == v !! 9 + assertBool "Base58 PubKey" $ xPubExport btc ctx (deriveXPubKey ctx m) == v !! 10 + assertBool "Base58 PrvKey" $ xPrvExport btc m == v !! 11 + +-- This function was used to generate addition data for the test vectors +genVector :: Ctx -> XPrvKey -> [(Text, Text)] +genVector ctx m = + [ ("xPrvID", encodeHex (runPutS . serialize $ xPrvID ctx m)), + ("xPrvFP", encodeHex (runPutS . serialize $ xPrvFP ctx m)), + ("xPrvAddr", fromJust $ addrToText btc (xPubAddr ctx $ deriveXPubKey ctx m)), + ( "bip44Addr", + fromJust $ + addrToText btc (xPubAddr ctx $ deriveXPubKey ctx $ derivePath ctx bip44Addr m) + ), + ("prvKey", encodeHex m.key.get), + ("xPrvWIF", xPrvWif btc m), + ("pubKey", encodeHex (exportPubKey ctx True (deriveXPubKey ctx m).key)), + ("chain code", encodeHex ((runPutS . serialize) m.chain)), + ("Hex PubKey", encodeHex (marshal (btc, ctx) (deriveXPubKey ctx m))), + ("Hex PrvKey", encodeHex (marshal btc m)) + ] + +parseVector :: Ctx -> TestKey -> [TestVector] -> [(Text, XPrvKey, TestVector)] +parseVector ctx mTxt vs = + go <$> vs + where + mast = makeXPrvKey $ fromJust $ decodeHex mTxt + go (d : vec) = + let deriv = ((.get) . fromJust . parsePath) (cs d) + in (d, derivePath ctx deriv mast, vec) + go _ = undefined + +type TestVector = [Text] + +type TestKey = Text + +m1 :: TestKey +m1 = "000102030405060708090a0b0c0d0e0f" + +vector1 :: [TestVector] +vector1 = + [ [ "m", + "3442193e1bb70916e914552172cd4e2dbc9df811", + "3442193e", + "15mKKb2eos1hWa6tisdPwwDC1a5J1y9nma", + "1NQpH6Nf8QtR2HphLRcvuVqfhXBXsiWn8r", + "e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35", + "L52XzL2cMkHxqxBXRyEpnPQZGUs3uKiL3R11XbAdHigRzDozKZeW", + "0339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2", + "873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d508", + "0488b21e000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d5080339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2", + "0488ade4000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d50800e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35", + "xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8", + "xprv9s21ZrQH143K3QTDL4LXw2F7HEK3wJUD2nW2nRk4stbPy6cq3jPPqjiChkVvvNKmPGJxWUtg6LnF5kejMRNNU3TGtRBeJgk33yuGBxrMPHi" + ], + [ "m/0'", + "5c1bd648ed23aa5fd50ba52b2457c11e9e80a6a7", + "5c1bd648", + "19Q2WoS5hSS6T8GjhK8KZLMgmWaq4neXrh", + "1DDVw6BRKUv9U8Hzg5rGsia13nDrgJQpBd", + "edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea", + "L5BmPijJjrKbiUfG4zbiFKNqkvuJ8usooJmzuD7Z8dkRoTThYnAT", + "035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56", + "47fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141", + "0488b21e013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56", + "0488ade4013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae623614100edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea", + "xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw", + "xprv9uHRZZhk6KAJC1avXpDAp4MDc3sQKNxDiPvvkX8Br5ngLNv1TxvUxt4cV1rGL5hj6KCesnDYUhd7oWgT11eZG7XnxHrnYeSvkzY7d2bhkJ7" + ], + [ "m/0'/1", + "bef5a2f9a56a94aab12459f72ad9cf8cf19c7bbe", + "bef5a2f9", + "1JQheacLPdM5ySCkrZkV66G2ApAXe1mqLj", + "1KMg6dRggXSkpz9fFyU76ru83TUSwPePEZ", + "3c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368", + "KyFAjQ5rgrKvhXvNMtFB5PCSKUYD1yyPEe3xr3T34TZSUHycXtMM", + "03501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c", + "2a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19", + "0488b21e025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c1903501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c", + "0488ade4025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19003c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368", + "xpub6ASuArnXKPbfEwhqN6e3mwBcDTgzisQN1wXN9BJcM47sSikHjJf3UFHKkNAWbWMiGj7Wf5uMash7SyYq527Hqck2AxYysAA7xmALppuCkwQ", + "xprv9wTYmMFdV23N2TdNG573QoEsfRrWKQgWeibmLntzniatZvR9BmLnvSxqu53Kw1UmYPxLgboyZQaXwTCg8MSY3H2EU4pWcQDnRnrVA1xe8fs" + ], + [ "m/0'/1/2'", + "ee7ab90cde56a8c0e2bb086ac49748b8db9dce72", + "ee7ab90c", + "1NjxqbA9aZWnh17q1UW3rB4EPu79wDXj7x", + "1WykKhR25y7VDT21nZEwUUKSKDz9pENJh", + "cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca", + "L43t3od1Gh7Lj55Bzjj1xDAgJDcL7YFo2nEcNaMGiyRZS1CidBVU", + "0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2", + "04466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f", + "0488b21e03bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2", + "0488ade403bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f00cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca", + "xpub6D4BDPcP2GT577Vvch3R8wDkScZWzQzMMUm3PWbmWvVJrZwQY4VUNgqFJPMM3No2dFDFGTsxxpG5uJh7n7epu4trkrX7x7DogT5Uv6fcLW5", + "xprv9z4pot5VBttmtdRTWfWQmoH1taj2axGVzFqSb8C9xaxKymcFzXBDptWmT7FwuEzG3ryjH4ktypQSAewRiNMjANTtpgP4mLTj34bhnZX7UiM" + ], + [ "m/0'/1/2'/2", + "d880d7d893848509a62d8fb74e32148dac68412f", + "d880d7d8", + "1LjmJcdPnDHhNTUgrWyhLGnRDKxQjoxAgt", + "1asQ3smHhv2nv5R6hPpiUfkEorJpsdwwx", + "0f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4", + "KwjQsVuMjbCP2Zmr3VaFaStav7NvevwjvvkqrWd5Qmh1XVnCteBR", + "02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29", + "cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd", + "0488b21e04ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29", + "0488ade404ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd000f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4", + "xpub6FHa3pjLCk84BayeJxFW2SP4XRrFd1JYnxeLeU8EqN3vDfZmbqBqaGJAyiLjTAwm6ZLRQUMv1ZACTj37sR62cfN7fe5JnJ7dh8zL4fiyLHV", + "xprvA2JDeKCSNNZky6uBCviVfJSKyQ1mDYahRjijr5idH2WwLsEd4Hsb2Tyh8RfQMuPh7f7RtyzTtdrbdqqsunu5Mm3wDvUAKRHSC34sJ7in334" + ], + [ "m/0'/1/2'/2/1000000000", + "d69aa102255fed74378278c7812701ea641fdf32", + "d69aa102", + "1LZiqrop2HGR4qrH1ULZPyBpU6AUP49Uam", + "1HXJog342VFdc68AB9Cb6LwVmCjvcLMiwm", + "471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8", + "Kybw8izYevo5xMh1TK7aUr7jHFCxXS1zv8p3oqFz3o2zFbhRXHYs", + "022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011", + "c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e", + "0488b21e05d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011", + "0488ade405d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e00471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8", + "xpub6H1LXWLaKsWFhvm6RVpEL9P4KfRZSW7abD2ttkWP3SSQvnyA8FSVqNTEcYFgJS2UaFcxupHiYkro49S8yGasTvXEYBVPamhGW6cFJodrTHy", + "xprvA41z7zogVVwxVSgdKUHDy1SKmdb533PjDz7J6N6mV6uS3ze1ai8FHa8kmHScGpWmj4WggLyQjgPie1rFSruoUihUZREPSL39UNdE3BBDu76" + ] + ] + +m2 :: TestKey +m2 = "fffcf9f6f3f0edeae7e4e1dedbd8d5d2cfccc9c6c3c0bdbab7b4b1aeaba8a5a29f9c999693908d8a8784817e7b7875726f6c696663605d5a5754514e4b484542" + +vector2 :: [TestVector] +vector2 = + [ [ "m", + "bd16bee53961a47d6ad888e29545434a89bdfe95", + "bd16bee5", + "1JEoxevbLLG8cVqeoGKQiAwoWbNYSUyYjg", + "148CGtv7bwcC933EHtcDfzDQVneur1R8Y1", + "4b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e", + "KyjXhyHF9wTphBkfpxjL8hkDXDUSbE3tKANT94kXSyh6vn6nKaoy", + "03cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7", + "60499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689", + "0488b21e00000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd968903cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7", + "0488ade400000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689004b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e", + "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB", + "xprv9s21ZrQH143K31xYSDQpPDxsXRTUcvj2iNHm5NUtrGiGG5e2DtALGdso3pGz6ssrdK4PFmM8NSpSBHNqPqm55Qn3LqFtT2emdEXVYsCzC2U" + ], + [ "m/0", + "5a61ff8eb7aaca3010db97ebda76121610b78096", + "5a61ff8e", + "19EuDJdgfRkwCmRzbzVBHZWQG9QNWhftbZ", + "1KVyTSpsBGYs7NdyZmArEpVTfWJQSgiDCx", + "abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e", + "L2ysLrR6KMSAtx7uPqmYpoTeiRzydXBattRXjXz5GDFPrdfPzKbj", + "02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea", + "f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c", + "0488b21e01bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea", + "0488ade401bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c00abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e", + "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH", + "xprv9vHkqa6EV4sPZHYqZznhT2NPtPCjKuDKGY38FBWLvgaDx45zo9WQRUT3dKYnjwih2yJD9mkrocEZXo1ex8G81dwSM1fwqWpWkeS3v86pgKt" + ], + [ "m/0/2147483647'", + "d8ab493736da02f11ed682f88339e720fb0379d1", + "d8ab4937", + "1Lke9bXGhn5VPrBuXgN12uGUphrttUErmk", + "14MFLsfx1nc4RKiaH9khqDTNL9CRz3q347", + "877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93", + "L1m5VpbXmMp57P3knskwhoMTLdhAAaXiHvnGLMribbfwzVRpz2Sr", + "03c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b", + "be17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d9", + "0488b21e025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d903c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b", + "0488ade4025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d900877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93", + "xpub6ASAVgeehLbnwdqV6UKMHVzgqAG8Gr6riv3Fxxpj8ksbH9ebxaEyBLZ85ySDhKiLDBrQSARLq1uNRts8RuJiHjaDMBU4Zn9h8LZNnBC5y4a", + "xprv9wSp6B7kry3Vj9m1zSnLvN3xH8RdsPP1Mh7fAaR7aRLcQMKTR2vidYEeEg2mUCTAwCd6vnxVrcjfy2kRgVsFawNzmjuHc2YmYRmagcEPdU9" + ], + [ "m/0/2147483647'/1", + "78412e3a2296a40de124307b6485bd19833e2e34", + "78412e3a", + "1BxrAr2pHpeBheusmd6fHDP2tSLAUa3qsW", + "19ou31MGyGW9VFx7woKBqwLe5JHhQBYaDD", + "704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7", + "KzyzXnznxSv249b4KuNkBwowaN3akiNeEHy5FWoPCJpStZbEKXN2", + "03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9", + "f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb", + "0488b21e03d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9", + "0488ade403d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb00704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7", + "xpub6DF8uhdarytz3FWdA8TvFSvvAh8dP3283MY7p2V4SeE2wyWmG5mg5EwVvmdMVCQcoNJxGoWaU9DCWh89LojfZ537wTfunKau47EL2dhHKon", + "xprv9zFnWC6h2cLgpmSA46vutJzBcfJ8yaJGg8cX1e5StJh45BBciYTRXSd25UEPVuesF9yog62tGAQtHjXajPPdbRCHuWS6T8XA2ECKADdw4Ef" + ], + [ "m/0/2147483647'/1/2147483646'", + "31a507b815593dfc51ffc7245ae7e5aee304246e", + "31a507b8", + "15XVotxCAV7sRx1PSCkQNsGw3W9jT9A94R", + "18GYmRm4nyjk8ydvoVXFxMWQvxhksEFDZR", + "f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d", + "L5KhaMvPYRW1ZoFmRjUtxxPypQ94m6BcDrPhqArhggdaTbbAFJEF", + "02d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0", + "637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e29", + "0488b21e0478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2902d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0", + "0488ade40478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2900f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d", + "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL", + "xprvA1RpRA33e1JQ7ifknakTFpgNXPmW2YvmhqLQYMmrj4xJXXWYpDPS3xz7iAxn8L39njGVyuoseXzU6rcxFLJ8HFsTjSyQbLYnMpCqE2VbFWc" + ], + [ "m/0/2147483647'/1/2147483646'/2", + "26132fdbe7bf89cbc64cf8dafa3f9f88b8666220", + "26132fdb", + "14UKfRV9ZPUp6ZC9PLhqbRtxdihW9em3xt", + "1758mgwNZhyzpRLe4u7FjqpJtqKpaGhXh7", + "bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23", + "L3WAYNAZPxx1fr7KCz7GN9nD5qMBnNiqEJNJMU1z9MMaannAt4aK", + "024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c", + "9452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271", + "0488b21e0531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c", + "0488ade40531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed27100bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23", + "xpub6FnCn6nSzZAw5Tw7cgR9bi15UV96gLZhjDstkXXxvCLsUXBGXPdSnLFbdpq8p9HmGsApME5hQTZ3emM2rnY5agb9rXpVGyy3bdW6EEgAtqt", + "xprvA2nrNbFZABcdryreWet9Ea4LvTJcGsqrMzxHx98MMrotbir7yrKCEXw7nadnHM8Dq38EGfSh6dqA9QWTyefMLEcBYJUuekgW4BYPJcr9E7j" + ] + ] + +m3 :: TestKey +m3 = "4b381541583be4423346c643850da4b320e46a87ae3d2a4e6da11eba819cd4acba45d239319ac14f863b8d5ab5a0d0c64d2e8a1e7d1457df2e5a3c51c73235be" + +vector3 :: [TestVector] +vector3 = + [ [ "m", + "41d63b50d8dd5e730cdf4c79a56fc929a757c548", + "41d63b50", + "1717ZYpXhZW5CqAbWSjDJbCey3FyKUmCSf", + "17rxURoF96VhmkcEGCj5LNQkmN9HVhWb7F", + "00ddb80b067e0d4993197fe10f2657a844a384589847602d56f0c629c81aae32", + "KwFPqAq9SKx1sPg15Qk56mqkHwrfGPuywtLUxoWPkiTSBoxCs8am", + "03683af1ba5743bdfc798cf814efeeab2735ec52d95eced528e692b8e34c4e5669", + "01d28a3e53cffa419ec122c968b3259e16b65076495494d97cae10bbfec3c36f", + "0488b21e00000000000000000001d28a3e53cffa419ec122c968b3259e16b65076495494d97cae10bbfec3c36f03683af1ba5743bdfc798cf814efeeab2735ec52d95eced528e692b8e34c4e5669", + "0488ade400000000000000000001d28a3e53cffa419ec122c968b3259e16b65076495494d97cae10bbfec3c36f0000ddb80b067e0d4993197fe10f2657a844a384589847602d56f0c629c81aae32", + "xpub661MyMwAqRbcEZVB4dScxMAdx6d4nFc9nvyvH3v4gJL378CSRZiYmhRoP7mBy6gSPSCYk6SzXPTf3ND1cZAceL7SfJ1Z3GC8vBgp2epUt13", + "xprv9s21ZrQH143K25QhxbucbDDuQ4naNntJRi4KUfWT7xo4EKsHt2QJDu7KXp1A3u7Bi1j8ph3EGsZ9Xvz9dGuVrtHHs7pXeTzjuxBrCmmhgC6" + ], + [ "m/0'", + "c61368bb50e066acd95bd04a0b23d3837fb75698", + "c61368bb", + "1K4L3YxEwg8HkSEapM4iSiGuR6HeQ53KPX", + "13QeQVJNNakdUU55P1fc8xPMkkeYVzn4o6", + "491f7a2eebc7b57028e0d3faa0acda02e75c33b03c48fb288c41e2ea44e1daef", + "KyfrPaeirL5yYAoZvfzyoKXSdszeLqg5vb6dNy9ymvjzZrMZY8GW", + "026557fdda1d5d43d79611f784780471f086d58e8126b8c40acb82272a7712e7f2", + "e5fea12a97b927fc9dc3d2cb0d1ea1cf50aa5a1fdc1f933e8906bb38df3377bd", + "0488b21e0141d63b5080000000e5fea12a97b927fc9dc3d2cb0d1ea1cf50aa5a1fdc1f933e8906bb38df3377bd026557fdda1d5d43d79611f784780471f086d58e8126b8c40acb82272a7712e7f2", + "0488ade40141d63b5080000000e5fea12a97b927fc9dc3d2cb0d1ea1cf50aa5a1fdc1f933e8906bb38df3377bd00491f7a2eebc7b57028e0d3faa0acda02e75c33b03c48fb288c41e2ea44e1daef", + "xpub68NZiKmJWnxxS6aaHmn81bvJeTESw724CRDs6HbuccFQN9Ku14VQrADWgqbhhTHBaohPX4CjNLf9fq9MYo6oDaPPLPxSb7gwQN3ih19Zm4Y", + "xprv9uPDJpEQgRQfDcW7BkF7eTya6RPxXeJCqCJGHuCJ4GiRVLzkTXBAJMu2qaMWPrS7AANYqdq6vcBcBUdJCVVFceUvJFjaPdGZ2y9WACViL4L" + ] + ] diff --git a/test/Haskoin/Crypto/Keys/MnemonicSpec.hs b/test/Haskoin/Crypto/Keys/MnemonicSpec.hs new file mode 100644 index 00000000..aa9add24 --- /dev/null +++ b/test/Haskoin/Crypto/Keys/MnemonicSpec.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Crypto.Keys.MnemonicSpec (spec) where + +import Control.Monad (zipWithM_) +import Data.Bits (shiftR, (.&.)) +import Data.ByteString qualified as BS +import Data.Either (fromRight) +import Data.List (isPrefixOf) +import Data.Maybe (fromJust) +import Data.Serialize (Serialize, encode) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word32, Word64) +import Haskoin.Crypto +import Haskoin.Util +import Haskoin.Util.Arbitrary +import Test.HUnit +import Test.Hspec +import Test.QuickCheck hiding ((.&.)) + +spec :: Spec +spec = + describe "mnemonic" $ do + it "entropy to mnemonic sentence" toMnemonicTest + it "mnemonic sentence to entropy" fromMnemonicTest + it "mnemonic sentence to seed" mnemonicToSeedTest + it "mnemonic sentence with invalid checksum" fromMnemonicInvalidTest + it "empty mnemonic sentence is invalid" $ sequence_ [emptyMnemonicTest] + it "generate 12 words" $ property toMnemonic128 + it "generate 18 words" $ property toMnemonic160 + it "generate 24 words" $ property toMnemonic256 + it "generate 48 words" $ property toMnemonic512 + it "generate any number of words" $ property toMnemonicVar + it "encode and decode 128-bit entropy" $ property fromToMnemonic128 + it "encode and decode 160-bit entropy" $ property fromToMnemonic160 + it "encode and decode 256-bit entropy" $ property fromToMnemonic256 + it "encode and decode 512-bit entropy" $ property fromToMnemonic512 + it "encode and decode n-bit entropy" $ property fromToMnemonicVar + it "convert 128-bit mnemonic to seed" $ property mnemonicToSeed128 + it "convert 160-bit mnemonic to seed" $ property mnemonicToSeed160 + it "convert 256-bit mnemonic to seed" $ property mnemonicToSeed256 + it "convert 512-bit mnemonic to seed" $ property mnemonicToSeed512 + it "convert n-bit mnemonic to seed" $ property mnemonicToSeedVar + it "get bits" $ property getBitsByteCount + it "get end bits" $ property getBitsEndBits + +toMnemonicTest :: Assertion +toMnemonicTest = zipWithM_ f ents mss + where + f e m = assertEqual "" m . h $ e + h = + fromRight (error "Could not decode mnemonic sentence") + . toMnemonic + . fromJust + . decodeHex + +fromMnemonicTest :: Assertion +fromMnemonicTest = zipWithM_ f ents mss + where + f e = assertEqual "" e . h + h = + encodeHex + . fromRight (error "Could not decode mnemonic sentence") + . fromMnemonic + +mnemonicToSeedTest :: Assertion +mnemonicToSeedTest = zipWithM_ f mss seeds + where + f m s = assertEqual "" s . h $ m + h = + encodeHex + . fromRight (error "Could not decode mnemonic seed") + . mnemonicToSeed "TREZOR" + +fromMnemonicInvalidTest :: Assertion +fromMnemonicInvalidTest = mapM_ f invalidMss + where + f = assertBool "" . h + h m = case fromMnemonic m of + Right _ -> False + Left err -> "fromMnemonic: checksum failed:" `isPrefixOf` err + +emptyMnemonicTest :: Assertion +emptyMnemonicTest = + assertBool "" $ + case fromMnemonic "" of + Right _ -> False + Left err -> "fromMnemonic: empty mnemonic" `isPrefixOf` err + +ents :: [Text] +ents = + [ "00000000000000000000000000000000", + "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f", + "80808080808080808080808080808080", + "ffffffffffffffffffffffffffffffff", + "000000000000000000000000000000000000000000000000", + "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f", + "808080808080808080808080808080808080808080808080", + "ffffffffffffffffffffffffffffffffffffffffffffffff", + "0000000000000000000000000000000000000000000000000000000000000000", + "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f", + "8080808080808080808080808080808080808080808080808080808080808080", + "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff", + "77c2b00716cec7213839159e404db50d", + "b63a9c59a6e641f288ebc103017f1da9f8290b3da6bdef7b", + "3e141609b97933b66a060dcddc71fad1d91677db872031e85f4c015c5e7e8982", + "0460ef47585604c5660618db2e6a7e7f", + "72f60ebac5dd8add8d2a25a797102c3ce21bc029c200076f", + "2c85efc7f24ee4573d2b81a6ec66cee209b2dcbd09d8eddc51e0215b0b68e416", + "eaebabb2383351fd31d703840b32e9e2", + "7ac45cfe7722ee6c7ba84fbc2d5bd61b45cb2fe5eb65aa78", + "4fa1a8bc3e6d80ee1316050e862c1812031493212b7ec3f3bb1b08f168cabeef", + "18ab19a9f54a9274f03e5209a2ac8a91", + "18a2e1d81b8ecfb2a333adcb0c17a5b9eb76cc5d05db91a4", + "15da872c95a13dd738fbf50e427583ad61f18fd99f628c417a61cf8343c90419" + ] + +mss :: [Mnemonic] +mss = + [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon about", + "legal winner thank year wave sausage worth useful legal winner thank\ + \ yellow", + "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage above", + "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo wrong", + "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon agent", + "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal will", + "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter always", + "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ when", + "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon art", + "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal winner thank year wave sausage\ + \ worth title", + "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ + \ amount doctor acoustic bless", + "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ zoo zoo zoo zoo zoo vote", + "jelly better achieve collect unaware mountain thought cargo oxygen act\ + \ hood bridge", + "renew stay biology evidence goat welcome casual join adapt armor shuffle\ + \ fault little machine walk stumble urge swap", + "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ + \ multiply desk host tomato cradle drill spread actor shine dismiss\ + \ champion exotic", + "afford alter spike radar gate glance object seek swamp infant panel\ + \ yellow", + "indicate race push merry suffer human cruise dwarf pole review arch keep\ + \ canvas theme poem divorce alter left", + "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ + \ recipe series open hour vintage deposit universe tip job dress radar\ + \ refuse motion taste", + "turtle front uncle idea crush write shrug there lottery flower risk\ + \ shell", + "kiss carry display unusual confirm curtain upgrade antique rotate hello\ + \ void custom frequent obey nut hole price segment", + "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ + \ catch course end lucky hurt sentence oven short ball bird grab wing top", + "board flee heavy tunnel powder denial science ski answer betray cargo\ + \ cat", + "board blade invite damage undo sun mimic interest slam gaze truly\ + \ inherit resist great inject rocket museum chief", + "beyond stage sleep clip because twist token leaf atom beauty genius food\ + \ business side grid unable middle armed observe pair crouch tonight away\ + \ coconut" + ] + +seeds :: [Text] +seeds = + [ "c55257c360c07c72029aebc1b53c05ed0362ada38ead3e3e9efa3708e53495531f09a69\ + \87599d18264c1e1c92f2cf141630c7a3c4ab7c81b2f001698e7463b04", + "2e8905819b8723fe2c1d161860e5ee1830318dbf49a83bd451cfb8440c28bd6fa457fe1\ + \296106559a3c80937a1c1069be3a3a5bd381ee6260e8d9739fce1f607", + "d71de856f81a8acc65e6fc851a38d4d7ec216fd0796d0a6827a3ad6ed5511a30fa280f1\ + \2eb2e47ed2ac03b5c462a0358d18d69fe4f985ec81778c1b370b652a8", + "ac27495480225222079d7be181583751e86f571027b0497b5b5d11218e0a8a133325729\ + \17f0f8e5a589620c6f15b11c61dee327651a14c34e18231052e48c069", + "035895f2f481b1b0f01fcf8c289c794660b289981a78f8106447707fdd9666ca06da5a9\ + \a565181599b79f53b844d8a71dd9f439c52a3d7b3e8a79c906ac845fa", + "f2b94508732bcbacbcc020faefecfc89feafa6649a5491b8c952cede496c214a0c7b3c3\ + \92d168748f2d4a612bada0753b52a1c7ac53c1e93abd5c6320b9e95dd", + "107d7c02a5aa6f38c58083ff74f04c607c2d2c0ecc55501dadd72d025b751bc27fe913f\ + \fb796f841c49b1d33b610cf0e91d3aa239027f5e99fe4ce9e5088cd65", + "0cd6e5d827bb62eb8fc1e262254223817fd068a74b5b449cc2f667c3f1f985a76379b43\ + \348d952e2265b4cd129090758b3e3c2c49103b5051aac2eaeb890a528", + "bda85446c68413707090a52022edd26a1c9462295029f2e60cd7c4f2bbd3097170af7a4\ + \d73245cafa9c3cca8d561a7c3de6f5d4a10be8ed2a5e608d68f92fcc8", + "bc09fca1804f7e69da93c2f2028eb238c227f2e9dda30cd63699232578480a4021b146a\ + \d717fbb7e451ce9eb835f43620bf5c514db0f8add49f5d121449d3e87", + "c0c519bd0e91a2ed54357d9d1ebef6f5af218a153624cf4f2da911a0ed8f7a09e2ef61a\ + \f0aca007096df430022f7a2b6fb91661a9589097069720d015e4e982f", + "dd48c104698c30cfe2b6142103248622fb7bb0ff692eebb00089b32d22484e1613912f0\ + \a5b694407be899ffd31ed3992c456cdf60f5d4564b8ba3f05a69890ad", + "b5b6d0127db1a9d2226af0c3346031d77af31e918dba64287a1b44b8ebf63cdd52676f6\ + \72a290aae502472cf2d602c051f3e6f18055e84e4c43897fc4e51a6ff", + "9248d83e06f4cd98debf5b6f010542760df925ce46cf38a1bdb4e4de7d21f5c39366941\ + \c69e1bdbf2966e0f6e6dbece898a0e2f0a4c2b3e640953dfe8b7bbdc5", + "ff7f3184df8696d8bef94b6c03114dbee0ef89ff938712301d27ed8336ca89ef9635da2\ + \0af07d4175f2bf5f3de130f39c9d9e8dd0472489c19b1a020a940da67", + "65f93a9f36b6c85cbe634ffc1f99f2b82cbb10b31edc7f087b4f6cb9e976e9faf76ff41\ + \f8f27c99afdf38f7a303ba1136ee48a4c1e7fcd3dba7aa876113a36e4", + "3bbf9daa0dfad8229786ace5ddb4e00fa98a044ae4c4975ffd5e094dba9e0bb289349db\ + \e2091761f30f382d4e35c4a670ee8ab50758d2c55881be69e327117ba", + "fe908f96f46668b2d5b37d82f558c77ed0d69dd0e7e043a5b0511c48c2f1064694a956f\ + \86360c93dd04052a8899497ce9e985ebe0c8c52b955e6ae86d4ff4449", + "bdfb76a0759f301b0b899a1e3985227e53b3f51e67e3f2a65363caedf3e32fde42a66c4\ + \04f18d7b05818c95ef3ca1e5146646856c461c073169467511680876c", + "ed56ff6c833c07982eb7119a8f48fd363c4a9b1601cd2de736b01045c5eb8ab4f57b079\ + \403485d1c4924f0790dc10a971763337cb9f9c62226f64fff26397c79", + "095ee6f817b4c2cb30a5a797360a81a40ab0f9a4e25ecd672a3f58a0b5ba0687c096a6b\ + \14d2c0deb3bdefce4f61d01ae07417d502429352e27695163f7447a8c", + "6eff1bb21562918509c73cb990260db07c0ce34ff0e3cc4a8cb3276129fbcb300bddfe0\ + \05831350efd633909f476c45c88253276d9fd0df6ef48609e8bb7dca8", + "f84521c777a13b61564234bf8f8b62b3afce27fc4062b51bb5e62bdfecb23864ee6ecf0\ + \7c1d5a97c0834307c5c852d8ceb88e7c97923c0a3b496bedd4e5f88a9", + "b15509eaa2d09d3efd3e006ef42151b30367dc6e3aa5e44caba3fe4d3e352e65101fbdb\ + \86a96776b91946ff06f8eac594dc6ee1d3e82a42dfe1b40fef6bcc3fd" + ] + +invalidMss :: [Mnemonic] +invalidMss = + [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon", + "legal winner thank year wave sausage worth useful legal winner thank\ + \ thank", + "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage sausage", + "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo", + "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon abandon", + "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal letter", + "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter abandon", + "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ zoo", + "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon", + "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal winner thank year wave sausage\ + \ worth letter", + "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ + \ amount doctor acoustic letter", + "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ zoo zoo zoo zoo zoo zoo", + "jelly better achieve collect unaware mountain thought cargo oxygen act\ + \ hood zoo", + "renew stay biology evidence goat welcome casual join adapt armor shuffle\ + \ fault little machine walk stumble urge zoo", + "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ + \ multiply desk host tomato cradle drill spread actor shine dismiss\ + \ champion zoo", + "afford alter spike radar gate glance object seek swamp infant panel\ + \ zoo", + "indicate race push merry suffer human cruise dwarf pole review arch keep\ + \ canvas theme poem divorce alter zoo", + "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ + \ recipe series open hour vintage deposit universe tip job dress radar\ + \ refuse motion zoo", + "turtle front uncle idea crush write shrug there lottery flower risk\ + \ zoo", + "kiss carry display unusual confirm curtain upgrade antique rotate hello\ + \ void custom frequent obey nut hole price zoo", + "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ + \ catch course end lucky hurt sentence oven short ball bird grab wing zoo", + "board flee heavy tunnel powder denial science ski answer betray cargo\ + \ zoo", + "board blade invite damage undo sun mimic interest slam gaze truly\ + \ inherit resist great inject rocket museum zoo", + "beyond stage sleep clip because twist token leaf atom beauty genius food\ + \ business side grid unable middle armed observe pair crouch tonight away\ + \ zoo" + ] + +binWordsToBS :: (Serialize a) => [a] -> BS.ByteString +binWordsToBS = foldr f BS.empty + where + f b a = a `BS.append` encode b + +{- Encode mnemonic -} + +toMnemonic128 :: (Word64, Word64) -> Bool +toMnemonic128 (a, b) = l == 12 + where + bs = encode a `BS.append` encode b + l = + length + . T.words + . fromRight (error "Could not decode mnemonic senttence") + $ toMnemonic bs + +toMnemonic160 :: (Word32, Word64, Word64) -> Bool +toMnemonic160 (a, b, c) = l == 15 + where + bs = BS.concat [encode a, encode b, encode c] + l = + length + . T.words + . fromRight (error "Could not decode mnemonic sentence") + $ toMnemonic bs + +toMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool +toMnemonic256 (a, b, c, d) = l == 24 + where + bs = BS.concat [encode a, encode b, encode c, encode d] + l = + length + . T.words + . fromRight (error "Could not decode mnemonic sentence") + $ toMnemonic bs + +toMnemonic512 :: + ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool +toMnemonic512 ((a, b, c, d), (e, f, g, h)) = l == 48 + where + bs = + BS.concat + [ encode a, + encode b, + encode c, + encode d, + encode e, + encode f, + encode g, + encode h + ] + l = + length + . T.words + . fromRight (error "Could not decode mnemonic sentence") + $ toMnemonic bs + +toMnemonicVar :: [Word32] -> Property +toMnemonicVar ls = not (null ls) && length ls <= 8 ==> l == wc + where + bs = binWordsToBS ls + bl = BS.length bs + cb = bl `div` 4 + wc = (cb + bl * 8) `div` 11 + l = + length + . T.words + . fromRight (error "Could not decode mnemonic sentence") + $ toMnemonic bs + +{- Encode/Decode -} + +fromToMnemonic128 :: (Word64, Word64) -> Bool +fromToMnemonic128 (a, b) = bs == bs' + where + bs = encode a `BS.append` encode b + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +fromToMnemonic160 :: (Word32, Word64, Word64) -> Bool +fromToMnemonic160 (a, b, c) = bs == bs' + where + bs = BS.concat [encode a, encode b, encode c] + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +fromToMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool +fromToMnemonic256 (a, b, c, d) = bs == bs' + where + bs = BS.concat [encode a, encode b, encode c, encode d] + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +fromToMnemonic512 :: + ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool +fromToMnemonic512 ((a, b, c, d), (e, f, g, h)) = bs == bs' + where + bs = + BS.concat + [ encode a, + encode b, + encode c, + encode d, + encode e, + encode f, + encode g, + encode h + ] + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +fromToMnemonicVar :: [Word32] -> Property +fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == bs' + where + bs = binWordsToBS ls + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +{- Mnemonic to seed -} + +mnemonicToSeed128 :: (Word64, Word64) -> Bool +mnemonicToSeed128 (a, b) = l == 64 + where + bs = encode a `BS.append` encode b + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +mnemonicToSeed160 :: (Word32, Word64, Word64) -> Bool +mnemonicToSeed160 (a, b, c) = l == 64 + where + bs = BS.concat [encode a, encode b, encode c] + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +mnemonicToSeed256 :: (Word64, Word64, Word64, Word64) -> Bool +mnemonicToSeed256 (a, b, c, d) = l == 64 + where + bs = BS.concat [encode a, encode b, encode c, encode d] + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +mnemonicToSeed512 :: + ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool +mnemonicToSeed512 ((a, b, c, d), (e, f, g, h)) = l == 64 + where + bs = + BS.concat + [ encode a, + encode b, + encode c, + encode d, + encode e, + encode f, + encode g, + encode h + ] + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +mnemonicToSeedVar :: [Word32] -> Property +mnemonicToSeedVar ls = not (null ls) && length ls <= 16 ==> l == 64 + where + bs = binWordsToBS ls + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +{- Get bits from ByteString -} + +data ByteCountGen = ByteCountGen BS.ByteString Int deriving (Show) + +instance Arbitrary ByteCountGen where + arbitrary = do + bs <- arbitraryBS + i <- choose (0, BS.length bs * 8) + return $ ByteCountGen bs i + +getBitsByteCount :: ByteCountGen -> Bool +getBitsByteCount (ByteCountGen bs i) = BS.length bits == l + where + (q, r) = i `quotRem` 8 + bits = getBits i bs + l = if r == 0 then q else q + 1 + +getBitsEndBits :: ByteCountGen -> Bool +getBitsEndBits (ByteCountGen bs i) = + (r == 0) || (BS.last bits .&. (0xff `shiftR` r) == 0x00) + where + r = i `mod` 8 + bits = getBits i bs diff --git a/test/Haskoin/Crypto/KeysSpec.hs b/test/Haskoin/Crypto/KeysSpec.hs new file mode 100644 index 00000000..9cc93836 --- /dev/null +++ b/test/Haskoin/Crypto/KeysSpec.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Crypto.KeysSpec (spec) where + +import Control.Lens +import Control.Monad +import Data.Aeson as A +import Data.Aeson.Lens +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as C +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Maybe +import Data.Serialize qualified as S +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Haskoin.Address +import Haskoin.Crypto +import Haskoin.Network.Constants +import Haskoin.Script +import Haskoin.Util +import Haskoin.Util.Arbitrary +import Test.HUnit +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +spec :: Spec +spec = prepareContext $ \ctx -> do + describe "Key pair property checks" $ do + testNetJson + marshalValue + marshalEncoding + unmarshalValue + $ (,) + <$> arbitraryNetwork + <*> fmap fst (arbitraryKeyPair ctx) + prop "Public key is canonical" $ + forAll (arbitraryKeyPair ctx) (isCanonicalPubKey ctx . snd) + prop "Key pair key show . read identity" $ + forAll (arbitraryKeyPair ctx) $ \x -> + (read . show) x == x + prop "Public key binary serialization" $ do + forAll (arbitraryKeyPair ctx) $ \(sec, pub) -> + (unmarshal ctx . marshal ctx) pub == Right pub + prop "fromWif . toWif identity" $ + forAll arbitraryNetwork $ \net -> + forAll (arbitraryKeyPair ctx) $ \(key, _) -> + (fromWif net . toWif net) key == Just key + prop "WIF binary identity" $ + forAll arbitraryNetwork $ \net -> + forAll (arbitraryKeyPair ctx) $ \(key, _) -> + (runGetS deserialize . runPutS . serialize) key == Right key + describe "Bitcoin core vectors /src/test/key_tests.cpp" $ do + it "Passes WIF decoding tests" testPrivkey + it "Passes SecKey compression tests" testPrvKeyCompressed + it "Passes PubKey compression tests" $ testKeyCompressed ctx + it "Passes address matching tests" $ testMatchingAddress ctx + it "Passes signature verification" $ testSigs ctx + it "Passes deterministic signing tests" $ testDetSigning ctx + describe "MiniKey vectors" $ + it "Passes MiniKey decoding tests" testMiniKey + describe "key_io_valid.json vectors" $ do + vectors <- runIO (readTestFile "key_io_valid.json" :: IO [(Text, Text, A.Value)]) + it "Passes the key_io_valid.json vectors" $ + mapM_ (testKeyIOValidVector ctx) vectors + describe "key_io_invalid.json vectors" $ do + vectors <- runIO (readTestFile "key_io_invalid.json" :: IO [[Text]]) + it "Passes the key_io_invalid.json vectors" $ + mapM_ (testKeyIOInvalidVector ctx) vectors + +-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp +-- from function IsCanonicalPubKey +isCanonicalPubKey :: Ctx -> PublicKey -> Bool +isCanonicalPubKey ctx p = + not $ + -- Non-canonical public key: too short + (B.length bs < 33) + || + -- Non-canonical public key: invalid length for uncompressed key + (B.index bs 0 == 4 && B.length bs /= 65) + || + -- Non-canonical public key: invalid length for compressed key + (B.index bs 0 `elem` [2, 3] && B.length bs /= 33) + || + -- Non-canonical public key: compressed nor uncompressed + (B.index bs 0 `notElem` [2, 3, 4]) + where + bs = marshal ctx p + +testMiniKey :: Assertion +testMiniKey = + assertEqual "fromMiniKey" (Just res) (go "S6c56bnXQiBjk9mqSYE7ykVQ7NzrRy") + where + go = fmap (encodeHex . (.key.get)) . fromMiniKey + res = "4c7a9640c72dc2099f23715d0c8a0d8a35f8906e3cab61dd3f78b67bf887c9ab" + +-- Test vectors from: +-- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_io_tests.cpp + +testKeyIOValidVector :: Ctx -> (Text, Text, A.Value) -> Assertion +testKeyIOValidVector ctx (a, payload, obj) + | disabled = return () -- There are invalid version 1 bech32 addresses + | isPrv = do + -- Test from WIF to SecKey + let isComp = obj ^?! key "isCompressed" . _Bool + prvKeyM = fromWif net a + prvKeyHexM = encodeHex . (.key.get) <$> prvKeyM + assertBool "Valid PrvKey" $ isJust prvKeyM + assertEqual "Valid compression" (Just isComp) ((.compress) <$> prvKeyM) + assertEqual "WIF matches payload" (Just payload) prvKeyHexM + let prvAsPubM :: Maybe ScriptOutput + prvAsPubM = (eitherToMaybe . unmarshal ctx <=< decodeHex) a + assertBool "PrvKey is invalid ScriptOutput" $ isNothing prvAsPubM + -- Test from SecKey to WIF + let secM = secKey =<< decodeHex payload + wifM = toWif net . wrapSecKey isComp <$> secM + assertEqual "Payload matches WIF" (Just a) wifM + | otherwise = do + -- Test Addr to Script + let addrM = textToAddr net a + scriptM = encodeHex . marshal ctx . addressToOutput <$> addrM + assertBool ("Valid Address " <> cs a) $ isJust addrM + assertEqual "Address matches payload" (Just payload) scriptM + let pubAsWifM = fromWif net a + pubAsSecM = secKey =<< decodeHex a + assertBool "Address is invalid Wif" $ isNothing pubAsWifM + assertBool "Address is invalid PrvKey" $ isNothing pubAsSecM + -- Test Script to Addr + let outM = eitherToMaybe . unmarshal ctx =<< decodeHex payload + resM = addrToText net =<< outputAddress ctx =<< outM + assertEqual "Payload matches address" (Just a) resM + where + isPrv = obj ^?! key "isPrivkey" . _Bool + disabled = fromMaybe False $ obj ^? key "disabled" . _Bool + chain = obj ^?! key "chain" . _String + net = + case chain of + "main" -> btc + "test" -> btcTest + "regtest" -> btcRegTest + _ -> error "Invalid chain key in key_io_valid.json" + +testKeyIOInvalidVector :: Ctx -> [Text] -> Assertion +testKeyIOInvalidVector ctx [a] = do + let wifMs = (`fromWif` a) <$> allNets + secKeyM = (secKey <=< decodeHex) a + scriptM :: Maybe ScriptOutput + scriptM = (eitherToMaybe . unmarshal ctx <=< decodeHex) a + assertBool "Payload is invalid WIF" $ all isNothing wifMs + assertBool "Payload is invalid SecKey" $ isNothing secKeyM + assertBool "Payload is invalid Script" $ isNothing scriptM +testKeyIOInvalidVector _ _ = assertFailure "Invalid test vector" + +-- Test vectors from: +-- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_tests.cpp + +testPrivkey :: Assertion +testPrivkey = do + assertBool "Key 1" $ isJust $ fromWif btc strSecret1 + assertBool "Key 2" $ isJust $ fromWif btc strSecret2 + assertBool "Key 1C" $ isJust $ fromWif btc strSecret1C + assertBool "Key 2C" $ isJust $ fromWif btc strSecret2C + assertBool "Bad key" $ isNothing $ fromWif btc strAddressBad + +testPrvKeyCompressed :: Assertion +testPrvKeyCompressed = do + assertBool "Key 1" $ not sec1.compress + assertBool "Key 2" $ not sec2.compress + assertBool "Key 1C" sec1C.compress + assertBool "Key 2C" sec2C.compress + +testKeyCompressed :: Ctx -> Assertion +testKeyCompressed ctx = do + assertBool "Key 1" $ not (pub1 ctx).compress + assertBool "Key 2" $ not (pub2 ctx).compress + assertBool "Key 1C" (pub1C ctx).compress + assertBool "Key 2C" (pub2C ctx).compress + +testMatchingAddress :: Ctx -> Assertion +testMatchingAddress ctx = do + assertEqual "Key 1" (Just addr1) $ addrToText btc (pubKeyAddr ctx (pub1 ctx)) + assertEqual "Key 2" (Just addr2) $ addrToText btc (pubKeyAddr ctx (pub2 ctx)) + assertEqual "Key 1C" (Just addr1C) $ addrToText btc (pubKeyAddr ctx (pub1C ctx)) + assertEqual "Key 2C" (Just addr2C) $ addrToText btc (pubKeyAddr ctx (pub2C ctx)) + +testSigs :: Ctx -> Assertion +testSigs ctx = forM_ sigMsg $ testSignature ctx . doubleSHA256 + +sigMsg :: [B.ByteString] +sigMsg = + [ mconcat ["Very secret message ", C.pack (show (i :: Int)), ": 11"] + | i <- [0 .. 15] + ] + +testSignature :: Ctx -> Hash256 -> Assertion +testSignature ctx h = do + let sign1 = signHash ctx sec1.key h + sign2 = signHash ctx sec2.key h + sign1C = signHash ctx sec1C.key h + sign2C = signHash ctx sec2C.key h + assertBool "Key 1, Sign1" $ verifyHashSig ctx h sign1 (pub1 ctx).point + assertBool "Key 1, Sign2" $ not $ verifyHashSig ctx h sign2 (pub1 ctx).point + assertBool "Key 1, Sign1C" $ verifyHashSig ctx h sign1C (pub1 ctx).point + assertBool "Key 1, Sign2C" $ not $ verifyHashSig ctx h sign2C (pub1 ctx).point + assertBool "Key 2, Sign1" $ not $ verifyHashSig ctx h sign1 (pub2 ctx).point + assertBool "Key 2, Sign2" $ verifyHashSig ctx h sign2 (pub2 ctx).point + assertBool "Key 2, Sign1C" $ not $ verifyHashSig ctx h sign1C (pub2 ctx).point + assertBool "Key 2, Sign2C" $ verifyHashSig ctx h sign2C (pub2 ctx).point + assertBool "Key 1C, Sign1" $ verifyHashSig ctx h sign1 (pub1C ctx).point + assertBool "Key 1C, Sign2" $ not $ verifyHashSig ctx h sign2 (pub1C ctx).point + assertBool "Key 1C, Sign1C" $ verifyHashSig ctx h sign1C (pub1C ctx).point + assertBool "Key 1C, Sign2C" $ not $ verifyHashSig ctx h sign2C (pub1C ctx).point + assertBool "Key 2C, Sign1" $ not $ verifyHashSig ctx h sign1 (pub2C ctx).point + assertBool "Key 2C, Sign2" $ verifyHashSig ctx h sign2 (pub2C ctx).point + assertBool "Key 2C, Sign1C" $ not $ verifyHashSig ctx h sign1C (pub2C ctx).point + assertBool "Key 2C, Sign2C" $ verifyHashSig ctx h sign2C (pub2C ctx).point + +testDetSigning :: Ctx -> Assertion +testDetSigning ctx = do + let m = doubleSHA256 ("Very deterministic message" :: B.ByteString) + assertEqual + "Det sig 1" + (signHash ctx sec1.key m) + (signHash ctx sec1C.key m) + assertEqual + "Det sig 2" + (signHash ctx sec2.key m) + (signHash ctx sec2C.key m) + +strSecret1, strSecret2, strSecret1C, strSecret2C :: Text +strSecret1 = "5HxWvvfubhXpYYpS3tJkw6fq9jE9j18THftkZjHHfmFiWtmAbrj" +strSecret2 = "5KC4ejrDjv152FGwP386VD1i2NYc5KkfSMyv1nGy1VGDxGHqVY3" +strSecret1C = "Kwr371tjA9u2rFSMZjTNun2PXXP3WPZu2afRHTcta6KxEUdm1vEw" +strSecret2C = "L3Hq7a8FEQwJkW1M2GNKDW28546Vp5miewcCzSqUD9kCAXrJdS3g" + +sec1, sec2, sec1C, sec2C :: PrivateKey +sec1 = fromJust $ fromWif btc strSecret1 +sec2 = fromJust $ fromWif btc strSecret2 +sec1C = fromJust $ fromWif btc strSecret1C +sec2C = fromJust $ fromWif btc strSecret2C + +addr1, addr2, addr1C, addr2C :: Text +addr1 = "1QFqqMUD55ZV3PJEJZtaKCsQmjLT6JkjvJ" +addr2 = "1F5y5E5FMc5YzdJtB9hLaUe43GDxEKXENJ" +addr1C = "1NoJrossxPBKfCHuJXT4HadJrXRE9Fxiqs" +addr2C = "1CRj2HyM1CXWzHAXLQtiGLyggNT9WQqsDs" + +strAddressBad :: Text +strAddressBad = "1HV9Lc3sNHZxwj4Zk6fB38tEmBryq2cBiF" + +pub1, pub2, pub1C, pub2C :: Ctx -> PublicKey +pub1 ctx = derivePublicKey ctx sec1 +pub2 ctx = derivePublicKey ctx sec2 +pub1C ctx = derivePublicKey ctx sec1C +pub2C ctx = derivePublicKey ctx sec2C diff --git a/test/Haskoin/Crypto/SignatureSpec.hs b/test/Haskoin/Crypto/SignatureSpec.hs index 7de6d3df..9e6c3deb 100644 --- a/test/Haskoin/Crypto/SignatureSpec.hs +++ b/test/Haskoin/Crypto/SignatureSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module Haskoin.Crypto.SignatureSpec (spec) where @@ -5,114 +7,120 @@ module Haskoin.Crypto.SignatureSpec (spec) where import Control.Monad import Data.Bits (testBit) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Maybe import Data.Serialize as S import Data.String.Conversions (cs) import Data.Text (Text) import Haskoin.Address -import Haskoin.Constants import Haskoin.Crypto -import Haskoin.Keys +import Haskoin.Network.Constants import Haskoin.Script import Haskoin.Transaction import Haskoin.Util import Haskoin.Util.Arbitrary -import Haskoin.UtilSpec (readTestFile) import Test.HUnit import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck spec :: Spec -spec = do - describe "Signature properties" $ do - prop "verify signature" $ - forAll arbitrarySignature $ \(m, key', sig) -> - verifyHashSig m sig (derivePubKey key') - prop "s component less than half order" $ - forAll arbitrarySignature $ isCanonicalHalfOrder . lst3 - prop "encoded signature is canonical" $ - forAll arbitrarySignature $ testIsCanonical . lst3 - prop "decodeStrictSig . exportSig identity" $ - forAll arbitrarySignature $ - (\s -> decodeStrictSig (exportSig s) == Just s) . lst3 - prop "importSig . exportSig identity" $ - forAll arbitrarySignature $ - (\s -> importSig (exportSig s) == Just s) . lst3 - prop "getSig . putSig identity" $ - forAll arbitrarySignature $ - (\s -> runGet getSig (runPut $ putSig s) == Right s) . lst3 - describe "Signature vectors" $ - checkDistSig $ \file1 file2 -> do - vectors <- runIO (readTestFile file1 :: IO [(Text, Text, Text)]) - vectorsDER <- runIO (readTestFile file2 :: IO [(Text, Text, Text)]) - it "Passes the trezor rfc6979 test vectors" $ - mapM_ (testRFC6979Vector . toVector) vectors - it "Passes the rfc6979 DER test vectors" $ - mapM_ (testRFC6979DERVector . toVector) vectorsDER - describe "BIP143 signature vectors" $ do - it "agrees with BIP143 p2wpkh example" testBip143p2wpkh - it "agrees with BIP143 p2sh-p2wpkh example" testBip143p2shp2wpkh - it "builds a p2wsh multisig transaction" testP2WSHMulsig - it "agrees with BIP143 p2sh-p2wsh multisig example" testBip143p2shp2wpkhMulsig +spec = prepareContext $ \ctx -> do + describe "Signature property checks" $ do + prop "verifies signature" $ + forAll (arbitrarySignature ctx) $ \(m, key', sig) -> + verifyHashSig ctx m sig (derivePubKey ctx key') + prop "s component less than half order" $ + forAll (arbitrarySignature ctx) $ + isCanonicalHalfOrder ctx . lst3 + prop "encoded signature is canonical" $ + forAll (arbitrarySignature ctx) $ + testIsCanonical ctx . lst3 + prop "decodeStrictSig . exportSig identity" $ + forAll (arbitrarySignature ctx) $ + (\s -> decodeStrictSig ctx (exportSig ctx s) == Just s) . lst3 + prop "importSig . exportSig identity" $ + forAll (arbitrarySignature ctx) $ + (\s -> importSig ctx (exportSig ctx s) == Just s) . lst3 + prop "signature JSON identity" $ + forAll (arbitrarySignature ctx) $ + (\s -> (unmarshalJSON ctx . marshalJSON ctx) s == Just s) . lst3 + prop "getSig . putSig identity" $ + forAll (arbitrarySignature ctx) $ + (\s -> unmarshal ctx (marshal ctx s) == Right s) . lst3 + describe "Signature vectors" $ do + it "passes RFC6979 test vectors" $ + checkDistSig ctx $ \file1 file2 -> do + vectors <- readTestFile file1 :: IO [(Text, Text, Text)] + vectorsDER <- readTestFile file2 :: IO [(Text, Text, Text)] + mapM_ (testRFC6979Vector ctx . toVector) vectors + mapM_ (testRFC6979DERVector ctx . toVector) vectorsDER + describe "BIP143 signature vectors" $ do + it "agrees with BIP143 p2wpkh example" $ + testBip143p2wpkh ctx + it "agrees with BIP143 p2sh-p2wpkh example" $ + testBip143p2shp2wpkh ctx + it "builds a p2wsh multisig transaction" $ + testP2WSHMulsig ctx + it "agrees with BIP143 p2sh-p2wsh multisig example" $ + testBip143p2shp2wpkhMulsig ctx -- github.com/bitcoin/bitcoin/blob/master/src/script.cpp -- from function IsCanonicalSignature -testIsCanonical :: Sig -> Bool -testIsCanonical sig = - not $ - -- Non-canonical signature: too short - (len < 8) - || - -- Non-canonical signature: too long - (len > 72) - || - -- Non-canonical signature: wrong type - (BS.index s 0 /= 0x30) - || - -- Non-canonical signature: wrong length marker - (BS.index s 1 /= len - 2) - || - -- Non-canonical signature: S length misplaced - (5 + rlen >= len) - || - -- Non-canonical signature: R+S length mismatch - (rlen + slen + 6 /= len) - || - -- Non-canonical signature: R value type mismatch - (BS.index s 2 /= 0x02) - || - -- Non-canonical signature: R length is zero - (rlen == 0) - || - -- Non-canonical signature: R value negative - testBit (BS.index s 4) 7 - || - -- Non-canonical signature: R value excessively padded - ( rlen > 1 - && BS.index s 4 == 0 - && not (testBit (BS.index s 5) 7) - ) - || - -- Non-canonical signature: S value type mismatch - (BS.index s (fromIntegral rlen + 4) /= 0x02) - || - -- Non-canonical signature: S length is zero - (slen == 0) - || - -- Non-canonical signature: S value negative - testBit (BS.index s (fromIntegral rlen + 6)) 7 - || - -- Non-canonical signature: S value excessively padded - ( slen > 1 - && BS.index s (fromIntegral rlen + 6) == 0 - && not (testBit (BS.index s (fromIntegral rlen + 7)) 7) - ) +testIsCanonical :: Ctx -> Sig -> Bool +testIsCanonical ctx sig = + not $ + -- Non-canonical signature: too short + (len < 8) + || + -- Non-canonical signature: too long + (len > 72) + || + -- Non-canonical signature: wrong type + (BS.index s 0 /= 0x30) + || + -- Non-canonical signature: wrong length marker + (BS.index s 1 /= len - 2) + || + -- Non-canonical signature: S length misplaced + (5 + rlen >= len) + || + -- Non-canonical signature: R+S length mismatch + (rlen + slen + 6 /= len) + || + -- Non-canonical signature: R value type mismatch + (BS.index s 2 /= 0x02) + || + -- Non-canonical signature: R length is zero + (rlen == 0) + || + -- Non-canonical signature: R value negative + testBit (BS.index s 4) 7 + || + -- Non-canonical signature: R value excessively padded + ( rlen > 1 + && BS.index s 4 == 0 + && not (testBit (BS.index s 5) 7) + ) + || + -- Non-canonical signature: S value type mismatch + (BS.index s (fromIntegral rlen + 4) /= 0x02) + || + -- Non-canonical signature: S length is zero + (slen == 0) + || + -- Non-canonical signature: S value negative + testBit (BS.index s (fromIntegral rlen + 6)) 7 + || + -- Non-canonical signature: S value excessively padded + ( slen > 1 + && BS.index s (fromIntegral rlen + 6) == 0 + && not (testBit (BS.index s (fromIntegral rlen + 7)) 7) + ) where - s = exportSig sig + s = exportSig ctx sig len = fromIntegral $ BS.length s rlen = BS.index s 3 slen = BS.index s (fromIntegral rlen + 5) @@ -123,49 +131,46 @@ testIsCanonical sig = -- between implementations. We check the output of signMsg 1 0 data ValidImpl - = ImplCore - | ImplABC + = ImplCore + | ImplCash -implSig :: Text -implSig = - encodeHex $ - exportSig $ - signMsg - "0000000000000000000000000000000000000000000000000000000000000001" - "0000000000000000000000000000000000000000000000000000000000000000" +implSig :: Ctx -> Text +implSig ctx = + encodeHex $ + exportSig ctx $ + signMsg + ctx + "0000000000000000000000000000000000000000000000000000000000000001" + "0000000000000000000000000000000000000000000000000000000000000000" -- We have test vectors for these cases validImplMap :: Map Text ValidImpl validImplMap = - Map.fromList - [ - ( "3045022100a0b37f8fba683cc68f6574cd43b39f0343a50008bf6ccea9d13231\ - \d9e7e2e1e4022011edc8d307254296264aebfc3dc76cd8b668373a072fd64665\ - \b50000e9fcce52" - , ImplCore - ) - , - ( "304402200581361d23e645be9e3efe63a9a2ac2e8dd0c70ba3ac8554c9befe06\ - \0ad0b36202207d8172f1e259395834793d81b17e986f1e6131e4734969d2f4ae\ - \3a9c8bc42965" - , ImplABC - ) - ] + Map.fromList + [ ( "3045022100a0b37f8fba683cc68f6574cd43b39f0343a50008bf6ccea9d13231\ + \d9e7e2e1e4022011edc8d307254296264aebfc3dc76cd8b668373a072fd64665\ + \b50000e9fcce52", + ImplCore + ), + ( "304402200581361d23e645be9e3efe63a9a2ac2e8dd0c70ba3ac8554c9befe06\ + \0ad0b36202207d8172f1e259395834793d81b17e986f1e6131e4734969d2f4ae\ + \3a9c8bc42965", + ImplCash + ) + ] -getImpl :: Maybe ValidImpl -getImpl = implSig `Map.lookup` validImplMap +getImpl :: Ctx -> Maybe ValidImpl +getImpl ctx = implSig ctx `Map.lookup` validImplMap rfc6979files :: ValidImpl -> (FilePath, FilePath) rfc6979files ImplCore = ("rfc6979core.json", "rfc6979DERcore.json") -rfc6979files ImplABC = ("rfc6979abc.json", "rfc6979DERabc.json") +rfc6979files ImplCash = ("rfc6979cash.json", "rfc6979DERcash.json") -checkDistSig :: (FilePath -> FilePath -> Spec) -> Spec -checkDistSig go = - case rfc6979files <$> getImpl of - Just (file1, file2) -> go file1 file2 - _ -> - it "Passes rfc6979 test vectors" $ - void $ assertFailure "Invalid rfc6979 signature" +checkDistSig :: Ctx -> (FilePath -> FilePath -> Assertion) -> Assertion +checkDistSig ctx go = + case rfc6979files <$> getImpl ctx of + Just (file1, file2) -> go file1 file2 + _ -> assertFailure "invalid RFC6979 signature" {- Trezor RFC 6979 Test Vectors -} -- github.com/trezor/python-ecdsa/blob/master/ecdsa/test_pyecdsa.py @@ -173,272 +178,272 @@ checkDistSig go = toVector :: (Text, Text, Text) -> (SecKey, ByteString, Text) toVector (prv, m, res) = (fromJust $ (secKey <=< decodeHex) prv, cs m, res) -testRFC6979Vector :: (SecKey, ByteString, Text) -> Assertion -testRFC6979Vector (prv, m, res) = do - assertEqual "RFC 6979 Vector" res (encodeHex $ encode $ exportCompactSig s) - assertBool "Signature is valid" $ verifyHashSig h s (derivePubKey prv) - assertBool "Signature is canonical" $ testIsCanonical s - assertBool "Signature is normalized" $ isCanonicalHalfOrder s +testRFC6979Vector :: Ctx -> (SecKey, ByteString, Text) -> Assertion +testRFC6979Vector ctx (prv, m, res) = do + assertEqual "RFC 6979 Vector" res (encodeHex (exportCompactSig ctx s).get) + assertBool "Signature is valid" $ verifyHashSig ctx h s (derivePubKey ctx prv) + assertBool "Signature is canonical" $ testIsCanonical ctx s + assertBool "Signature is normalized" $ isCanonicalHalfOrder ctx s where h = sha256 m - s = signHash prv h + s = signHash ctx prv h -- Test vectors from: -- https://crypto.stackexchange.com/questions/20838/request-for-data-to-test-deterministic-ecdsa-signature-algorithm-for-secp256k1 -testRFC6979DERVector :: (SecKey, ByteString, Text) -> Assertion -testRFC6979DERVector (prv, m, res) = do - assertEqual "RFC 6979 DER Vector" res (encodeHex $ exportSig s) - assertBool "DER Signature is valid" $ verifyHashSig h s (derivePubKey prv) - assertBool "DER Signature is canonical" $ testIsCanonical s - assertBool "DER Signature is normalized" $ isCanonicalHalfOrder s +testRFC6979DERVector :: Ctx -> (SecKey, ByteString, Text) -> Assertion +testRFC6979DERVector ctx (prv, m, res) = do + assertEqual "RFC 6979 DER Vector" res (encodeHex $ exportSig ctx s) + assertBool "DER Signature is valid" $ verifyHashSig ctx h s (derivePubKey ctx prv) + assertBool "DER Signature is canonical" $ testIsCanonical ctx s + assertBool "DER Signature is normalized" $ isCanonicalHalfOrder ctx s where h = sha256 m - s = signHash prv h + s = signHash ctx prv h -- Reproduce the P2WPKH example from BIP 143 -testBip143p2wpkh :: Assertion -testBip143p2wpkh = - case getImpl of - Just ImplCore -> - assertEqual "BIP143 Core p2wpkh" (Right signedTxCore) generatedSignedTx - Just ImplABC -> - assertEqual "BIP143 ABC p2wpkh" (Right signedTxABC) generatedSignedTx - Nothing -> assertFailure "Invalid secp256k1 library" +testBip143p2wpkh :: Ctx -> Assertion +testBip143p2wpkh ctx = + case getImpl ctx of + Just ImplCore -> + assertEqual "BIP143 Core p2wpkh" (Right signedTxCore) generatedSignedTx + Just ImplCash -> + assertEqual "BIP143 ABC p2wpkh" (Right signedTxCash) generatedSignedTx + Nothing -> assertFailure "Invalid secp256k1 library" where signedTxCore = - "01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\ - \541db4e4ad969f00000000494830450221008b9d1dc26ba6a9cb62127b02742f\ - \a9d754cd3bebf337f7a55d114c8e5cdd30be022040529b194ba3f9281a99f2b1\ - \c0a19c0489bc22ede944ccf4ecbab4cc618ef3ed01eeffffffef51e1b804cc89\ - \d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffff\ - \ffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac\ - \7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0\ - \167faa815988ac000247304402203609e17b84f6a7d30c80bfa610b5b4542f32\ - \a8a0d5447a12fb1366d7f01cc44a0220573a954c4518331561406f90300e8f33\ - \58f51928d43c212a8caed02de67eebee0121025476c2e83188368da1ff3e292e\ - \7acafcdb3566bb0ad253f62fc70f07aeee635711000000" - signedTxABC = - "01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\ - \541db4e4ad969f000000004847304402200fbc9dad97500334e47c2dca50096a\ - \2117c01952c2870102e320823d21c36229022007cb36c2b141d11c08ef81d948\ - \f148332fc09fe8f6d226aaaf8ba6ae0d8a66ba01eeffffffef51e1b804cc89d1\ - \82d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffff\ - \ff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a\ - \6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f016\ - \7faa815988ac0002473044022011cb891cee521eb1fc7aef681655a881288553\ - \fc024cff9cee5007bae5e6b8c602200b89d60ee2f98aa9a645dad59cd680b4b6\ - \25f343efcd3e7fb70852100ef601890121025476c2e83188368da1ff3e292e7a\ - \cafcdb3566bb0ad253f62fc70f07aeee635711000000" + "01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\ + \541db4e4ad969f00000000494830450221008b9d1dc26ba6a9cb62127b02742f\ + \a9d754cd3bebf337f7a55d114c8e5cdd30be022040529b194ba3f9281a99f2b1\ + \c0a19c0489bc22ede944ccf4ecbab4cc618ef3ed01eeffffffef51e1b804cc89\ + \d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffff\ + \ffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac\ + \7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0\ + \167faa815988ac000247304402203609e17b84f6a7d30c80bfa610b5b4542f32\ + \a8a0d5447a12fb1366d7f01cc44a0220573a954c4518331561406f90300e8f33\ + \58f51928d43c212a8caed02de67eebee0121025476c2e83188368da1ff3e292e\ + \7acafcdb3566bb0ad253f62fc70f07aeee635711000000" + signedTxCash = + "01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\ + \541db4e4ad969f000000004847304402200fbc9dad97500334e47c2dca50096a\ + \2117c01952c2870102e320823d21c36229022007cb36c2b141d11c08ef81d948\ + \f148332fc09fe8f6d226aaaf8ba6ae0d8a66ba01eeffffffef51e1b804cc89d1\ + \82d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffff\ + \ff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a\ + \6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f016\ + \7faa815988ac0002473044022011cb891cee521eb1fc7aef681655a881288553\ + \fc024cff9cee5007bae5e6b8c602200b89d60ee2f98aa9a645dad59cd680b4b6\ + \25f343efcd3e7fb70852100ef601890121025476c2e83188368da1ff3e292e7a\ + \cafcdb3566bb0ad253f62fc70f07aeee635711000000" unsignedTx = - "0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541d\ - \b4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e815b\ - \1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb20600000000\ - \1976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d0000\ - \00001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac11000000" + "0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541d\ + \b4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e815b\ + \1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb20600000000\ + \1976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d0000\ + \00001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac11000000" Just key0 = - secHexKey - "bbc27228ddcb9209d7fd6f36b02f7dfa6252af40bb2f1cbc7a557da8027ff866" - pubKey0 = toPubKey key0 + secHexKey + "bbc27228ddcb9209d7fd6f36b02f7dfa6252af40bb2f1cbc7a557da8027ff866" + pubKey0 = toPubKey ctx key0 Just key1 = - secHexKey - "619c335025c7f4012e556c2a58b2506e30b8511b53ade95ea316fd8c3286feb9" - [op0, op1] = prevOutput <$> txIn unsignedTx + secHexKey + "619c335025c7f4012e556c2a58b2506e30b8511b53ade95ea316fd8c3286feb9" + [op0, op1] = (.outpoint) <$> unsignedTx.inputs sigIn0 = SigInput (PayPK pubKey0) 625000000 op0 sigHashAll Nothing - WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key1 + WitnessPubKeyAddress h = pubKeyWitnessAddr ctx $ toPubKey ctx key1 sigIn1 = SigInput (PayWitnessPKHash h) 600000000 op1 sigHashAll Nothing - generatedSignedTx = signTx btc unsignedTx [sigIn0, sigIn1] [key0, key1] + generatedSignedTx = signTx btc ctx unsignedTx [sigIn0, sigIn1] [key0, key1] -- Reproduce the P2SH-P2WPKH example from BIP 143 -testBip143p2shp2wpkh :: Assertion -testBip143p2shp2wpkh = - case getImpl of - Just ImplCore -> - assertEqual "BIP143 Core p2sh-p2wpkh" (Right signedTxCore) generatedSignedTx - Just ImplABC -> - assertEqual "BIP143 ABC p2sh-p2wpkh" (Right signedTxABC) generatedSignedTx - Nothing -> assertFailure "Invalid secp256k1 library" +testBip143p2shp2wpkh :: Ctx -> Assertion +testBip143p2shp2wpkh ctx = + case getImpl ctx of + Just ImplCore -> + assertEqual "BIP143 Core p2sh-p2wpkh" (Right signedTxCore) generatedSignedTx + Just ImplCash -> + assertEqual "BIP143 Cash p2sh-p2wpkh" (Right signedTxCash) generatedSignedTx + Nothing -> assertFailure "Invalid secp256k1 library" where signedTxCore = - "01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\ - \ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\ - \df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\ - \c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\ - \a7ad0402e8bd8ad6d77c88ac02473044022047ac8e878352d3ebbde1c94ce3a1\ - \0d057c24175747116f8288e5d794d12d482f0220217f36a485cae903c713331d\ - \877c1f64677e3622ad4010726870540656fe9dcb012103ad1d8e89212f0b92c7\ - \4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000" - signedTxABC = - "01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\ - \ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\ - \df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\ - \c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\ - \a7ad0402e8bd8ad6d77c88ac024730440220091c78fd1e21535f6ddc45515e4c\ - \afca15cdf344765d72c1529fb82d3ada2d1802204a980d5e37d0b04f5e1185a0\ - \f97295c383764e9a4b08d8bd1161b33c6719139a012103ad1d8e89212f0b92c7\ - \4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000" + "01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\ + \ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\ + \df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\ + \c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\ + \a7ad0402e8bd8ad6d77c88ac02473044022047ac8e878352d3ebbde1c94ce3a1\ + \0d057c24175747116f8288e5d794d12d482f0220217f36a485cae903c713331d\ + \877c1f64677e3622ad4010726870540656fe9dcb012103ad1d8e89212f0b92c7\ + \4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000" + signedTxCash = + "01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\ + \ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\ + \df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\ + \c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\ + \a7ad0402e8bd8ad6d77c88ac024730440220091c78fd1e21535f6ddc45515e4c\ + \afca15cdf344765d72c1529fb82d3ada2d1802204a980d5e37d0b04f5e1185a0\ + \f97295c383764e9a4b08d8bd1161b33c6719139a012103ad1d8e89212f0b92c7\ + \4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000" unsignedTx = - "0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d\ - \3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b684d7\ - \f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b\ - \1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000" + "0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d\ + \3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b684d7\ + \f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b\ + \1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000" Just key0 = - secHexKey - "eb696a065ef48a2192da5b28b694f87544b30fae8327c4510137a922f32c6dcf" - op0 = prevOutput . head $ txIn unsignedTx - WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key0 + secHexKey + "eb696a065ef48a2192da5b28b694f87544b30fae8327c4510137a922f32c6dcf" + op0 = (head unsignedTx.inputs).outpoint + WitnessPubKeyAddress h = pubKeyWitnessAddr ctx $ toPubKey ctx key0 sigIn0 = SigInput (PayWitnessPKHash h) 1000000000 op0 sigHashAll Nothing - generatedSignedTx = signNestedWitnessTx btc unsignedTx [sigIn0] [key0] + generatedSignedTx = signNestedWitnessTx btc ctx unsignedTx [sigIn0] [key0] -- P2WSH multisig example (tested against bitcoin-core 0.19.0.1) -testP2WSHMulsig :: Assertion -testP2WSHMulsig = - case getImpl of - Just ImplCore -> - assertEqual "Core p2wsh multisig" (Right signedTxCore) generatedSignedTx - Just ImplABC -> - assertEqual "ABC p2wsh multisig" (Right signedTxABC) generatedSignedTx - Nothing -> assertFailure "Invalid secp256k1 library" +testP2WSHMulsig :: Ctx -> Assertion +testP2WSHMulsig ctx = + case getImpl ctx of + Just ImplCore -> + assertEqual "Core p2wsh multisig" (Right signedTxCore) generatedSignedTx + Just ImplCash -> + assertEqual "Cash p2wsh multisig" (Right signedTxCash) generatedSignedTx + Nothing -> assertFailure "Invalid secp256k1 library" where signedTxCore = - "01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\ - \34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\ - \2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100fad4fedd2b\ - \b4c439c64637eb8e9150d9020a7212808b8dc0578d5ff5b4ad65fe0220714640\ - \f261b37eb3106310bf853f4b706e51436fb6b64c2ab00768814eb55b98014730\ - \44022100baff4e4ceea4022b9725a2e6f6d77997a554f858165b91ac8c16c983\ - \3008bee9021f5f70ebc3f8580dc0a5e96451e3697bdf1f1f5883944f0f33ab0c\ - \fb272354040169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea811\ - \549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f69e\ - \a311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695e2\ - \d8e007a7f26db96c2ee42db15dc953ae00000000" - signedTxABC = - "01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\ - \34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\ - \2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100b79bf3714a\ - \50f8f0e2f946034361ba4f6567b796d55910d89e98720d2e99f98c0220134879\ - \518002df23e80a058475fa8b10bc4182bedfecd5f85e446a00f211ea53014830\ - \45022100ce3c77480d664430a7544c1a962d1ae31151109a528a37e5bccc92ba\ - \2e460ad10220317bc9a71d0c3471058d16d4c3b1ea99616208db6b9b9040fb81\ - \0a7fa27f72b40169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea8\ - \11549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f6\ - \9ea311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695\ - \e2d8e007a7f26db96c2ee42db15dc953ae00000000" + "01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\ + \34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\ + \2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100fad4fedd2b\ + \b4c439c64637eb8e9150d9020a7212808b8dc0578d5ff5b4ad65fe0220714640\ + \f261b37eb3106310bf853f4b706e51436fb6b64c2ab00768814eb55b98014730\ + \44022100baff4e4ceea4022b9725a2e6f6d77997a554f858165b91ac8c16c983\ + \3008bee9021f5f70ebc3f8580dc0a5e96451e3697bdf1f1f5883944f0f33ab0c\ + \fb272354040169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea811\ + \549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f69e\ + \a311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695e2\ + \d8e007a7f26db96c2ee42db15dc953ae00000000" + signedTxCash = + "01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\ + \34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\ + \2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100b79bf3714a\ + \50f8f0e2f946034361ba4f6567b796d55910d89e98720d2e99f98c0220134879\ + \518002df23e80a058475fa8b10bc4182bedfecd5f85e446a00f211ea53014830\ + \45022100ce3c77480d664430a7544c1a962d1ae31151109a528a37e5bccc92ba\ + \2e460ad10220317bc9a71d0c3471058d16d4c3b1ea99616208db6b9b9040fb81\ + \0a7fa27f72b40169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea8\ + \11549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f6\ + \9ea311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695\ + \e2d8e007a7f26db96c2ee42db15dc953ae00000000" unsignedTx = - "0100000001d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a4\ - \48c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab\ - \583b12fbcb26d1269b4a2c951a33ad88ac00000000" - op0 = head $ prevOutput <$> txIn unsignedTx + "0100000001d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a4\ + \48c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab\ + \583b12fbcb26d1269b4a2c951a33ad88ac00000000" + op0 = (head unsignedTx.inputs).outpoint Just keys = - traverse - secHexKey - [ "3030303030303030303030303030303030303030303030303030303030303031" - , "3030303030303030303030303030303030303030303030303030303030303032" - , "3030303030303030303030303030303030303030303030303030303030303033" - ] - rdm = PayMulSig (toPubKey <$> keys) 2 + traverse + secHexKey + [ "3030303030303030303030303030303030303030303030303030303030303031", + "3030303030303030303030303030303030303030303030303030303030303032", + "3030303030303030303030303030303030303030303030303030303030303033" + ] + rdm = PayMulSig (toPubKey ctx <$> keys) 2 sigIn = - SigInput - (toP2WSH $ encodeOutput rdm) - 100000000 - op0 - sigHashAll - (Just rdm) - generatedSignedTx = signTx btc unsignedTx [sigIn] (take 2 keys) + SigInput + (toP2WSH $ encodeOutput ctx rdm) + 100000000 + op0 + sigHashAll + (Just rdm) + generatedSignedTx = signTx btc ctx unsignedTx [sigIn] (take 2 keys) -- Reproduce the P2SH-P2WSH multisig example from BIP 143 -testBip143p2shp2wpkhMulsig :: Assertion -testBip143p2shp2wpkhMulsig = - case getImpl of - Just ImplCore -> - assertEqual - "BIP143 Core p2sh-p2wsh multisig" - (Right signedTxCore) - generatedSignedTx - Just ImplABC -> - assertEqual - "BIP143 Core p2sh-p2wsh multisig" - (Right signedTxABC) - generatedSignedTx - Nothing -> assertFailure "Invalid secp256k1 library" +testBip143p2shp2wpkhMulsig :: Ctx -> Assertion +testBip143p2shp2wpkhMulsig ctx = + case getImpl ctx of + Just ImplCore -> + assertEqual + "BIP143 Core p2sh-p2wsh multisig" + (Right signedTxCore) + generatedSignedTx + Just ImplCash -> + assertEqual + "BIP143 Core p2sh-p2wsh multisig" + (Right signedTxCash) + generatedSignedTx + Nothing -> assertFailure "Invalid secp256k1 library" where signedTxCore = - "0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\ - \6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\ - \9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\ - \389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\ - \a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac080047304402206a\ - \c44d672dac41f9b00e28f4df20c52eeb087207e8d758d76d92c6fab3b73e2b02\ - \20367750dbbe19290069cba53d096f44530e4f98acaa594810388cf7409a1870\ - \ce01473044022068c7946a43232757cbdf9176f009a928e1cd9a1a8c212f15c1\ - \e11ac9f2925d9002205b75f937ff2f9f3c1246e547e54f62e027f64eefa26955\ - \78cc6432cdabce271502473044022059ebf56d98010a932cf8ecfec54c48e613\ - \9ed6adb0728c09cbe1e4fa0915302e022007cd986c8fa870ff5d2b3a89139c9f\ - \e7e499259875357e20fcbb15571c76795403483045022100fbefd94bd0a488d5\ - \0b79102b5dad4ab6ced30c4069f1eaa69a4b5a763414067e02203156c6a5c9cf\ - \88f91265f5a942e96213afae16d83321c8b31bb342142a14d163814830450221\ - \00a5263ea0553ba89221984bd7f0b13613db16e7a70c549a86de0cc0444141a4\ - \07022005c360ef0ae5a5d4f9f2f87a56c1546cc8268cab08c73501d6b3be2e1e\ - \1a8a08824730440220525406a1482936d5a21888260dc165497a90a15669636d\ - \8edca6b9fe490d309c022032af0c646a34a44d1f4576bf6a4a74b67940f8faa8\ - \4c7df9abe12a01a11e2b4783cf56210307b8ae49ac90a048e9b53357a2354b33\ - \34e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac5c\ - \3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b97\ - \81957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a9a\ - \21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94ba0\ - \4d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b330\ - \2ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000" - signedTxABC = - "0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\ - \6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\ - \9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\ - \389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\ - \a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac0800483045022100\ - \b70b684ef0d17b51adf71c0dae932beca5d447dd5eec03394328436bdba836e7\ - \0220208ebfd7408d21e41da11d8287655528385429d3fe300bee241f10944339\ - \5b580147304402204b5f9bc06c8f0a252b9842ea44785853beb1638002cec5f2\ - \489d73e5f6f5109302204f3b132b32638835d4b1a651e7d18dc93c10192db553\ - \999932af6a8e3d8a153202483045022100e0ed8d3a245a138c751d74e1359aee\ - \6a52476ddf33a3a9a5f0c2ad30147319650220581318187061ad0f48fc4f5c85\ - \1822e554d59977005b8de4b78bf2ce2fe8399703483045022100a0a40abc581e\ - \4b725775a3aa93bf0f0fd9a02ad3aa0f93483214784a47ba5387022069151c30\ - \f85a7e20c8671107c5af884ee4c5a82bd06398327fa68a993f7cc64b81473044\ - \022016d828460f6fab3cf89ae4b87c8f02c11c798cf739967f3b7406e7367c29\ - \ae8b022079e82b822eb6c37a66efabc3f0b40a2b98c52f848d36463f6623cbdc\ - \fe675812824730440220225a14ba7434858dbb5e6e0a0969ddf3b5455edaabf9\ - \9f5773d1f59e7816b918022047ed1ab87840a74f7e9489f3af051e5fd26b790f\ - \b308c79f4b0ed73c0422795d83cf56210307b8ae49ac90a048e9b53357a2354b\ - \3334e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac\ - \5c3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b\ - \9781957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a\ - \9a21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94b\ - \a04d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b3\ - \302ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000" + "0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\ + \6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\ + \9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\ + \389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\ + \a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac080047304402206a\ + \c44d672dac41f9b00e28f4df20c52eeb087207e8d758d76d92c6fab3b73e2b02\ + \20367750dbbe19290069cba53d096f44530e4f98acaa594810388cf7409a1870\ + \ce01473044022068c7946a43232757cbdf9176f009a928e1cd9a1a8c212f15c1\ + \e11ac9f2925d9002205b75f937ff2f9f3c1246e547e54f62e027f64eefa26955\ + \78cc6432cdabce271502473044022059ebf56d98010a932cf8ecfec54c48e613\ + \9ed6adb0728c09cbe1e4fa0915302e022007cd986c8fa870ff5d2b3a89139c9f\ + \e7e499259875357e20fcbb15571c76795403483045022100fbefd94bd0a488d5\ + \0b79102b5dad4ab6ced30c4069f1eaa69a4b5a763414067e02203156c6a5c9cf\ + \88f91265f5a942e96213afae16d83321c8b31bb342142a14d163814830450221\ + \00a5263ea0553ba89221984bd7f0b13613db16e7a70c549a86de0cc0444141a4\ + \07022005c360ef0ae5a5d4f9f2f87a56c1546cc8268cab08c73501d6b3be2e1e\ + \1a8a08824730440220525406a1482936d5a21888260dc165497a90a15669636d\ + \8edca6b9fe490d309c022032af0c646a34a44d1f4576bf6a4a74b67940f8faa8\ + \4c7df9abe12a01a11e2b4783cf56210307b8ae49ac90a048e9b53357a2354b33\ + \34e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac5c\ + \3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b97\ + \81957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a9a\ + \21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94ba0\ + \4d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b330\ + \2ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000" + signedTxCash = + "0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\ + \6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\ + \9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\ + \389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\ + \a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac0800483045022100\ + \b70b684ef0d17b51adf71c0dae932beca5d447dd5eec03394328436bdba836e7\ + \0220208ebfd7408d21e41da11d8287655528385429d3fe300bee241f10944339\ + \5b580147304402204b5f9bc06c8f0a252b9842ea44785853beb1638002cec5f2\ + \489d73e5f6f5109302204f3b132b32638835d4b1a651e7d18dc93c10192db553\ + \999932af6a8e3d8a153202483045022100e0ed8d3a245a138c751d74e1359aee\ + \6a52476ddf33a3a9a5f0c2ad30147319650220581318187061ad0f48fc4f5c85\ + \1822e554d59977005b8de4b78bf2ce2fe8399703483045022100a0a40abc581e\ + \4b725775a3aa93bf0f0fd9a02ad3aa0f93483214784a47ba5387022069151c30\ + \f85a7e20c8671107c5af884ee4c5a82bd06398327fa68a993f7cc64b81473044\ + \022016d828460f6fab3cf89ae4b87c8f02c11c798cf739967f3b7406e7367c29\ + \ae8b022079e82b822eb6c37a66efabc3f0b40a2b98c52f848d36463f6623cbdc\ + \fe675812824730440220225a14ba7434858dbb5e6e0a0969ddf3b5455edaabf9\ + \9f5773d1f59e7816b918022047ed1ab87840a74f7e9489f3af051e5fd26b790f\ + \b308c79f4b0ed73c0422795d83cf56210307b8ae49ac90a048e9b53357a2354b\ + \3334e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac\ + \5c3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b\ + \9781957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a\ + \9a21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94b\ + \a04d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b3\ + \302ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000" unsignedTx = - "010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1c\ - \a29787b96e0100000000ffffffff0200e9a435000000001976a914389ffce9cd\ - \9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a3\ - \3f950689af511e6e84c138dbbd3c3ee41588ac00000000" - op0 = head $ prevOutput <$> txIn unsignedTx + "010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1c\ + \a29787b96e0100000000ffffffff0200e9a435000000001976a914389ffce9cd\ + \9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a3\ + \3f950689af511e6e84c138dbbd3c3ee41588ac00000000" + op0 = (head unsignedTx.inputs).outpoint rawKeys = - [ "730fff80e1413068a05b57d6a58261f07551163369787f349438ea38ca80fac6" - , "11fa3d25a17cbc22b29c44a484ba552b5a53149d106d3d853e22fdd05a2d8bb3" - , "77bf4141a87d55bdd7f3cd0bdccf6e9e642935fec45f2f30047be7b799120661" - , "14af36970f5025ea3e8b5542c0f8ebe7763e674838d08808896b63c3351ffe49" - , "fe9a95c19eef81dde2b95c1284ef39be497d128e2aa46916fb02d552485e0323" - , "428a7aee9f0c2af0cd19af3cf1c78149951ea528726989b2e83e4778d2c3f890" - ] + [ "730fff80e1413068a05b57d6a58261f07551163369787f349438ea38ca80fac6", + "11fa3d25a17cbc22b29c44a484ba552b5a53149d106d3d853e22fdd05a2d8bb3", + "77bf4141a87d55bdd7f3cd0bdccf6e9e642935fec45f2f30047be7b799120661", + "14af36970f5025ea3e8b5542c0f8ebe7763e674838d08808896b63c3351ffe49", + "fe9a95c19eef81dde2b95c1284ef39be497d128e2aa46916fb02d552485e0323", + "428a7aee9f0c2af0cd19af3cf1c78149951ea528726989b2e83e4778d2c3f890" + ] Just keys = traverse secHexKey rawKeys - rdm = PayMulSig (toPubKey <$> keys) 6 - sigIn sh = SigInput (toP2WSH $ encodeOutput rdm) 987654321 op0 sh (Just rdm) + rdm = PayMulSig (toPubKey ctx <$> keys) 6 + sigIn sh = SigInput (toP2WSH $ encodeOutput ctx rdm) 987654321 op0 sh (Just rdm) sigHashesA = [sigHashAll, sigHashNone, sigHashSingle] - sigHashesB = setAnyoneCanPayFlag <$> sigHashesA + sigHashesB = setAnyoneCanPay <$> sigHashesA sigIns = sigIn <$> (sigHashesA <> sigHashesB) generatedSignedTx = foldM addSig unsignedTx $ zip sigIns keys - addSig tx (sigIn', key') = signNestedWitnessTx btc tx [sigIn'] [key'] + addSig tx (sigIn', key') = signNestedWitnessTx btc ctx tx [sigIn'] [key'] secHexKey :: Text -> Maybe SecKey secHexKey = decodeHex >=> secKey -toPubKey :: SecKey -> PubKeyI -toPubKey = derivePubKeyI . wrapSecKey True +toPubKey :: Ctx -> SecKey -> PublicKey +toPubKey ctx = derivePublicKey ctx . wrapSecKey True diff --git a/test/Haskoin/Keys/ExtendedSpec.hs b/test/Haskoin/Keys/ExtendedSpec.hs deleted file mode 100644 index 18591f9b..00000000 --- a/test/Haskoin/Keys/ExtendedSpec.hs +++ /dev/null @@ -1,621 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Haskoin.Keys.ExtendedSpec (spec) where - -import Control.Monad (forM_) -import Data.Aeson as A -import Data.Bits ((.&.)) -import qualified Data.ByteString.Lazy.Char8 as B8 -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Either (isLeft) -import Data.Maybe (fromJust, isJust, isNothing) -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word (Word32) -import Haskoin.Address -import Haskoin.Constants -import Haskoin.Keys -import Haskoin.Util -import Haskoin.Util.Arbitrary -import Haskoin.UtilSpec (customCerealID) -import Test.HUnit (Assertion, assertBool, assertEqual) -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck hiding ((.&.)) - -serialVals :: [SerialBox] -serialVals = - [ SerialBox arbitraryDerivPath - , SerialBox arbitraryHardPath - , SerialBox arbitrarySoftPath - ] - -readVals :: [ReadBox] -readVals = - [ ReadBox arbitraryDerivPath - , ReadBox arbitraryHardPath - , ReadBox arbitrarySoftPath - , ReadBox arbitraryXPrvKey - , ReadBox (snd <$> arbitraryXPubKey) - , ReadBox arbitraryParsedPath - , ReadBox arbitraryBip32PathIndex - ] - -jsonVals :: [JsonBox] -jsonVals = - [ JsonBox arbitraryDerivPath - , JsonBox arbitraryHardPath - , JsonBox arbitrarySoftPath - , JsonBox arbitraryParsedPath - ] - -netVals :: [NetBox] -netVals = - [ NetBox - ( xPrvToJSON - , xPrvToEncoding - , xPrvFromJSON - , genNetData arbitraryXPrvKey - ) - , NetBox - ( xPubToJSON - , xPubToEncoding - , xPubFromJSON - , genNetData (snd <$> arbitraryXPubKey) - ) - ] - -spec :: Spec -spec = do - testIdentity serialVals readVals jsonVals netVals - describe "Custom identity tests" $ do - prop "encodes and decodes extended private key" $ - forAll arbitraryNetwork $ \net -> - forAll arbitraryXPrvKey $ - customCerealID (getXPrvKey net) (putXPrvKey net) - prop "encodes and decodes extended public key" $ - forAll arbitraryNetwork $ \net -> - forAll arbitraryXPubKey $ - customCerealID (getXPubKey net) (putXPubKey net) . snd - describe "bip32 subkey derivation vector 1" $ vectorSpec m1 vector1 - describe "bip32 subkey derivation vector 2" $ vectorSpec m2 vector2 - describe "bip32 subkey derivation vector 3" $ vectorSpec m3 vector3 - describe "bip32 subkey derivation using string path" $ do - it "either derivations" testApplyPath - it "either derivations" testBadApplyPath - it "dublic derivations" testDerivePubPath - it "private derivations" testDerivePrvPath - it "path parsing" testParsePath - it "from json" testFromJsonPath - it "to json" testToJsonPath - describe "Derivation Paths" $ do - prop "from string derivation path" $ - forAll arbitraryDerivPath $ \p -> fromString (cs $ pathToStr p) == p - prop "from string hard derivation path" $ - forAll arbitraryHardPath $ \p -> fromString (cs $ pathToStr p) == p - prop "from string soft derivation path" $ - forAll arbitrarySoftPath $ \p -> fromString (cs $ pathToStr p) == p - prop "from and to lists of derivation paths" $ - forAll arbitraryDerivPath $ \p -> listToPath (pathToList p) == p - prop "from and to lists of hard derivation paths" $ - forAll arbitraryHardPath $ \p -> - toHard (listToPath $ pathToList p) == Just p - prop "from and to lists of soft derivation paths" $ - forAll arbitrarySoftPath $ \p -> - toSoft (listToPath $ pathToList p) == Just p - describe "Extended Keys" $ do - let net = btc - prop "computes pubkey of a subkey is subkey of the pubkey" $ - forAll arbitraryXPrvKey pubKeyOfSubKeyIsSubKeyOfPubKey - prop "exports and imports extended private key" $ - forAll arbitraryXPrvKey $ \k -> - xPrvImport net (xPrvExport net k) == Just k - prop "exports and imports extended public key" $ - forAll arbitraryXPubKey $ \(_, k) -> - xPubImport net (xPubExport net k) == Just k - -pubKeyOfSubKeyIsSubKeyOfPubKey :: XPrvKey -> Word32 -> Bool -pubKeyOfSubKeyIsSubKeyOfPubKey k i = - deriveXPubKey (prvSubKey k i') == pubSubKey (deriveXPubKey k) i' - where - i' = fromIntegral $ i .&. 0x7fffffff -- make it a public derivation - -testFromJsonPath :: Assertion -testFromJsonPath = - sequence_ $ do - path <- jsonPathVectors - return $ - assertEqual - path - (Just [fromString path :: DerivPath]) - (A.decode $ B8.pack $ "[\"" ++ path ++ "\"]") - -testToJsonPath :: Assertion -testToJsonPath = - sequence_ $ do - path <- jsonPathVectors - return $ - assertEqual - path - (B8.pack $ "[\"" ++ path ++ "\"]") - (A.encode [fromString path :: ParsedPath]) - -jsonPathVectors :: [String] -jsonPathVectors = - [ "m" - , "m/0" - , "m/0'" - , "M/0'" - , "m/2147483647" - , "M/2147483647" - , "m/1/2/3/4/5/6/7/8" - , "M/1/2/3/4/5/6/7/8" - , "m/1'/2'/3/4" - , "M/1'/2'/3/4" - ] - -testParsePath :: Assertion -testParsePath = - sequence_ $ do - (path, t) <- parsePathVectors - return $ assertBool path (t $ parsePath path) - -parsePathVectors :: [(String, Maybe ParsedPath -> Bool)] -parsePathVectors = - [ ("m", isJust) - , ("m/0'", isJust) - , ("M/0'", isJust) - , ("m/2147483648", isNothing) - , ("m/2147483647", isJust) - , ("M/2147483648", isNothing) - , ("M/2147483647", isJust) - , ("M/-1", isNothing) - , ("M/-2147483648", isNothing) - , ("m/1/2/3/4/5/6/7/8", isJust) - , ("M/1/2/3/4/5/6/7/8", isJust) - , ("m/1'/2'/3/4", isJust) - , ("M/1'/2'/3/4", isJust) - , ("m/1/2'/3/4'", isJust) - , ("M/1/2'/3/4'", isJust) - , ("meh", isNothing) - , ("infinity", isNothing) - , ("NaN", isNothing) - ] - -testApplyPath :: Assertion -testApplyPath = - sequence_ $ do - (key, path, final) <- applyPathVectors - return $ - assertEqual path final $ applyPath (fromJust $ parsePath path) key - -testBadApplyPath :: Assertion -testBadApplyPath = - sequence_ $ do - (key, path) <- badApplyPathVectors - return $ - assertBool path $ isLeft $ applyPath (fromJust $ parsePath path) key - -testDerivePubPath :: Assertion -testDerivePubPath = - sequence_ $ do - (key, path, final) <- derivePubPathVectors - return $ - assertEqual path final $ - derivePubPath (fromString path :: SoftPath) key - -testDerivePrvPath :: Assertion -testDerivePrvPath = - sequence_ $ do - (key, path, final) <- derivePrvPathVectors - return $ - assertEqual path final $ - derivePath (fromString path :: DerivPath) key - -derivePubPathVectors :: [(XPubKey, String, XPubKey)] -derivePubPathVectors = - [ (xpub, "M", xpub) - , (xpub, "M/8", pubSubKey xpub 8) - , (xpub, "M/8/30/1", foldl pubSubKey xpub [8, 30, 1]) - ] - where - xprv = - fromJust $ - xPrvImport - btc - "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ - \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" - xpub = deriveXPubKey xprv - -derivePrvPathVectors :: [(XPrvKey, String, XPrvKey)] -derivePrvPathVectors = - [ (xprv, "m", xprv) - , (xprv, "M", xprv) - , (xprv, "m/8'", hardSubKey xprv 8) - , (xprv, "M/8'", hardSubKey xprv 8) - , - ( xprv - , "m/8'/30/1" - , foldl prvSubKey (hardSubKey xprv 8) [30, 1] - ) - , - ( xprv - , "M/8'/30/1" - , foldl prvSubKey (hardSubKey xprv 8) [30, 1] - ) - , - ( xprv - , "m/3/20" - , foldl prvSubKey xprv [3, 20] - ) - , - ( xprv - , "M/3/20" - , foldl prvSubKey xprv [3, 20] - ) - ] - where - xprv = - fromJust $ - xPrvImport - btc - "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ - \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" - -applyPathVectors :: [(XKey, String, Either String XKey)] -applyPathVectors = - [ (XPrv xprv btc, "m", Right (XPrv xprv btc)) - , (XPrv xprv btc, "M", Right (XPub xpub btc)) - , (XPrv xprv btc, "m/8'", Right (XPrv (hardSubKey xprv 8) btc)) - , - ( XPrv xprv btc - , "M/8'" - , Right (XPub (deriveXPubKey (hardSubKey xprv 8)) btc) - ) - , - ( XPrv xprv btc - , "m/8'/30/1" - , Right (XPrv (foldl prvSubKey (hardSubKey xprv 8) [30, 1]) btc) - ) - , - ( XPrv xprv btc - , "M/8'/30/1" - , Right - ( XPub - (deriveXPubKey (foldl prvSubKey (hardSubKey xprv 8) [30, 1])) - btc - ) - ) - , (XPrv xprv btc, "m/3/20", Right (XPrv (foldl prvSubKey xprv [3, 20]) btc)) - , - ( XPrv xprv btc - , "M/3/20" - , Right (XPub (deriveXPubKey (foldl prvSubKey xprv [3, 20])) btc) - ) - , - ( XPub xpub btc - , "M/3/20" - , Right (XPub (deriveXPubKey (foldl prvSubKey xprv [3, 20])) btc) - ) - ] - where - xprv = - fromJust $ - xPrvImport - btc - "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ - \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" - xpub = deriveXPubKey xprv - -badApplyPathVectors :: [(XKey, String)] -badApplyPathVectors = - [ (XPub xpub btc, "m/8'") - , (XPub xpub btc, "M/8'") - , (XPub xpub btc, "M/1/2/3'/4/5") - ] - where - xprv = - fromJust $ - xPrvImport - btc - "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ - \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" - xpub = deriveXPubKey xprv - --- BIP 0032 Test Vectors --- https://en.bitcoin.it/wiki/BIP_0032_TestVectors - -bip44Addr :: DerivPath -bip44Addr = Deriv :| 44 :| 0 :| 0 :/ 0 :/ 0 - -vectorSpec :: TestKey -> [TestVector] -> Spec -vectorSpec mTxt vecTxt = - forM_ (parseVector mTxt vecTxt) $ \(d, m, v) -> - it ("chain " <> cs d) $ runVector m v - -runVector :: XPrvKey -> TestVector -> Assertion -runVector m v = do - assertBool "xPrvID" $ encodeHex (runPutS . serialize $ xPrvID m) == v !! 0 - assertBool "xPrvFP" $ encodeHex (runPutS . serialize $ xPrvFP m) == v !! 1 - assertBool "xPrvAddr" $ - addrToText btc (xPubAddr $ deriveXPubKey m) == Just (v !! 2) - assertBool "bip44Addr" $ - addrToText btc (xPubAddr $ deriveXPubKey $ derivePath bip44Addr m) - == Just (v !! 3) - assertBool "prvKey" $ encodeHex (getSecKey $ xPrvKey m) == v !! 4 - assertBool "xPrvWIF" $ xPrvWif btc m == v !! 5 - assertBool "pubKey" $ - encodeHex (exportPubKey True $ xPubKey $ deriveXPubKey m) == v !! 6 - assertBool "chain code" $ encodeHex (runPutS . serialize $ xPrvChain m) == v !! 7 - assertBool "Hex PubKey" $ - encodeHex (runPutS $ putXPubKey btc $ deriveXPubKey m) == v !! 8 - assertBool "Hex PrvKey" $ encodeHex (runPutS (putXPrvKey btc m)) == v !! 9 - assertBool "Base58 PubKey" $ xPubExport btc (deriveXPubKey m) == v !! 10 - assertBool "Base58 PrvKey" $ xPrvExport btc m == v !! 11 - --- This function was used to generate addition data for the test vectors -genVector :: XPrvKey -> [(Text, Text)] -genVector m = - [ ("xPrvID", encodeHex (runPutS . serialize $ xPrvID m)) - , ("xPrvFP", encodeHex (runPutS . serialize $ xPrvFP m)) - , ("xPrvAddr", fromJust $ addrToText btc (xPubAddr $ deriveXPubKey m)) - , - ( "bip44Addr" - , fromJust $ - addrToText btc (xPubAddr $ deriveXPubKey $ derivePath bip44Addr m) - ) - , ("prvKey", encodeHex (getSecKey $ xPrvKey m)) - , ("xPrvWIF", xPrvWif btc m) - , ("pubKey", encodeHex (exportPubKey True $ xPubKey $ deriveXPubKey m)) - , ("chain code", encodeHex (runPutS . serialize $ xPrvChain m)) - , ("Hex PubKey", encodeHex (runPutS $ putXPubKey btc $ deriveXPubKey m)) - , ("Hex PrvKey", encodeHex (runPutS (putXPrvKey btc m))) - ] - -parseVector :: TestKey -> [TestVector] -> [(Text, XPrvKey, TestVector)] -parseVector mTxt vs = - go <$> vs - where - mast = makeXPrvKey $ fromJust $ decodeHex mTxt - go (d : vec) = - let deriv = getParsedPath $ fromJust $ parsePath $ cs d - in (d, derivePath deriv mast, vec) - go _ = undefined - -type TestVector = [Text] -type TestKey = Text - -m1 :: TestKey -m1 = "000102030405060708090a0b0c0d0e0f" - -vector1 :: [TestVector] -vector1 = - [ - [ "m" - , "3442193e1bb70916e914552172cd4e2dbc9df811" - , "3442193e" - , "15mKKb2eos1hWa6tisdPwwDC1a5J1y9nma" - , "1NQpH6Nf8QtR2HphLRcvuVqfhXBXsiWn8r" - , "e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" - , "L52XzL2cMkHxqxBXRyEpnPQZGUs3uKiL3R11XbAdHigRzDozKZeW" - , "0339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" - , "873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d508" - , "0488b21e000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d5080339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" - , "0488ade4000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d50800e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" - , "xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8" - , "xprv9s21ZrQH143K3QTDL4LXw2F7HEK3wJUD2nW2nRk4stbPy6cq3jPPqjiChkVvvNKmPGJxWUtg6LnF5kejMRNNU3TGtRBeJgk33yuGBxrMPHi" - ] - , - [ "m/0'" - , "5c1bd648ed23aa5fd50ba52b2457c11e9e80a6a7" - , "5c1bd648" - , "19Q2WoS5hSS6T8GjhK8KZLMgmWaq4neXrh" - , "1DDVw6BRKUv9U8Hzg5rGsia13nDrgJQpBd" - , "edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" - , "L5BmPijJjrKbiUfG4zbiFKNqkvuJ8usooJmzuD7Z8dkRoTThYnAT" - , "035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" - , "47fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141" - , "0488b21e013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" - , "0488ade4013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae623614100edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" - , "xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw" - , "xprv9uHRZZhk6KAJC1avXpDAp4MDc3sQKNxDiPvvkX8Br5ngLNv1TxvUxt4cV1rGL5hj6KCesnDYUhd7oWgT11eZG7XnxHrnYeSvkzY7d2bhkJ7" - ] - , - [ "m/0'/1" - , "bef5a2f9a56a94aab12459f72ad9cf8cf19c7bbe" - , "bef5a2f9" - , "1JQheacLPdM5ySCkrZkV66G2ApAXe1mqLj" - , "1KMg6dRggXSkpz9fFyU76ru83TUSwPePEZ" - , "3c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368" - , "KyFAjQ5rgrKvhXvNMtFB5PCSKUYD1yyPEe3xr3T34TZSUHycXtMM" - , "03501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c" - , "2a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19" - , "0488b21e025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c1903501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c" - , "0488ade4025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19003c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368" - , "xpub6ASuArnXKPbfEwhqN6e3mwBcDTgzisQN1wXN9BJcM47sSikHjJf3UFHKkNAWbWMiGj7Wf5uMash7SyYq527Hqck2AxYysAA7xmALppuCkwQ" - , "xprv9wTYmMFdV23N2TdNG573QoEsfRrWKQgWeibmLntzniatZvR9BmLnvSxqu53Kw1UmYPxLgboyZQaXwTCg8MSY3H2EU4pWcQDnRnrVA1xe8fs" - ] - , - [ "m/0'/1/2'" - , "ee7ab90cde56a8c0e2bb086ac49748b8db9dce72" - , "ee7ab90c" - , "1NjxqbA9aZWnh17q1UW3rB4EPu79wDXj7x" - , "1WykKhR25y7VDT21nZEwUUKSKDz9pENJh" - , "cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca" - , "L43t3od1Gh7Lj55Bzjj1xDAgJDcL7YFo2nEcNaMGiyRZS1CidBVU" - , "0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2" - , "04466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f" - , "0488b21e03bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2" - , "0488ade403bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f00cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca" - , "xpub6D4BDPcP2GT577Vvch3R8wDkScZWzQzMMUm3PWbmWvVJrZwQY4VUNgqFJPMM3No2dFDFGTsxxpG5uJh7n7epu4trkrX7x7DogT5Uv6fcLW5" - , "xprv9z4pot5VBttmtdRTWfWQmoH1taj2axGVzFqSb8C9xaxKymcFzXBDptWmT7FwuEzG3ryjH4ktypQSAewRiNMjANTtpgP4mLTj34bhnZX7UiM" - ] - , - [ "m/0'/1/2'/2" - , "d880d7d893848509a62d8fb74e32148dac68412f" - , "d880d7d8" - , "1LjmJcdPnDHhNTUgrWyhLGnRDKxQjoxAgt" - , "1asQ3smHhv2nv5R6hPpiUfkEorJpsdwwx" - , "0f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4" - , "KwjQsVuMjbCP2Zmr3VaFaStav7NvevwjvvkqrWd5Qmh1XVnCteBR" - , "02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29" - , "cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd" - , "0488b21e04ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29" - , "0488ade404ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd000f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4" - , "xpub6FHa3pjLCk84BayeJxFW2SP4XRrFd1JYnxeLeU8EqN3vDfZmbqBqaGJAyiLjTAwm6ZLRQUMv1ZACTj37sR62cfN7fe5JnJ7dh8zL4fiyLHV" - , "xprvA2JDeKCSNNZky6uBCviVfJSKyQ1mDYahRjijr5idH2WwLsEd4Hsb2Tyh8RfQMuPh7f7RtyzTtdrbdqqsunu5Mm3wDvUAKRHSC34sJ7in334" - ] - , - [ "m/0'/1/2'/2/1000000000" - , "d69aa102255fed74378278c7812701ea641fdf32" - , "d69aa102" - , "1LZiqrop2HGR4qrH1ULZPyBpU6AUP49Uam" - , "1HXJog342VFdc68AB9Cb6LwVmCjvcLMiwm" - , "471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8" - , "Kybw8izYevo5xMh1TK7aUr7jHFCxXS1zv8p3oqFz3o2zFbhRXHYs" - , "022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011" - , "c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e" - , "0488b21e05d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011" - , "0488ade405d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e00471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8" - , "xpub6H1LXWLaKsWFhvm6RVpEL9P4KfRZSW7abD2ttkWP3SSQvnyA8FSVqNTEcYFgJS2UaFcxupHiYkro49S8yGasTvXEYBVPamhGW6cFJodrTHy" - , "xprvA41z7zogVVwxVSgdKUHDy1SKmdb533PjDz7J6N6mV6uS3ze1ai8FHa8kmHScGpWmj4WggLyQjgPie1rFSruoUihUZREPSL39UNdE3BBDu76" - ] - ] - -m2 :: TestKey -m2 = "fffcf9f6f3f0edeae7e4e1dedbd8d5d2cfccc9c6c3c0bdbab7b4b1aeaba8a5a29f9c999693908d8a8784817e7b7875726f6c696663605d5a5754514e4b484542" - -vector2 :: [TestVector] -vector2 = - [ - [ "m" - , "bd16bee53961a47d6ad888e29545434a89bdfe95" - , "bd16bee5" - , "1JEoxevbLLG8cVqeoGKQiAwoWbNYSUyYjg" - , "148CGtv7bwcC933EHtcDfzDQVneur1R8Y1" - , "4b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e" - , "KyjXhyHF9wTphBkfpxjL8hkDXDUSbE3tKANT94kXSyh6vn6nKaoy" - , "03cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7" - , "60499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689" - , "0488b21e00000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd968903cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7" - , "0488ade400000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689004b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e" - , "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB" - , "xprv9s21ZrQH143K31xYSDQpPDxsXRTUcvj2iNHm5NUtrGiGG5e2DtALGdso3pGz6ssrdK4PFmM8NSpSBHNqPqm55Qn3LqFtT2emdEXVYsCzC2U" - ] - , - [ "m/0" - , "5a61ff8eb7aaca3010db97ebda76121610b78096" - , "5a61ff8e" - , "19EuDJdgfRkwCmRzbzVBHZWQG9QNWhftbZ" - , "1KVyTSpsBGYs7NdyZmArEpVTfWJQSgiDCx" - , "abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e" - , "L2ysLrR6KMSAtx7uPqmYpoTeiRzydXBattRXjXz5GDFPrdfPzKbj" - , "02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea" - , "f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c" - , "0488b21e01bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea" - , "0488ade401bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c00abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e" - , "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH" - , "xprv9vHkqa6EV4sPZHYqZznhT2NPtPCjKuDKGY38FBWLvgaDx45zo9WQRUT3dKYnjwih2yJD9mkrocEZXo1ex8G81dwSM1fwqWpWkeS3v86pgKt" - ] - , - [ "m/0/2147483647'" - , "d8ab493736da02f11ed682f88339e720fb0379d1" - , "d8ab4937" - , "1Lke9bXGhn5VPrBuXgN12uGUphrttUErmk" - , "14MFLsfx1nc4RKiaH9khqDTNL9CRz3q347" - , "877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93" - , "L1m5VpbXmMp57P3knskwhoMTLdhAAaXiHvnGLMribbfwzVRpz2Sr" - , "03c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b" - , "be17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d9" - , "0488b21e025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d903c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b" - , "0488ade4025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d900877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93" - , "xpub6ASAVgeehLbnwdqV6UKMHVzgqAG8Gr6riv3Fxxpj8ksbH9ebxaEyBLZ85ySDhKiLDBrQSARLq1uNRts8RuJiHjaDMBU4Zn9h8LZNnBC5y4a" - , "xprv9wSp6B7kry3Vj9m1zSnLvN3xH8RdsPP1Mh7fAaR7aRLcQMKTR2vidYEeEg2mUCTAwCd6vnxVrcjfy2kRgVsFawNzmjuHc2YmYRmagcEPdU9" - ] - , - [ "m/0/2147483647'/1" - , "78412e3a2296a40de124307b6485bd19833e2e34" - , "78412e3a" - , "1BxrAr2pHpeBheusmd6fHDP2tSLAUa3qsW" - , "19ou31MGyGW9VFx7woKBqwLe5JHhQBYaDD" - , "704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7" - , "KzyzXnznxSv249b4KuNkBwowaN3akiNeEHy5FWoPCJpStZbEKXN2" - , "03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9" - , "f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb" - , "0488b21e03d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9" - , "0488ade403d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb00704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7" - , "xpub6DF8uhdarytz3FWdA8TvFSvvAh8dP3283MY7p2V4SeE2wyWmG5mg5EwVvmdMVCQcoNJxGoWaU9DCWh89LojfZ537wTfunKau47EL2dhHKon" - , "xprv9zFnWC6h2cLgpmSA46vutJzBcfJ8yaJGg8cX1e5StJh45BBciYTRXSd25UEPVuesF9yog62tGAQtHjXajPPdbRCHuWS6T8XA2ECKADdw4Ef" - ] - , - [ "m/0/2147483647'/1/2147483646'" - , "31a507b815593dfc51ffc7245ae7e5aee304246e" - , "31a507b8" - , "15XVotxCAV7sRx1PSCkQNsGw3W9jT9A94R" - , "18GYmRm4nyjk8ydvoVXFxMWQvxhksEFDZR" - , "f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d" - , "L5KhaMvPYRW1ZoFmRjUtxxPypQ94m6BcDrPhqArhggdaTbbAFJEF" - , "02d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0" - , "637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e29" - , "0488b21e0478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2902d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0" - , "0488ade40478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2900f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d" - , "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL" - , "xprvA1RpRA33e1JQ7ifknakTFpgNXPmW2YvmhqLQYMmrj4xJXXWYpDPS3xz7iAxn8L39njGVyuoseXzU6rcxFLJ8HFsTjSyQbLYnMpCqE2VbFWc" - ] - , - [ "m/0/2147483647'/1/2147483646'/2" - , "26132fdbe7bf89cbc64cf8dafa3f9f88b8666220" - , "26132fdb" - , "14UKfRV9ZPUp6ZC9PLhqbRtxdihW9em3xt" - , "1758mgwNZhyzpRLe4u7FjqpJtqKpaGhXh7" - , "bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23" - , "L3WAYNAZPxx1fr7KCz7GN9nD5qMBnNiqEJNJMU1z9MMaannAt4aK" - , "024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c" - , "9452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271" - , "0488b21e0531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c" - , "0488ade40531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed27100bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23" - , "xpub6FnCn6nSzZAw5Tw7cgR9bi15UV96gLZhjDstkXXxvCLsUXBGXPdSnLFbdpq8p9HmGsApME5hQTZ3emM2rnY5agb9rXpVGyy3bdW6EEgAtqt" - , "xprvA2nrNbFZABcdryreWet9Ea4LvTJcGsqrMzxHx98MMrotbir7yrKCEXw7nadnHM8Dq38EGfSh6dqA9QWTyefMLEcBYJUuekgW4BYPJcr9E7j" - ] - ] - -m3 :: TestKey -m3 = "4b381541583be4423346c643850da4b320e46a87ae3d2a4e6da11eba819cd4acba45d239319ac14f863b8d5ab5a0d0c64d2e8a1e7d1457df2e5a3c51c73235be" - -vector3 :: [TestVector] -vector3 = - [ - [ "m" - , "41d63b50d8dd5e730cdf4c79a56fc929a757c548" - , "41d63b50" - , "1717ZYpXhZW5CqAbWSjDJbCey3FyKUmCSf" - , "17rxURoF96VhmkcEGCj5LNQkmN9HVhWb7F" - , "00ddb80b067e0d4993197fe10f2657a844a384589847602d56f0c629c81aae32" - , "KwFPqAq9SKx1sPg15Qk56mqkHwrfGPuywtLUxoWPkiTSBoxCs8am" - , "03683af1ba5743bdfc798cf814efeeab2735ec52d95eced528e692b8e34c4e5669" - , "01d28a3e53cffa419ec122c968b3259e16b65076495494d97cae10bbfec3c36f" - , "0488b21e00000000000000000001d28a3e53cffa419ec122c968b3259e16b65076495494d97cae10bbfec3c36f03683af1ba5743bdfc798cf814efeeab2735ec52d95eced528e692b8e34c4e5669" - , "0488ade400000000000000000001d28a3e53cffa419ec122c968b3259e16b65076495494d97cae10bbfec3c36f0000ddb80b067e0d4993197fe10f2657a844a384589847602d56f0c629c81aae32" - , "xpub661MyMwAqRbcEZVB4dScxMAdx6d4nFc9nvyvH3v4gJL378CSRZiYmhRoP7mBy6gSPSCYk6SzXPTf3ND1cZAceL7SfJ1Z3GC8vBgp2epUt13" - , "xprv9s21ZrQH143K25QhxbucbDDuQ4naNntJRi4KUfWT7xo4EKsHt2QJDu7KXp1A3u7Bi1j8ph3EGsZ9Xvz9dGuVrtHHs7pXeTzjuxBrCmmhgC6" - ] - , - [ "m/0'" - , "c61368bb50e066acd95bd04a0b23d3837fb75698" - , "c61368bb" - , "1K4L3YxEwg8HkSEapM4iSiGuR6HeQ53KPX" - , "13QeQVJNNakdUU55P1fc8xPMkkeYVzn4o6" - , "491f7a2eebc7b57028e0d3faa0acda02e75c33b03c48fb288c41e2ea44e1daef" - , "KyfrPaeirL5yYAoZvfzyoKXSdszeLqg5vb6dNy9ymvjzZrMZY8GW" - , "026557fdda1d5d43d79611f784780471f086d58e8126b8c40acb82272a7712e7f2" - , "e5fea12a97b927fc9dc3d2cb0d1ea1cf50aa5a1fdc1f933e8906bb38df3377bd" - , "0488b21e0141d63b5080000000e5fea12a97b927fc9dc3d2cb0d1ea1cf50aa5a1fdc1f933e8906bb38df3377bd026557fdda1d5d43d79611f784780471f086d58e8126b8c40acb82272a7712e7f2" - , "0488ade40141d63b5080000000e5fea12a97b927fc9dc3d2cb0d1ea1cf50aa5a1fdc1f933e8906bb38df3377bd00491f7a2eebc7b57028e0d3faa0acda02e75c33b03c48fb288c41e2ea44e1daef" - , "xpub68NZiKmJWnxxS6aaHmn81bvJeTESw724CRDs6HbuccFQN9Ku14VQrADWgqbhhTHBaohPX4CjNLf9fq9MYo6oDaPPLPxSb7gwQN3ih19Zm4Y" - , "xprv9uPDJpEQgRQfDcW7BkF7eTya6RPxXeJCqCJGHuCJ4GiRVLzkTXBAJMu2qaMWPrS7AANYqdq6vcBcBUdJCVVFceUvJFjaPdGZ2y9WACViL4L" - ] - ] diff --git a/test/Haskoin/Keys/MnemonicSpec.hs b/test/Haskoin/Keys/MnemonicSpec.hs deleted file mode 100644 index faeab484..00000000 --- a/test/Haskoin/Keys/MnemonicSpec.hs +++ /dev/null @@ -1,498 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Haskoin.Keys.MnemonicSpec (spec) where - -import Control.Monad (zipWithM_) -import Data.Bits (shiftR, (.&.)) -import qualified Data.ByteString as BS -import Data.Either (fromRight) -import Data.List (isPrefixOf) -import Data.Maybe (fromJust) -import Data.Serialize (Serialize, encode) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Word (Word32, Word64) -import Haskoin.Keys -import Haskoin.Util -import Haskoin.Util.Arbitrary -import Test.HUnit -import Test.Hspec -import Test.QuickCheck hiding ((.&.)) - -spec :: Spec -spec = - describe "mnemonic" $ do - it "entropy to mnemonic sentence" toMnemonicTest - it "mnemonic sentence to entropy" fromMnemonicTest - it "mnemonic sentence to seed" mnemonicToSeedTest - it "mnemonic sentence with invalid checksum" fromMnemonicInvalidTest - it "empty mnemonic sentence is invalid" $ sequence_ [emptyMnemonicTest] - it "generate 12 words" $ property toMnemonic128 - it "generate 18 words" $ property toMnemonic160 - it "generate 24 words" $ property toMnemonic256 - it "generate 48 words" $ property toMnemonic512 - it "generate any number of words" $ property toMnemonicVar - it "encode and decode 128-bit entropy" $ property fromToMnemonic128 - it "encode and decode 160-bit entropy" $ property fromToMnemonic160 - it "encode and decode 256-bit entropy" $ property fromToMnemonic256 - it "encode and decode 512-bit entropy" $ property fromToMnemonic512 - it "encode and decode n-bit entropy" $ property fromToMnemonicVar - it "convert 128-bit mnemonic to seed" $ property mnemonicToSeed128 - it "convert 160-bit mnemonic to seed" $ property mnemonicToSeed160 - it "convert 256-bit mnemonic to seed" $ property mnemonicToSeed256 - it "convert 512-bit mnemonic to seed" $ property mnemonicToSeed512 - it "convert n-bit mnemonic to seed" $ property mnemonicToSeedVar - it "get bits" $ property getBitsByteCount - it "get end bits" $ property getBitsEndBits - -toMnemonicTest :: Assertion -toMnemonicTest = zipWithM_ f ents mss - where - f e m = assertEqual "" m . h $ e - h = - fromRight (error "Could not decode mnemonic sentence") - . toMnemonic - . fromJust - . decodeHex - -fromMnemonicTest :: Assertion -fromMnemonicTest = zipWithM_ f ents mss - where - f e = assertEqual "" e . h - h = - encodeHex - . fromRight (error "Could not decode mnemonic sentence") - . fromMnemonic - -mnemonicToSeedTest :: Assertion -mnemonicToSeedTest = zipWithM_ f mss seeds - where - f m s = assertEqual "" s . h $ m - h = - encodeHex - . fromRight (error "Could not decode mnemonic seed") - . mnemonicToSeed "TREZOR" - -fromMnemonicInvalidTest :: Assertion -fromMnemonicInvalidTest = mapM_ f invalidMss - where - f = assertBool "" . h - h m = case fromMnemonic m of - Right _ -> False - Left err -> "fromMnemonic: checksum failed:" `isPrefixOf` err - -emptyMnemonicTest :: Assertion -emptyMnemonicTest = - assertBool "" $ - case fromMnemonic "" of - Right _ -> False - Left err -> "fromMnemonic: empty mnemonic" `isPrefixOf` err - -ents :: [Text] -ents = - [ "00000000000000000000000000000000" - , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" - , "80808080808080808080808080808080" - , "ffffffffffffffffffffffffffffffff" - , "000000000000000000000000000000000000000000000000" - , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" - , "808080808080808080808080808080808080808080808080" - , "ffffffffffffffffffffffffffffffffffffffffffffffff" - , "0000000000000000000000000000000000000000000000000000000000000000" - , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" - , "8080808080808080808080808080808080808080808080808080808080808080" - , "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" - , "77c2b00716cec7213839159e404db50d" - , "b63a9c59a6e641f288ebc103017f1da9f8290b3da6bdef7b" - , "3e141609b97933b66a060dcddc71fad1d91677db872031e85f4c015c5e7e8982" - , "0460ef47585604c5660618db2e6a7e7f" - , "72f60ebac5dd8add8d2a25a797102c3ce21bc029c200076f" - , "2c85efc7f24ee4573d2b81a6ec66cee209b2dcbd09d8eddc51e0215b0b68e416" - , "eaebabb2383351fd31d703840b32e9e2" - , "7ac45cfe7722ee6c7ba84fbc2d5bd61b45cb2fe5eb65aa78" - , "4fa1a8bc3e6d80ee1316050e862c1812031493212b7ec3f3bb1b08f168cabeef" - , "18ab19a9f54a9274f03e5209a2ac8a91" - , "18a2e1d81b8ecfb2a333adcb0c17a5b9eb76cc5d05db91a4" - , "15da872c95a13dd738fbf50e427583ad61f18fd99f628c417a61cf8343c90419" - ] - -mss :: [Mnemonic] -mss = - [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon about" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ yellow" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage above" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo wrong" - , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon abandon abandon agent" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ year wave sausage worth useful legal will" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage absurd amount doctor acoustic avoid letter always" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ - \ when" - , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon art" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ year wave sausage worth useful legal winner thank year wave sausage\ - \ worth title" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ - \ amount doctor acoustic bless" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ - \ zoo zoo zoo zoo zoo vote" - , "jelly better achieve collect unaware mountain thought cargo oxygen act\ - \ hood bridge" - , "renew stay biology evidence goat welcome casual join adapt armor shuffle\ - \ fault little machine walk stumble urge swap" - , "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ - \ multiply desk host tomato cradle drill spread actor shine dismiss\ - \ champion exotic" - , "afford alter spike radar gate glance object seek swamp infant panel\ - \ yellow" - , "indicate race push merry suffer human cruise dwarf pole review arch keep\ - \ canvas theme poem divorce alter left" - , "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ - \ recipe series open hour vintage deposit universe tip job dress radar\ - \ refuse motion taste" - , "turtle front uncle idea crush write shrug there lottery flower risk\ - \ shell" - , "kiss carry display unusual confirm curtain upgrade antique rotate hello\ - \ void custom frequent obey nut hole price segment" - , "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ - \ catch course end lucky hurt sentence oven short ball bird grab wing top" - , "board flee heavy tunnel powder denial science ski answer betray cargo\ - \ cat" - , "board blade invite damage undo sun mimic interest slam gaze truly\ - \ inherit resist great inject rocket museum chief" - , "beyond stage sleep clip because twist token leaf atom beauty genius food\ - \ business side grid unable middle armed observe pair crouch tonight away\ - \ coconut" - ] - -seeds :: [Text] -seeds = - [ "c55257c360c07c72029aebc1b53c05ed0362ada38ead3e3e9efa3708e53495531f09a69\ - \87599d18264c1e1c92f2cf141630c7a3c4ab7c81b2f001698e7463b04" - , "2e8905819b8723fe2c1d161860e5ee1830318dbf49a83bd451cfb8440c28bd6fa457fe1\ - \296106559a3c80937a1c1069be3a3a5bd381ee6260e8d9739fce1f607" - , "d71de856f81a8acc65e6fc851a38d4d7ec216fd0796d0a6827a3ad6ed5511a30fa280f1\ - \2eb2e47ed2ac03b5c462a0358d18d69fe4f985ec81778c1b370b652a8" - , "ac27495480225222079d7be181583751e86f571027b0497b5b5d11218e0a8a133325729\ - \17f0f8e5a589620c6f15b11c61dee327651a14c34e18231052e48c069" - , "035895f2f481b1b0f01fcf8c289c794660b289981a78f8106447707fdd9666ca06da5a9\ - \a565181599b79f53b844d8a71dd9f439c52a3d7b3e8a79c906ac845fa" - , "f2b94508732bcbacbcc020faefecfc89feafa6649a5491b8c952cede496c214a0c7b3c3\ - \92d168748f2d4a612bada0753b52a1c7ac53c1e93abd5c6320b9e95dd" - , "107d7c02a5aa6f38c58083ff74f04c607c2d2c0ecc55501dadd72d025b751bc27fe913f\ - \fb796f841c49b1d33b610cf0e91d3aa239027f5e99fe4ce9e5088cd65" - , "0cd6e5d827bb62eb8fc1e262254223817fd068a74b5b449cc2f667c3f1f985a76379b43\ - \348d952e2265b4cd129090758b3e3c2c49103b5051aac2eaeb890a528" - , "bda85446c68413707090a52022edd26a1c9462295029f2e60cd7c4f2bbd3097170af7a4\ - \d73245cafa9c3cca8d561a7c3de6f5d4a10be8ed2a5e608d68f92fcc8" - , "bc09fca1804f7e69da93c2f2028eb238c227f2e9dda30cd63699232578480a4021b146a\ - \d717fbb7e451ce9eb835f43620bf5c514db0f8add49f5d121449d3e87" - , "c0c519bd0e91a2ed54357d9d1ebef6f5af218a153624cf4f2da911a0ed8f7a09e2ef61a\ - \f0aca007096df430022f7a2b6fb91661a9589097069720d015e4e982f" - , "dd48c104698c30cfe2b6142103248622fb7bb0ff692eebb00089b32d22484e1613912f0\ - \a5b694407be899ffd31ed3992c456cdf60f5d4564b8ba3f05a69890ad" - , "b5b6d0127db1a9d2226af0c3346031d77af31e918dba64287a1b44b8ebf63cdd52676f6\ - \72a290aae502472cf2d602c051f3e6f18055e84e4c43897fc4e51a6ff" - , "9248d83e06f4cd98debf5b6f010542760df925ce46cf38a1bdb4e4de7d21f5c39366941\ - \c69e1bdbf2966e0f6e6dbece898a0e2f0a4c2b3e640953dfe8b7bbdc5" - , "ff7f3184df8696d8bef94b6c03114dbee0ef89ff938712301d27ed8336ca89ef9635da2\ - \0af07d4175f2bf5f3de130f39c9d9e8dd0472489c19b1a020a940da67" - , "65f93a9f36b6c85cbe634ffc1f99f2b82cbb10b31edc7f087b4f6cb9e976e9faf76ff41\ - \f8f27c99afdf38f7a303ba1136ee48a4c1e7fcd3dba7aa876113a36e4" - , "3bbf9daa0dfad8229786ace5ddb4e00fa98a044ae4c4975ffd5e094dba9e0bb289349db\ - \e2091761f30f382d4e35c4a670ee8ab50758d2c55881be69e327117ba" - , "fe908f96f46668b2d5b37d82f558c77ed0d69dd0e7e043a5b0511c48c2f1064694a956f\ - \86360c93dd04052a8899497ce9e985ebe0c8c52b955e6ae86d4ff4449" - , "bdfb76a0759f301b0b899a1e3985227e53b3f51e67e3f2a65363caedf3e32fde42a66c4\ - \04f18d7b05818c95ef3ca1e5146646856c461c073169467511680876c" - , "ed56ff6c833c07982eb7119a8f48fd363c4a9b1601cd2de736b01045c5eb8ab4f57b079\ - \403485d1c4924f0790dc10a971763337cb9f9c62226f64fff26397c79" - , "095ee6f817b4c2cb30a5a797360a81a40ab0f9a4e25ecd672a3f58a0b5ba0687c096a6b\ - \14d2c0deb3bdefce4f61d01ae07417d502429352e27695163f7447a8c" - , "6eff1bb21562918509c73cb990260db07c0ce34ff0e3cc4a8cb3276129fbcb300bddfe0\ - \05831350efd633909f476c45c88253276d9fd0df6ef48609e8bb7dca8" - , "f84521c777a13b61564234bf8f8b62b3afce27fc4062b51bb5e62bdfecb23864ee6ecf0\ - \7c1d5a97c0834307c5c852d8ceb88e7c97923c0a3b496bedd4e5f88a9" - , "b15509eaa2d09d3efd3e006ef42151b30367dc6e3aa5e44caba3fe4d3e352e65101fbdb\ - \86a96776b91946ff06f8eac594dc6ee1d3e82a42dfe1b40fef6bcc3fd" - ] - -invalidMss :: [Mnemonic] -invalidMss = - [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ thank" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage sausage" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo" - , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon abandon abandon abandon" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ year wave sausage worth useful legal letter" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage absurd amount doctor acoustic avoid letter abandon" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ - \ zoo" - , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ year wave sausage worth useful legal winner thank year wave sausage\ - \ worth letter" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ - \ amount doctor acoustic letter" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ - \ zoo zoo zoo zoo zoo zoo" - , "jelly better achieve collect unaware mountain thought cargo oxygen act\ - \ hood zoo" - , "renew stay biology evidence goat welcome casual join adapt armor shuffle\ - \ fault little machine walk stumble urge zoo" - , "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ - \ multiply desk host tomato cradle drill spread actor shine dismiss\ - \ champion zoo" - , "afford alter spike radar gate glance object seek swamp infant panel\ - \ zoo" - , "indicate race push merry suffer human cruise dwarf pole review arch keep\ - \ canvas theme poem divorce alter zoo" - , "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ - \ recipe series open hour vintage deposit universe tip job dress radar\ - \ refuse motion zoo" - , "turtle front uncle idea crush write shrug there lottery flower risk\ - \ zoo" - , "kiss carry display unusual confirm curtain upgrade antique rotate hello\ - \ void custom frequent obey nut hole price zoo" - , "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ - \ catch course end lucky hurt sentence oven short ball bird grab wing zoo" - , "board flee heavy tunnel powder denial science ski answer betray cargo\ - \ zoo" - , "board blade invite damage undo sun mimic interest slam gaze truly\ - \ inherit resist great inject rocket museum zoo" - , "beyond stage sleep clip because twist token leaf atom beauty genius food\ - \ business side grid unable middle armed observe pair crouch tonight away\ - \ zoo" - ] - -binWordsToBS :: Serialize a => [a] -> BS.ByteString -binWordsToBS = foldr f BS.empty - where - f b a = a `BS.append` encode b - -{- Encode mnemonic -} - -toMnemonic128 :: (Word64, Word64) -> Bool -toMnemonic128 (a, b) = l == 12 - where - bs = encode a `BS.append` encode b - l = - length - . T.words - . fromRight (error "Could not decode mnemonic senttence") - $ toMnemonic bs - -toMnemonic160 :: (Word32, Word64, Word64) -> Bool -toMnemonic160 (a, b, c) = l == 15 - where - bs = BS.concat [encode a, encode b, encode c] - l = - length - . T.words - . fromRight (error "Could not decode mnemonic sentence") - $ toMnemonic bs - -toMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool -toMnemonic256 (a, b, c, d) = l == 24 - where - bs = BS.concat [encode a, encode b, encode c, encode d] - l = - length - . T.words - . fromRight (error "Could not decode mnemonic sentence") - $ toMnemonic bs - -toMnemonic512 :: - ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool -toMnemonic512 ((a, b, c, d), (e, f, g, h)) = l == 48 - where - bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h - ] - l = - length - . T.words - . fromRight (error "Could not decode mnemonic sentence") - $ toMnemonic bs - -toMnemonicVar :: [Word32] -> Property -toMnemonicVar ls = not (null ls) && length ls <= 8 ==> l == wc - where - bs = binWordsToBS ls - bl = BS.length bs - cb = bl `div` 4 - wc = (cb + bl * 8) `div` 11 - l = - length . T.words - . fromRight (error "Could not decode mnemonic sentence") - $ toMnemonic bs - -{- Encode/Decode -} - -fromToMnemonic128 :: (Word64, Word64) -> Bool -fromToMnemonic128 (a, b) = bs == bs' - where - bs = encode a `BS.append` encode b - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -fromToMnemonic160 :: (Word32, Word64, Word64) -> Bool -fromToMnemonic160 (a, b, c) = bs == bs' - where - bs = BS.concat [encode a, encode b, encode c] - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -fromToMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool -fromToMnemonic256 (a, b, c, d) = bs == bs' - where - bs = BS.concat [encode a, encode b, encode c, encode d] - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -fromToMnemonic512 :: - ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool -fromToMnemonic512 ((a, b, c, d), (e, f, g, h)) = bs == bs' - where - bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h - ] - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -fromToMnemonicVar :: [Word32] -> Property -fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == bs' - where - bs = binWordsToBS ls - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -{- Mnemonic to seed -} - -mnemonicToSeed128 :: (Word64, Word64) -> Bool -mnemonicToSeed128 (a, b) = l == 64 - where - bs = encode a `BS.append` encode b - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -mnemonicToSeed160 :: (Word32, Word64, Word64) -> Bool -mnemonicToSeed160 (a, b, c) = l == 64 - where - bs = BS.concat [encode a, encode b, encode c] - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -mnemonicToSeed256 :: (Word64, Word64, Word64, Word64) -> Bool -mnemonicToSeed256 (a, b, c, d) = l == 64 - where - bs = BS.concat [encode a, encode b, encode c, encode d] - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -mnemonicToSeed512 :: - ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool -mnemonicToSeed512 ((a, b, c, d), (e, f, g, h)) = l == 64 - where - bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h - ] - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -mnemonicToSeedVar :: [Word32] -> Property -mnemonicToSeedVar ls = not (null ls) && length ls <= 16 ==> l == 64 - where - bs = binWordsToBS ls - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -{- Get bits from ByteString -} - -data ByteCountGen = ByteCountGen BS.ByteString Int deriving (Show) - -instance Arbitrary ByteCountGen where - arbitrary = do - bs <- arbitraryBS - i <- choose (0, BS.length bs * 8) - return $ ByteCountGen bs i - -getBitsByteCount :: ByteCountGen -> Bool -getBitsByteCount (ByteCountGen bs i) = BS.length bits == l - where - (q, r) = i `quotRem` 8 - bits = getBits i bs - l = if r == 0 then q else q + 1 - -getBitsEndBits :: ByteCountGen -> Bool -getBitsEndBits (ByteCountGen bs i) = - (r == 0) || (BS.last bits .&. (0xff `shiftR` r) == 0x00) - where - r = i `mod` 8 - bits = getBits i bs diff --git a/test/Haskoin/KeysSpec.hs b/test/Haskoin/KeysSpec.hs deleted file mode 100644 index 9407e0ce..00000000 --- a/test/Haskoin/KeysSpec.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Haskoin.KeysSpec (spec) where - -import Control.Lens -import Control.Monad -import Data.Aeson as A -import Data.Aeson.Lens -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Maybe -import qualified Data.Serialize as S -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Haskoin.Address -import Haskoin.Constants -import Haskoin.Crypto -import Haskoin.Keys -import Haskoin.Script -import Haskoin.Util -import Haskoin.Util.Arbitrary -import Haskoin.UtilSpec (readTestFile) -import Test.HUnit -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck - -serialVals :: [SerialBox] -serialVals = - [ SerialBox (snd <$> arbitraryKeyPair) -- PubKeyI - ] - -readVals :: [ReadBox] -readVals = - [ ReadBox (arbitrary :: Gen SecKey) - , ReadBox arbitrarySecKeyI - , ReadBox (snd <$> arbitraryKeyPair) -- PubKeyI - ] - -jsonVals :: [JsonBox] -jsonVals = - [ JsonBox (snd <$> arbitraryKeyPair) -- PubKeyI - ] - -spec :: Spec -spec = do - testIdentity serialVals readVals jsonVals [] - describe "PubKey properties" $ do - prop "Public key is canonical" $ - forAll arbitraryKeyPair (isCanonicalPubKey . snd) - prop "Public key fromString identity" $ - forAll arbitraryKeyPair $ \(_, k) -> - fromString (cs . encodeHex $ runPutS $ serialize k) == k - describe "SecKey properties" $ - prop "fromWif . toWif identity" $ - forAll arbitraryNetwork $ \net -> - forAll arbitraryKeyPair $ \(pk, _) -> - fromWif net (toWif net pk) == Just pk - describe "Bitcoin core vectors /src/test/key_tests.cpp" $ do - it "Passes WIF decoding tests" testPrivkey - it "Passes SecKey compression tests" testPrvKeyCompressed - it "Passes PubKey compression tests" testKeyCompressed - it "Passes address matching tests" testMatchingAddress - it "Passes signature verification" testSigs - it "Passes deterministic signing tests" testDetSigning - describe "MiniKey vectors" $ - it "Passes MiniKey decoding tests" testMiniKey - describe "key_io_valid.json vectors" $ do - vectors <- runIO (readTestFile "key_io_valid.json" :: IO [(Text, Text, A.Value)]) - it "Passes the key_io_valid.json vectors" $ - mapM_ testKeyIOValidVector vectors - describe "key_io_invalid.json vectors" $ do - vectors <- runIO (readTestFile "key_io_invalid.json" :: IO [[Text]]) - it "Passes the key_io_invalid.json vectors" $ - mapM_ testKeyIOInvalidVector vectors - --- github.com/bitcoin/bitcoin/blob/master/src/script.cpp --- from function IsCanonicalPubKey -isCanonicalPubKey :: PubKeyI -> Bool -isCanonicalPubKey p = - not $ - -- Non-canonical public key: too short - (BS.length bs < 33) - || - -- Non-canonical public key: invalid length for uncompressed key - (BS.index bs 0 == 4 && BS.length bs /= 65) - || - -- Non-canonical public key: invalid length for compressed key - (BS.index bs 0 `elem` [2, 3] && BS.length bs /= 33) - || - -- Non-canonical public key: compressed nor uncompressed - (BS.index bs 0 `notElem` [2, 3, 4]) - where - bs = runPutS $ serialize p - -testMiniKey :: Assertion -testMiniKey = - assertEqual "fromMiniKey" (Just res) (go "S6c56bnXQiBjk9mqSYE7ykVQ7NzrRy") - where - go = fmap (encodeHex . runPutS . S.put . secKeyData) . fromMiniKey - res = "4c7a9640c72dc2099f23715d0c8a0d8a35f8906e3cab61dd3f78b67bf887c9ab" - --- Test vectors from: --- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_io_tests.cpp - -testKeyIOValidVector :: (Text, Text, A.Value) -> Assertion -testKeyIOValidVector (a, payload, obj) - | disabled = return () -- There are invalid version 1 bech32 addresses - | isPrv = do - -- Test from WIF to SecKey - let isComp = obj ^?! key "isCompressed" . _Bool - prvKeyM = fromWif net a - prvKeyHexM = encodeHex . runPutS . S.put . secKeyData <$> prvKeyM - assertBool "Valid PrvKey" $ isJust prvKeyM - assertEqual "Valid compression" (Just isComp) (secKeyCompressed <$> prvKeyM) - assertEqual "WIF matches payload" (Just payload) prvKeyHexM - let prvAsPubM = (eitherToMaybe . decodeOutputBS <=< decodeHex) a - assertBool "PrvKey is invalid ScriptOutput" $ isNothing prvAsPubM - -- Test from SecKey to WIF - let secM = eitherToMaybe . runGetS S.get =<< decodeHex payload - wifM = toWif net . wrapSecKey isComp <$> secM - assertEqual "Payload matches WIF" (Just a) wifM - | otherwise = do - -- Test Addr to Script - let addrM = textToAddr net a - scriptM = encodeHex . encodeOutputBS . addressToOutput <$> addrM - assertBool ("Valid Address " <> cs a) $ isJust addrM - assertEqual "Address matches payload" (Just payload) scriptM - let pubAsWifM = fromWif net a - pubAsSecM = - eitherToMaybe . runGetS S.get - =<< decodeHex a :: - Maybe SecKey - assertBool "Address is invalid Wif" $ isNothing pubAsWifM - assertBool "Address is invalid PrvKey" $ isNothing pubAsSecM - -- Test Script to Addr - let outM = eitherToMaybe . decodeOutputBS =<< decodeHex payload - resM = addrToText net =<< outputAddress =<< outM - assertEqual "Payload matches address" (Just a) resM - where - isPrv = obj ^?! key "isPrivkey" . _Bool - disabled = fromMaybe False $ obj ^? key "disabled" . _Bool - chain = obj ^?! key "chain" . _String - net = - case chain of - "main" -> btc - "test" -> btcTest - "regtest" -> btcRegTest - _ -> error "Invalid chain key in key_io_valid.json" - -testKeyIOInvalidVector :: [Text] -> Assertion -testKeyIOInvalidVector [a] = do - let wifMs = (`fromWif` a) <$> allNets - secKeyM = (eitherToMaybe . runGetS S.get <=< decodeHex) a :: Maybe SecKey - scriptM = (eitherToMaybe . decodeOutputBS <=< decodeHex) a :: Maybe ScriptOutput - assertBool "Payload is invalid WIF" $ all isNothing wifMs - assertBool "Payload is invalid SecKey" $ isNothing secKeyM - assertBool "Payload is invalid Script" $ isNothing scriptM -testKeyIOInvalidVector _ = assertFailure "Invalid test vector" - --- Test vectors from: --- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_tests.cpp - -testPrivkey :: Assertion -testPrivkey = do - assertBool "Key 1" $ isJust $ fromWif btc strSecret1 - assertBool "Key 2" $ isJust $ fromWif btc strSecret2 - assertBool "Key 1C" $ isJust $ fromWif btc strSecret1C - assertBool "Key 2C" $ isJust $ fromWif btc strSecret2C - assertBool "Bad key" $ isNothing $ fromWif btc strAddressBad - -testPrvKeyCompressed :: Assertion -testPrvKeyCompressed = do - assertBool "Key 1" $ not $ secKeyCompressed sec1 - assertBool "Key 2" $ not $ secKeyCompressed sec2 - assertBool "Key 1C" $ secKeyCompressed sec1C - assertBool "Key 2C" $ secKeyCompressed sec2C - -testKeyCompressed :: Assertion -testKeyCompressed = do - assertBool "Key 1" $ not $ pubKeyCompressed pub1 - assertBool "Key 2" $ not $ pubKeyCompressed pub2 - assertBool "Key 1C" $ pubKeyCompressed pub1C - assertBool "Key 2C" $ pubKeyCompressed pub2C - -testMatchingAddress :: Assertion -testMatchingAddress = do - assertEqual "Key 1" (Just addr1) $ addrToText btc (pubKeyAddr pub1) - assertEqual "Key 2" (Just addr2) $ addrToText btc (pubKeyAddr pub2) - assertEqual "Key 1C" (Just addr1C) $ addrToText btc (pubKeyAddr pub1C) - assertEqual "Key 2C" (Just addr2C) $ addrToText btc (pubKeyAddr pub2C) - -testSigs :: Assertion -testSigs = forM_ sigMsg $ testSignature . doubleSHA256 - -sigMsg :: [BS.ByteString] -sigMsg = - [ mconcat ["Very secret message ", C.pack (show (i :: Int)), ": 11"] - | i <- [0 .. 15] - ] - -testSignature :: Hash256 -> Assertion -testSignature h = do - let sign1 = signHash (secKeyData sec1) h - sign2 = signHash (secKeyData sec2) h - sign1C = signHash (secKeyData sec1C) h - sign2C = signHash (secKeyData sec2C) h - assertBool "Key 1, Sign1" $ verifyHashSig h sign1 (pubKeyPoint pub1) - assertBool "Key 1, Sign2" $ not $ verifyHashSig h sign2 (pubKeyPoint pub1) - assertBool "Key 1, Sign1C" $ verifyHashSig h sign1C (pubKeyPoint pub1) - assertBool "Key 1, Sign2C" $ not $ verifyHashSig h sign2C (pubKeyPoint pub1) - assertBool "Key 2, Sign1" $ not $ verifyHashSig h sign1 (pubKeyPoint pub2) - assertBool "Key 2, Sign2" $ verifyHashSig h sign2 (pubKeyPoint pub2) - assertBool "Key 2, Sign1C" $ not $ verifyHashSig h sign1C (pubKeyPoint pub2) - assertBool "Key 2, Sign2C" $ verifyHashSig h sign2C (pubKeyPoint pub2) - assertBool "Key 1C, Sign1" $ verifyHashSig h sign1 (pubKeyPoint pub1C) - assertBool "Key 1C, Sign2" $ not $ verifyHashSig h sign2 (pubKeyPoint pub1C) - assertBool "Key 1C, Sign1C" $ verifyHashSig h sign1C (pubKeyPoint pub1C) - assertBool "Key 1C, Sign2C" $ not $ verifyHashSig h sign2C (pubKeyPoint pub1C) - assertBool "Key 2C, Sign1" $ not $ verifyHashSig h sign1 (pubKeyPoint pub2C) - assertBool "Key 2C, Sign2" $ verifyHashSig h sign2 (pubKeyPoint pub2C) - assertBool "Key 2C, Sign1C" $ not $ verifyHashSig h sign1C (pubKeyPoint pub2C) - assertBool "Key 2C, Sign2C" $ verifyHashSig h sign2C (pubKeyPoint pub2C) - -testDetSigning :: Assertion -testDetSigning = do - let m = doubleSHA256 ("Very deterministic message" :: BS.ByteString) - assertEqual - "Det sig 1" - (signHash (secKeyData sec1) m) - (signHash (secKeyData sec1C) m) - assertEqual - "Det sig 2" - (signHash (secKeyData sec2) m) - (signHash (secKeyData sec2C) m) - -strSecret1, strSecret2, strSecret1C, strSecret2C :: Text -strSecret1 = "5HxWvvfubhXpYYpS3tJkw6fq9jE9j18THftkZjHHfmFiWtmAbrj" -strSecret2 = "5KC4ejrDjv152FGwP386VD1i2NYc5KkfSMyv1nGy1VGDxGHqVY3" -strSecret1C = "Kwr371tjA9u2rFSMZjTNun2PXXP3WPZu2afRHTcta6KxEUdm1vEw" -strSecret2C = "L3Hq7a8FEQwJkW1M2GNKDW28546Vp5miewcCzSqUD9kCAXrJdS3g" - -sec1, sec2, sec1C, sec2C :: SecKeyI -sec1 = fromJust $ fromWif btc strSecret1 -sec2 = fromJust $ fromWif btc strSecret2 -sec1C = fromJust $ fromWif btc strSecret1C -sec2C = fromJust $ fromWif btc strSecret2C - -addr1, addr2, addr1C, addr2C :: Text -addr1 = "1QFqqMUD55ZV3PJEJZtaKCsQmjLT6JkjvJ" -addr2 = "1F5y5E5FMc5YzdJtB9hLaUe43GDxEKXENJ" -addr1C = "1NoJrossxPBKfCHuJXT4HadJrXRE9Fxiqs" -addr2C = "1CRj2HyM1CXWzHAXLQtiGLyggNT9WQqsDs" - -strAddressBad :: Text -strAddressBad = "1HV9Lc3sNHZxwj4Zk6fB38tEmBryq2cBiF" - -pub1, pub2, pub1C, pub2C :: PubKeyI -pub1 = derivePubKeyI sec1 -pub2 = derivePubKeyI sec2 -pub1C = derivePubKeyI sec1C -pub2C = derivePubKeyI sec2C diff --git a/test/Haskoin/NetworkSpec.hs b/test/Haskoin/NetworkSpec.hs index 561b5fd5..31d14e8b 100644 --- a/test/Haskoin/NetworkSpec.hs +++ b/test/Haskoin/NetworkSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module Haskoin.NetworkSpec (spec) where @@ -9,13 +11,12 @@ import Data.Maybe (fromJust) import Data.Text (Text) import Data.Word (Word32) import Haskoin.Address -import Haskoin.Constants -import Haskoin.Keys +import Haskoin.Crypto import Haskoin.Network +import Haskoin.Network.Constants import Haskoin.Transaction import Haskoin.Util import Haskoin.Util.Arbitrary -import Haskoin.UtilSpec (customCerealID) import Test.HUnit (Assertion, assertBool, assertEqual) import Test.Hspec import Test.Hspec.QuickCheck @@ -23,54 +24,55 @@ import Test.QuickCheck serialVals :: [SerialBox] serialVals = - [ SerialBox arbitraryVarInt - , SerialBox arbitraryVarString - , SerialBox arbitraryNetworkAddress - , SerialBox arbitraryInvType - , SerialBox arbitraryInvVector - , SerialBox arbitraryInv1 - , SerialBox arbitraryVersion - , SerialBox arbitraryAddr1 - , SerialBox arbitraryAlert - , SerialBox arbitraryReject - , SerialBox arbitraryRejectCode - , SerialBox arbitraryGetData - , SerialBox arbitraryNotFound - , SerialBox arbitraryPing - , SerialBox arbitraryPong - , SerialBox arbitraryMessageCommand - , SerialBox arbitraryMessageHeader - , SerialBox arbitraryBloomFlags - , SerialBox arbitraryBloomFilter - , SerialBox arbitraryFilterLoad - , SerialBox arbitraryFilterAdd - ] + [ SerialBox arbitraryVarInt, + SerialBox arbitraryVarString, + SerialBox arbitraryNetworkAddress, + SerialBox arbitraryInvType, + SerialBox arbitraryInvVector, + SerialBox arbitraryInv1, + SerialBox arbitraryVersion, + SerialBox arbitraryAddr1, + SerialBox arbitraryAlert, + SerialBox arbitraryReject, + SerialBox arbitraryRejectCode, + SerialBox arbitraryGetData, + SerialBox arbitraryNotFound, + SerialBox arbitraryPing, + SerialBox arbitraryPong, + SerialBox arbitraryMessageCommand, + SerialBox arbitraryMessageHeader, + SerialBox arbitraryBloomFlags, + SerialBox arbitraryBloomFilter, + SerialBox arbitraryFilterLoad, + SerialBox arbitraryFilterAdd + ] spec :: Spec -spec = do - testIdentity serialVals [] [] [] - describe "Custom identity tests" $ do - prop "Data.Serialize Encoding for type Message" $ - forAll arbitraryNetwork $ \net -> - forAll (arbitraryMessage net) $ - customCerealID (getMessage net) (putMessage net) - describe "bloom filters" $ do - it "bloom filter vector 1" bloomFilter1 - it "bloom filter vector 2" bloomFilter2 - it "bloom filter vector 3" bloomFilter3 - describe "relevant bloom filter update" $ do - it "Relevant Update" relevantOutputUpdated - it "Irrelevant Update" irrelevantOutputNotUpdated +spec = prepareContext $ \ctx -> do + testIdentity serialVals [] [] [] + describe "Custom identity tests" $ do + prop "Data.Serialize Encoding for type Message" $ + forAll arbitraryNetwork $ \net -> + forAll (arbitraryMessage net ctx) $ + customCerealID (getMessage net) (putMessage net) + describe "bloom filters" $ do + it "bloom filter vector 1" bloomFilter1 + it "bloom filter vector 2" bloomFilter2 + it "bloom filter vector 3" $ bloomFilter3 ctx + describe "relevant bloom filter update" $ do + it "Relevant Update" $ relevantOutputUpdated ctx + it "Irrelevant Update" $ irrelevantOutputNotUpdated ctx bloomFilter :: Word32 -> Text -> Assertion bloomFilter n x = do - assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1 - assertBool "Bloom filter contains something it should not" $ - not $ bloomContains f1 v2 - assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3 - assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4 - assertBool "Bloom filter serialization is incorrect" $ - runPutS (serialize f4) == bs + assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1 + assertBool "Bloom filter contains something it should not" $ + not $ + bloomContains f1 v2 + assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3 + assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4 + assertBool "Bloom filter serialization is incorrect" $ + runPutS (serialize f4) == bs where f0 = bloomCreate 3 0.01 n BloomUpdateAll f1 = bloomInsert f0 v1 @@ -88,97 +90,97 @@ bloomFilter1 = bloomFilter 0 "03614e9b050000000000000001" bloomFilter2 :: Assertion bloomFilter2 = bloomFilter 2147483649 "03ce4299050000000100008001" -bloomFilter3 :: Assertion -bloomFilter3 = - assertBool "Bloom filter serialization is incorrect" $ - runPutS (serialize f2) == bs +bloomFilter3 :: Ctx -> Assertion +bloomFilter3 ctx = + assertBool "Bloom filter serialization is incorrect" $ + runPutS (serialize f2) == bs where f0 = bloomCreate 2 0.001 0 BloomUpdateAll - f1 = bloomInsert f0 $ runPutS $ serialize p - f2 = bloomInsert f1 $ runPutS $ serialize $ getAddrHash160 $ pubKeyAddr p + f1 = bloomInsert f0 $ marshal ctx p + f2 = bloomInsert f1 $ runPutS $ serialize (pubKeyAddr ctx p).hash160 k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C" - p = derivePubKeyI k + p = derivePublicKey ctx k bs = fromJust $ decodeHex "038fc16b080000000000000001" -relevantOutputUpdated :: Assertion -relevantOutputUpdated = - assertBool "Bloom filter output updated" $ - any (bloomContains bf2) spendTxInput +relevantOutputUpdated :: Ctx -> Assertion +relevantOutputUpdated ctx = + assertBool "Bloom filter output updated" $ + any (bloomContains bf2) spendTxInput where bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8" bf1 = bloomInsert bf0 relevantOutputHash - bf2 = fromJust $ bloomRelevantUpdate bf1 relevantTx - spendTxInput = runPutS . serialize . prevOutput <$> txIn spendRelevantTx + bf2 = fromJust $ bloomRelevantUpdate ctx bf1 relevantTx + spendTxInput = runPutS . serialize . (.outpoint) <$> spendRelevantTx.inputs -irrelevantOutputNotUpdated :: Assertion -irrelevantOutputNotUpdated = assertEqual "Bloom filter not updated" Nothing bf2 +irrelevantOutputNotUpdated :: Ctx -> Assertion +irrelevantOutputNotUpdated ctx = assertEqual "Bloom filter not updated" Nothing bf2 where bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8" bf1 = bloomInsert bf0 relevantOutputHash - bf2 = bloomRelevantUpdate bf1 unrelatedTx + bf2 = bloomRelevantUpdate ctx bf1 unrelatedTx -- Random transaction (57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9) relevantTx :: Tx relevantTx = - Tx - { txVersion = 1 - , txIn = - [ TxIn - { prevOutput = OutPoint "35fe9017b7e3af592920b56fa06ac02faf0c52cdb19dcb416129ac71c95d060e" 1 - , scriptInput = fromJust $ decodeHex "473044022032fc8eef299b7e94b9a986a6aa2dcb9733ab804bef80df995e443b9c1f8c604202203335df7a2e2b4789451cdb4b2b05a786a81c51519eb6a567fd6fe8cd7b2d33fe014104272502dc63a512dad1473cb82a71be9baf4f4303abd1ff6028fc8a78e1f3aec1218907119dec14f07354850758ff0948e88a904fa411c4df7d5444414ec64ad6" - , txInSequence = 4294967295 - } - ] - , txOut = - [ TxOut{outValue = 100000000, scriptOutput = fromJust $ decodeHex "76a91403f47604ea2736334151081e13265b4fe38e6fa888ac"} - , TxOut{outValue = 107980000, scriptOutput = fromJust $ decodeHex "76a91481cc186a2f4a69f633ed4bf10ef4a78be13effdd88ac"} - ] - , txWitness = [] - , txLockTime = 0 - } + Tx + { version = 1, + inputs = + [ TxIn + { outpoint = OutPoint "35fe9017b7e3af592920b56fa06ac02faf0c52cdb19dcb416129ac71c95d060e" 1, + script = fromJust $ decodeHex "473044022032fc8eef299b7e94b9a986a6aa2dcb9733ab804bef80df995e443b9c1f8c604202203335df7a2e2b4789451cdb4b2b05a786a81c51519eb6a567fd6fe8cd7b2d33fe014104272502dc63a512dad1473cb82a71be9baf4f4303abd1ff6028fc8a78e1f3aec1218907119dec14f07354850758ff0948e88a904fa411c4df7d5444414ec64ad6", + sequence = 4294967295 + } + ], + outputs = + [ TxOut {value = 100000000, script = fromJust $ decodeHex "76a91403f47604ea2736334151081e13265b4fe38e6fa888ac"}, + TxOut {value = 107980000, script = fromJust $ decodeHex "76a91481cc186a2f4a69f633ed4bf10ef4a78be13effdd88ac"} + ], + witness = [], + locktime = 0 + } -- Transaction that spends above (fd6e3b693b844aa431fad46765c1aa019a6b13aebfa9dae916b3ffa43283a300) spendRelevantTx :: Tx spendRelevantTx = - Tx - { txVersion = 1 - , txIn = - [ TxIn - { prevOutput = OutPoint "57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9" 0 - , scriptInput = fromJust $ decodeHex "483045022100ecc334821e4e94cc2fdc841d5ad147d5bb942b993ba81460cc446e0410afa811022015fcbc542b734dbb61a05ec06012095096de5839c50808fe56f2b315e877c20d012103fb64e5792fa586172339b776b7017d3d529358cb73be6406a1fc994228d14f88" - , txInSequence = 4294967295 - } - , TxIn - { prevOutput = OutPoint "cfee6a8d6e68e8fd16df6fff010afffcd19d7e075aa7b707dd1bae6adc420042" 0 - , scriptInput = fromJust $ decodeHex "47304402200e6bb95fa606f254d17089d83c4ceeb19c5d1699b4faddcd4f1f1568286e6b650220087fb8439f31e1b30e47710d095422405f601d6151f2f93e125e1a08a6e29ad4012103b49252e8fc6d5b49c8d14ee71fab45591df4a126a6c453c724f3d356e38f0cee" - , txInSequence = 4294967295 - } - ] - , txOut = - [ TxOut{outValue = 3851100, scriptOutput = fromJust $ decodeHex "76a914a297cae82a9a3b932bf023ae274fe2585295c9ca88ac"} - , TxOut{outValue = 111000000, scriptOutput = fromJust $ decodeHex "76a9148f952c38600a61385974acc30a64f74407f9801488ac"} - ] - , txWitness = [] - , txLockTime = 0 - } + Tx + { version = 1, + inputs = + [ TxIn + { outpoint = OutPoint "57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9" 0, + script = fromJust $ decodeHex "483045022100ecc334821e4e94cc2fdc841d5ad147d5bb942b993ba81460cc446e0410afa811022015fcbc542b734dbb61a05ec06012095096de5839c50808fe56f2b315e877c20d012103fb64e5792fa586172339b776b7017d3d529358cb73be6406a1fc994228d14f88", + sequence = 4294967295 + }, + TxIn + { outpoint = OutPoint "cfee6a8d6e68e8fd16df6fff010afffcd19d7e075aa7b707dd1bae6adc420042" 0, + script = fromJust $ decodeHex "47304402200e6bb95fa606f254d17089d83c4ceeb19c5d1699b4faddcd4f1f1568286e6b650220087fb8439f31e1b30e47710d095422405f601d6151f2f93e125e1a08a6e29ad4012103b49252e8fc6d5b49c8d14ee71fab45591df4a126a6c453c724f3d356e38f0cee", + sequence = 4294967295 + } + ], + outputs = + [ TxOut {value = 3851100, script = fromJust $ decodeHex "76a914a297cae82a9a3b932bf023ae274fe2585295c9ca88ac"}, + TxOut {value = 111000000, script = fromJust $ decodeHex "76a9148f952c38600a61385974acc30a64f74407f9801488ac"} + ], + witness = [], + locktime = 0 + } -- This random transaction is unrelated to the others unrelatedTx :: Tx unrelatedTx = - Tx - { txVersion = 1 - , txIn = - [ TxIn - { prevOutput = OutPoint "3ec3a71431c68e5d978a5fb4a0a1081d8bee8384d8aa4c06b1fbaf9413e2214f" 20 - , scriptInput = fromJust $ decodeHex "483045022100ec9c202c9d3140b973aca9d7f21a82138aa4cfa43fddc5419098ac5e26a6f152022010848fd688f290ae010fb5cb493410caa03145fc12445900ec1ad2bde33aecd9012102c7445e72d723f99a0064526c28269d07f47c8fd81531a94a8d3bf5ebd5e23ef1" - , txInSequence = 4294967295 - } - ] - , txOut = - [ TxOut{outValue = 12600000, scriptOutput = fromJust $ decodeHex "76a9148fef3b7051de8cc44e966159e7ea37f4520187e888ac"} - ] - , txWitness = [] - , txLockTime = 0 - } + Tx + { version = 1, + inputs = + [ TxIn + { outpoint = OutPoint "3ec3a71431c68e5d978a5fb4a0a1081d8bee8384d8aa4c06b1fbaf9413e2214f" 20, + script = fromJust $ decodeHex "483045022100ec9c202c9d3140b973aca9d7f21a82138aa4cfa43fddc5419098ac5e26a6f152022010848fd688f290ae010fb5cb493410caa03145fc12445900ec1ad2bde33aecd9012102c7445e72d723f99a0064526c28269d07f47c8fd81531a94a8d3bf5ebd5e23ef1", + sequence = 4294967295 + } + ], + outputs = + [ TxOut {value = 12600000, script = fromJust $ decodeHex "76a9148fef3b7051de8cc44e966159e7ea37f4520187e888ac"} + ], + witness = [], + locktime = 0 + } diff --git a/test/Haskoin/ScriptSpec.hs b/test/Haskoin/ScriptSpec.hs index 5c3d07ff..03bc604d 100644 --- a/test/Haskoin/ScriptSpec.hs +++ b/test/Haskoin/ScriptSpec.hs @@ -1,11 +1,15 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Haskoin.ScriptSpec (spec) where import Control.Monad import Data.Aeson as A import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -17,14 +21,13 @@ import Data.String.Conversions (cs) import Data.Text (Text) import Data.Word import Haskoin.Address -import Haskoin.Constants -import Haskoin.Data -import Haskoin.Keys +import Haskoin.Crypto +import Haskoin.Network.Constants +import Haskoin.Network.Data import Haskoin.Script import Haskoin.Transaction import Haskoin.Util import Haskoin.Util.Arbitrary -import Haskoin.UtilSpec (readTestFile) import Test.HUnit as HUnit import Test.Hspec import Test.Hspec.QuickCheck @@ -33,196 +36,187 @@ import Text.Read serialVals :: [SerialBox] serialVals = - [ SerialBox arbitraryScriptOp - , SerialBox arbitraryScript - ] + [ SerialBox arbitraryScriptOp, + SerialBox arbitraryScript + ] -readVals :: [ReadBox] -readVals = - [ ReadBox arbitrarySigHash - , ReadBox arbitrarySigHashFlag - , ReadBox arbitraryScript - , ReadBox arbitraryPushDataType - , ReadBox arbitraryScriptOp - , ReadBox (arbitraryScriptOutput =<< arbitraryNetwork) - ] +readVals :: Ctx -> [ReadBox] +readVals ctx = + [ ReadBox arbitrarySigHash, + ReadBox arbitrarySigHashFlag, + ReadBox arbitraryScript, + ReadBox arbitraryPushDataType, + ReadBox arbitraryScriptOp, + ReadBox ((`arbitraryScriptOutput` ctx) =<< arbitraryNetwork) + ] -jsonVals :: [JsonBox] -jsonVals = - [ JsonBox $ arbitraryScriptOutput =<< arbitraryNetwork - , JsonBox arbitraryOutPoint - , JsonBox arbitrarySigHash - , JsonBox $ fst <$> (arbitrarySigInput =<< arbitraryNetwork) - ] +jsonVals :: Ctx -> [JsonBox] +jsonVals ctx = + [ JsonBox $ + fmap (marshalValue ctx) $ + arbitraryNetwork >>= flip arbitraryScriptOutput ctx, + JsonBox arbitraryOutPoint, + JsonBox arbitrarySigHash, + JsonBox $ + fmap (marshalValue ctx . fst) $ + arbitraryNetwork >>= flip arbitrarySigInput ctx + ] + +netVals :: Ctx -> [NetBox] +netVals ctx = + [ NetBox + ( marshalValue . (,ctx), + marshalEncoding . (,ctx), + unmarshalValue . (,ctx), + do + net <- arbitraryNetwork + (_, _, txsig) <- arbitraryTxSignature net ctx + return (net, txsig) + ) + ] spec :: Spec -spec = do - testIdentity serialVals readVals jsonVals [] - describe "btc scripts" $ props btc - describe "bch scripts" $ props bch - describe "multi signatures" $ - zipWithM_ (curry mapMulSigVector) mulSigVectors [0 ..] - describe "signature decoding" $ - zipWithM_ (curry (sigDecodeMap btc)) scriptSigSignatures [0 ..] - describe "SigHashFlag fromEnum/toEnum" $ - prop "fromEnum/toEnum" $ - forAll arbitrarySigHashFlag $ \f -> toEnum (fromEnum f) `shouldBe` f - describe "Script vectors" $ - it "Can encode script vectors" encodeScriptVector +spec = prepareContext $ \ctx -> do + testIdentity serialVals (readVals ctx) (jsonVals ctx) (netVals ctx) + describe "btc scripts" $ props btc ctx + describe "bch scripts" $ props bch ctx + describe "multi signatures" $ + zipWithM_ (curry (mapMulSigVector ctx)) mulSigVectors [0 ..] + describe "signature decoding" $ + zipWithM_ (curry (sigDecodeMap btc ctx)) scriptSigSignatures [0 ..] + describe "SigHashFlag fromEnum/toEnum" $ + prop "fromEnum/toEnum" $ + forAll arbitrarySigHashFlag $ + \f -> toEnum (fromEnum f) `shouldBe` f + describe "Script vectors" $ + it "Can encode script vectors" encodeScriptVector -props :: Network -> Spec -props net = do - standardSpec net - strictSigSpec net - scriptSpec net - txSigHashForkIdSpec net - forkIdScriptSpec net - sigHashSpec net - txSigHashSpec net +props :: Network -> Ctx -> Spec +props net ctx = do + standardSpec net ctx + strictSigSpec net ctx + scriptSpec net ctx + txSigHashForkIdSpec net + forkIdScriptSpec net ctx + sigHashSpec net ctx + txSigHashSpec net -standardSpec :: Network -> Spec -standardSpec net = do - prop "has intToScriptOp . scriptOpToInt identity" $ - forAll arbitraryIntScriptOp $ \i -> - intToScriptOp <$> scriptOpToInt i `shouldBe` Right i - prop "has decodeOutput . encodeOutput identity" $ - forAll (arbitraryScriptOutput net) $ \so -> - decodeOutput (encodeOutput so) `shouldBe` Right so - prop "has decodeInput . encodeOutput identity" $ - forAll (arbitraryScriptInput net) $ \si -> - decodeInput net (encodeInput si) `shouldBe` Right si - prop "can sort multisig scripts" $ - forAll arbitraryMSOutput $ \out -> - map - (runPutS . serialize) - (getOutputMulSigKeys (sortMulSig out)) - `shouldSatisfy` \xs -> xs == sort xs - it "can decode inputs with empty signatures" $ do - decodeInput net (Script [OP_0]) - `shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty)) - decodeInput net (Script [opPushData ""]) - `shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty)) - let pk = - derivePubKeyI $ - wrapSecKey True $ fromJust $ secKey $ B.replicate 32 1 - decodeInput net (Script [OP_0, opPushData $ runPutS $ serialize pk]) - `shouldBe` Right (RegularInput (SpendPKHash TxSignatureEmpty pk)) - decodeInput net (Script [OP_0, OP_0]) - `shouldBe` Right (RegularInput (SpendMulSig [TxSignatureEmpty])) - decodeInput net (Script [OP_0, OP_0, OP_0, OP_0]) - `shouldBe` Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty)) +standardSpec :: Network -> Ctx -> Spec +standardSpec net ctx = do + prop "has intToScriptOp . scriptOpToInt identity" $ + forAll arbitraryIntScriptOp $ \i -> + intToScriptOp <$> scriptOpToInt i `shouldBe` Right i + prop "has decodeOutput . encodeOutput identity" $ + forAll (arbitraryScriptOutput net ctx) $ \so -> + decodeOutput ctx (encodeOutput ctx so) `shouldBe` Right so + prop "has decodeInput . encodeOutput identity" $ + forAll (arbitraryScriptInput net ctx) $ \si -> + (decodeInput net ctx . encodeInput net ctx) si `shouldBe` Right si + prop "can sort multisig scripts" $ + forAll (arbitraryMSOutput ctx) $ \out -> + let keyList = map (marshal ctx) (sortMulSig ctx out).keys + isSorted xs = xs == sort xs + in keyList `shouldSatisfy` isSorted + it "can decode inputs with empty signatures" $ do + decodeInput net ctx (Script [OP_0]) + `shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty)) + decodeInput net ctx (Script [opPushData ""]) + `shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty)) + let Just sk = secKey (B.replicate 32 1) + pk = derivePublicKey ctx (wrapSecKey True sk) + decodeInput net ctx (Script [OP_0, opPushData $ marshal ctx pk]) + `shouldBe` Right (RegularInput (SpendPKHash TxSignatureEmpty pk)) + decodeInput net ctx (Script [OP_0, OP_0]) + `shouldBe` Right (RegularInput (SpendMulSig [TxSignatureEmpty])) + decodeInput net ctx (Script [OP_0, OP_0, OP_0, OP_0]) + `shouldBe` Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty)) -scriptSpec :: Network -> Spec -scriptSpec net = - when (getNetworkName net == "btc") $ - it "can verify standard scripts from script_tests.json file" $ do - xs <- readTestFile "script_tests.json" :: IO [A.Value] - let vectorsA = - mapMaybe (A.decode . A.encode) xs :: - [ ( String - , String - , String - , String - , String - ) - ] - vectorsB = - mapMaybe (A.decode . A.encode) xs :: - [ ( [Word64] - , String - , String - , String - , String - , String - ) - ] - vectors = - map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA - <> vectorsB - length vectors `shouldBe` 86 - forM_ vectors $ \([val], siStr, soStr, flags, res, desc) -> - -- We can disable specific tests by adding a DISABLED flag in the data +scriptSpec :: Network -> Ctx -> Spec +scriptSpec net ctx = + when (net.name == "btc") $ + it "can verify standard scripts from script_tests.json file" $ do + xs <- readTestFile "script_tests.json" :: IO [A.Value] + let vectorsA = + mapMaybe (A.decode . A.encode) xs :: + [(String, String, String, String, String)] + vectorsB = + mapMaybe (A.decode . A.encode) xs :: + [([Word64], String, String, String, String, String)] + vectors = + map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA + <> vectorsB + length vectors `shouldBe` 86 + forM_ vectors $ \([val], siStr, soStr, flags, res, desc) -> + -- We can disable specific tests by adding a DISABLED flag in the data + unless ("DISABLED" `isInfixOf` flags) $ do + let _strict = + any + (`isInfixOf` flags) + ["DERSIG", "STRICTENC", "NULLDUMMY"] + scriptSig = parseScript siStr + scriptPubKey = parseScript soStr + out = unmarshal ctx scriptPubKey + tx = spendTx scriptPubKey 0 scriptSig + sat = val * 100000000 + ver o = verifyStdInput net ctx tx 0 o sat + valid = either (const False) ver out + assertBool desc $ if res == "OK" then valid else not valid - unless ("DISABLED" `isInfixOf` flags) $ do - let _strict = - "DERSIG" `isInfixOf` flags - || "STRICTENC" `isInfixOf` flags - || "NULLDUMMY" `isInfixOf` flags - scriptSig = parseScript siStr - scriptPubKey = parseScript soStr - decodedOutput = decodeOutputBS scriptPubKey - ver = either (const False) $ \so -> - verifyStdInput - net - (spendTx scriptPubKey 0 scriptSig) - 0 - so - (val * 100000000) - case res of - "OK" -> assertBool desc $ ver decodedOutput - _ -> assertBool desc (not $ ver decodedOutput) - -forkIdScriptSpec :: Network -> Spec -forkIdScriptSpec net = - when (isJust (getSigHashForkId net)) $ - it "can verify scripts from forkid_script_tests.json file" $ do - xs <- readTestFile "forkid_script_tests.json" :: IO [A.Value] - let vectors = - mapMaybe (A.decode . A.encode) xs :: - [ ( [Word64] - , String - , String - , String - , String - , String - ) - ] - length vectors `shouldBe` 3 - forM_ vectors $ \([valBTC], siStr, soStr, _, res, _) -> do - let val = valBTC * 100000000 - scriptSig = parseScript siStr - scriptPubKey = parseScript soStr - decodedOutput = - fromRight (error $ "Could not decode output: " <> soStr) $ - decodeOutputBS scriptPubKey - ver = - verifyStdInput - net - (spendTx scriptPubKey val scriptSig) - 0 - decodedOutput - val - case res of - "OK" -> ver `shouldBe` True - _ -> ver `shouldBe` False +forkIdScriptSpec :: Network -> Ctx -> Spec +forkIdScriptSpec net ctx = + when (isJust net.sigHashForkId) $ + it "can verify scripts from forkid_script_tests.json file" $ do + xs <- readTestFile "forkid_script_tests.json" :: IO [A.Value] + let vectors = + mapMaybe (A.decode . A.encode) xs :: + [ ( [Word64], + String, + String, + String, + String, + String + ) + ] + length vectors `shouldBe` 3 + forM_ vectors $ \([valBTC], siStr, soStr, _, res, _) -> do + let val = valBTC * 100000000 + scriptSig = parseScript siStr + scriptPubKey = parseScript soStr + out = unmarshal ctx scriptPubKey + tx = spendTx scriptPubKey val scriptSig + ver o = verifyStdInput net ctx tx 0 o val + valid = either (const False) ver out + case res of + "OK" -> valid `shouldBe` True + _ -> valid `shouldBe` False creditTx :: ByteString -> Word64 -> Tx creditTx scriptPubKey val = - Tx 1 [txI] [txO] [] 0 + Tx 1 [txI] [txO] [] 0 where - txO = TxOut{outValue = val, scriptOutput = scriptPubKey} + txO = TxOut {value = val, script = scriptPubKey} txI = - TxIn - { prevOutput = nullOutPoint - , scriptInput = runPutS $ serialize $ Script [OP_0, OP_0] - , txInSequence = maxBound - } + TxIn + { outpoint = nullOutPoint, + script = runPutS $ serialize $ Script [OP_0, OP_0], + sequence = maxBound + } spendTx :: ByteString -> Word64 -> ByteString -> Tx spendTx scriptPubKey val scriptSig = - Tx 1 [txI] [txO] [] 0 + Tx 1 [txI] [txO] [] 0 where - txO = TxOut{outValue = val, scriptOutput = B.empty} + txO = TxOut {value = val, script = B.empty} txI = - TxIn - { prevOutput = OutPoint (txHash $ creditTx scriptPubKey val) 0 - , scriptInput = scriptSig - , txInSequence = maxBound - } + TxIn + { outpoint = OutPoint (txHash $ creditTx scriptPubKey val) 0, + script = scriptSig, + sequence = maxBound + } parseScript :: String -> ByteString parseScript str = - B.concat $ fromMaybe err $ mapM f $ words str + B.concat $ fromMaybe err $ mapM f $ words str where f = decodeHex . cs . dropHex . replaceToken dropHex ('0' : 'x' : xs) = xs @@ -231,233 +225,238 @@ parseScript str = replaceToken :: String -> String replaceToken str = case readMaybe $ "OP_" <> str of - Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp)) - _ -> str + Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp)) + _ -> str -strictSigSpec :: Network -> Spec -strictSigSpec net = - when (getNetworkName net == "btc") $ do - it "can decode strict signatures" $ do - xs <- readTestFile "sig_strict.json" - let vectors = mapMaybe decodeHex xs - length vectors `shouldBe` 3 - forM_ vectors $ \sig -> - decodeTxSig net sig `shouldSatisfy` isRight - it "can detect non-strict signatures" $ do - xs <- readTestFile "sig_nonstrict.json" - let vectors = mapMaybe decodeHex xs - length vectors `shouldBe` 17 - forM_ vectors $ \sig -> - decodeTxSig net sig `shouldSatisfy` isLeft +strictSigSpec :: Network -> Ctx -> Spec +strictSigSpec net ctx = + when (net.name == "btc") $ do + it "can decode strict signatures" $ do + xs <- readTestFile "sig_strict.json" + let vectors = mapMaybe decodeHex xs + length vectors `shouldBe` 3 + forM_ vectors $ \sig -> + let eitherSig :: Either String TxSignature + eitherSig = decodeTxSig net ctx sig + in eitherSig `shouldSatisfy` isRight + it "can detect non-strict signatures" $ do + xs <- readTestFile "sig_nonstrict.json" + let vectors = mapMaybe decodeHex xs + length vectors `shouldBe` 17 + forM_ vectors $ \sig -> + let eitherSig = decodeTxSig net ctx sig + in eitherSig `shouldSatisfy` isLeft txSigHashSpec :: Network -> Spec txSigHashSpec net = - when (getNetworkName net == "btc") $ - it "can produce valid sighashes from sighash.json test vectors" $ do - xs <- readTestFile "sighash.json" :: IO [A.Value] - let vectors = - mapMaybe (A.decode . A.encode) xs :: - [ ( String - , String - , Int - , Integer - , String - ) - ] - length vectors `shouldBe` 500 - forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do - let tx = fromString txStr - s = - fromMaybe (error $ "Could not decode script: " <> cs scpStr) $ - eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr) - sh = fromIntegral shI - res = - eitherToMaybe . runGetS deserialize . B.reverse - =<< decodeHex (cs resStr) - Just (txSigHash net tx s 0 i sh) `shouldBe` res + when (net.name == "btc") $ + it "can produce valid sighashes from sighash.json test vectors" $ do + xs <- readTestFile "sighash.json" :: IO [A.Value] + let vectors = + mapMaybe (A.decode . A.encode) xs :: + [ ( String, + String, + Int, + Integer, + String + ) + ] + length vectors `shouldBe` 500 + forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do + let tx = fromString txStr + s = + fromMaybe (error $ "Could not decode script: " <> cs scpStr) $ + eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr) + sh = fromIntegral shI + res = + eitherToMaybe . runGetS deserialize . B.reverse + =<< decodeHex (cs resStr) + Just (txSigHash net tx s 0 i sh) `shouldBe` res txSigHashForkIdSpec :: Network -> Spec txSigHashForkIdSpec net = - when (getNetworkName net == "btc") $ - it "can produce valid sighashes from forkid_sighash.json test vectors" $ do - xs <- readTestFile "forkid_sighash.json" :: IO [A.Value] - let vectors = - mapMaybe (A.decode . A.encode) xs :: - [ ( String - , String - , Int - , Word64 - , Integer - , String - ) - ] - length vectors `shouldBe` 13 - forM_ vectors $ \(txStr, scpStr, i, val, shI, resStr) -> do - let tx = fromString txStr - s = - fromMaybe (error $ "Could not decode script: " <> cs scpStr) $ - eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr) - sh = fromIntegral shI - res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr) - Just (txSigHashForkId net tx s val i sh) `shouldBe` res + when (net.name == "btc") $ + it "can produce valid sighashes from forkid_sighash.json test vectors" $ do + xs <- readTestFile "forkid_sighash.json" :: IO [A.Value] + let vectors = + mapMaybe (A.decode . A.encode) xs :: + [ ( String, + String, + Int, + Word64, + Integer, + String + ) + ] + length vectors `shouldBe` 13 + forM_ vectors $ \(txStr, scpStr, i, val, shI, resStr) -> do + let tx = fromString txStr + s = + fromMaybe (error $ "Could not decode script: " <> cs scpStr) $ + eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr) + sh = fromIntegral shI + res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr) + Just (txSigHashForkId net tx s val i sh) `shouldBe` res -sigHashSpec :: Network -> Spec -sigHashSpec net = do - it "can correctly show" $ do - show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32) - show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32) - show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32) - show (0xabac3344 :: SigHash) `shouldBe` "SigHash " - <> show (0xabac3344 :: Word32) - it "can add a forkid" $ do - 0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00 - 0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff - 0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff - 0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff - 0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff - 0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001 - 0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003 - it "can extract a forkid" $ do - sigHashGetForkId 0x00000000 `shouldBe` 0x00000000 - sigHashGetForkId 0x80000000 `shouldBe` 0x00800000 - sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff - sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34 - it "can build some vectors" $ do - sigHashAll `shouldBe` 0x01 - sigHashNone `shouldBe` 0x02 - sigHashSingle `shouldBe` 0x03 - setForkIdFlag sigHashAll `shouldBe` 0x41 - setAnyoneCanPayFlag sigHashAll `shouldBe` 0x81 - setAnyoneCanPayFlag (setForkIdFlag sigHashAll) `shouldBe` 0xc1 - it "can test flags" $ do - hasForkIdFlag sigHashAll `shouldBe` False - hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True - hasAnyoneCanPayFlag sigHashAll `shouldBe` False - hasAnyoneCanPayFlag (setAnyoneCanPayFlag sigHashAll) `shouldBe` True - isSigHashAll sigHashNone `shouldBe` False - isSigHashAll sigHashAll `shouldBe` True - isSigHashNone sigHashSingle `shouldBe` False - isSigHashNone sigHashNone `shouldBe` True - isSigHashSingle sigHashAll `shouldBe` False - isSigHashSingle sigHashSingle `shouldBe` True - isSigHashUnknown sigHashAll `shouldBe` False - isSigHashUnknown sigHashNone `shouldBe` False - isSigHashUnknown sigHashSingle `shouldBe` False - isSigHashUnknown 0x00 `shouldBe` True - isSigHashUnknown 0x04 `shouldBe` True - it "can decodeTxSig . encode a TxSignature" $ - property $ - forAll (arbitraryTxSignature net) $ \(_, _, ts) -> - decodeTxSig net (encodeTxSig ts) `shouldBe` Right ts - it "can produce the sighash one" $ - property $ - forAll (arbitraryTx net) $ forAll arbitraryScript . testSigHashOne net +sigHashSpec :: Network -> Ctx -> Spec +sigHashSpec net ctx = do + it "can correctly show" $ do + show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32) + show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32) + show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32) + show (0xabac3344 :: SigHash) + `shouldBe` "SigHash " + <> show (0xabac3344 :: Word32) + it "can add a forkid" $ do + 0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00 + 0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff + 0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff + 0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff + 0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff + 0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001 + 0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003 + it "can extract a forkid" $ do + sigHashGetForkId 0x00000000 `shouldBe` 0x00000000 + sigHashGetForkId 0x80000000 `shouldBe` 0x00800000 + sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff + sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34 + it "can build some vectors" $ do + sigHashAll `shouldBe` 0x01 + sigHashNone `shouldBe` 0x02 + sigHashSingle `shouldBe` 0x03 + setForkIdFlag sigHashAll `shouldBe` 0x41 + setAnyoneCanPay sigHashAll `shouldBe` 0x81 + setAnyoneCanPay (setForkIdFlag sigHashAll) `shouldBe` 0xc1 + it "can test flags" $ do + hasForkIdFlag sigHashAll `shouldBe` False + hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True + anyoneCanPay sigHashAll `shouldBe` False + anyoneCanPay (setAnyoneCanPay sigHashAll) `shouldBe` True + isSigHashAll sigHashNone `shouldBe` False + isSigHashAll sigHashAll `shouldBe` True + isSigHashNone sigHashSingle `shouldBe` False + isSigHashNone sigHashNone `shouldBe` True + isSigHashSingle sigHashAll `shouldBe` False + isSigHashSingle sigHashSingle `shouldBe` True + isSigHashUnknown sigHashAll `shouldBe` False + isSigHashUnknown sigHashNone `shouldBe` False + isSigHashUnknown sigHashSingle `shouldBe` False + isSigHashUnknown 0x00 `shouldBe` True + isSigHashUnknown 0x04 `shouldBe` True + it "can decodeTxSig . encode a TxSignature" $ + property $ + forAll (arbitraryTxSignature net ctx) $ \(_, _, ts) -> + let f = decodeTxSig net ctx . encodeTxSig net ctx + in f ts `shouldBe` Right ts + it "can produce the sighash one" $ + property $ + forAll (arbitraryTx net ctx) $ + forAll arbitraryScript . testSigHashOne net testSigHashOne :: Network -> Tx -> Script -> Word64 -> Bool -> Property testSigHashOne net tx s val acp = - not (null $ txIn tx) - ==> if length (txIn tx) > length (txOut tx) - then res `shouldBe` one - else res `shouldNotBe` one + not (null tx.inputs) ==> + if length tx.inputs > length tx.outputs + then res `shouldBe` one + else res `shouldNotBe` one where - res = txSigHash net tx s val (length (txIn tx) - 1) (f sigHashSingle) + res = txSigHash net tx s val (length tx.inputs - 1) (f sigHashSingle) one = "0100000000000000000000000000000000000000000000000000000000000000" f = - if acp - then setAnyoneCanPayFlag - else id + if acp + then setAnyoneCanPay + else id {- Parse tests from bitcoin-qt repository -} -mapMulSigVector :: ((Text, Text), Int) -> Spec -mapMulSigVector (v, i) = - it name $ runMulSigVector v +mapMulSigVector :: Ctx -> ((Text, Text), Int) -> Spec +mapMulSigVector ctx (v, i) = + it name $ runMulSigVector ctx v where name = "check multisig vector " <> show i -runMulSigVector :: (Text, Text) -> Assertion -runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b +runMulSigVector :: Ctx -> (Text, Text) -> Assertion +runMulSigVector ctx (a, ops) = assertBool "multisig vector" $ Just a == b where s = do - s' <- decodeHex ops - eitherToMaybe $ runGetS deserialize s' + s' <- decodeHex ops + eitherToMaybe $ runGetS deserialize s' b = do - o <- s - d <- eitherToMaybe $ decodeOutput o - addrToText btc $ payToScriptAddress d + o <- s + d <- eitherToMaybe $ decodeOutput ctx o + addrToText btc $ payToScriptAddress ctx d -sigDecodeMap :: Network -> (Text, Int) -> Spec -sigDecodeMap net (_, i) = - it ("check signature " ++ show i) func +sigDecodeMap :: Network -> Ctx -> (Text, Int) -> Spec +sigDecodeMap net ctx (_, i) = + it ("check signature " ++ show i) func where - func = testSigDecode net $ scriptSigSignatures !! i + func = testSigDecode net ctx $ scriptSigSignatures !! i -testSigDecode :: Network -> Text -> Assertion -testSigDecode net str = - let bs = fromJust $ decodeHex str - eitherSig = decodeTxSig net bs - in assertBool - ( unwords - [ "Decode failed:" - , fromLeft (error "Decode did not fail") eitherSig - ] - ) - $ isRight eitherSig +testSigDecode :: Network -> Ctx -> Text -> Assertion +testSigDecode net ctx str = + let bs = fromJust $ decodeHex str + eitherSig = decodeTxSig net ctx bs + in assertBool + ( unwords + [ "Decode failed:", + fromLeft (error "Decode did not fail") eitherSig + ] + ) + $ isRight eitherSig mulSigVectors :: [(Text, Text)] mulSigVectors = - [ - ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC" - , "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb\ - \129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8\ - \334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253\ - \e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccf\ - \fef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f997\ - \4ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f\ - \322a1863d4621353ae" - ) - ] + [ ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC", + "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb\ + \129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8\ + \334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253\ + \e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccf\ + \fef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f997\ + \4ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f\ + \322a1863d4621353ae" + ) + ] scriptSigSignatures :: [Text] scriptSigSignatures = + -- Signature in input of txid + -- 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053 + [ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f333\ + \57119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a29\ + \41a2b1e401" -- Signature in input of txid - -- 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053 - [ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f333\ - \57119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a29\ - \41a2b1e401" - -- Signature in input of txid - -- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d. - -- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only - -- decode strict signatures. - -- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378d\ - -- \b4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22\ - -- \e18fe1e7d1510db501" - ] + -- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d. + -- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only + -- decode strict signatures. + -- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378d\ + -- \b4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22\ + -- \e18fe1e7d1510db501" + ] encodeScriptVector :: Assertion encodeScriptVector = - assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s) + assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s) where res = - "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\ - \bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\ - \348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\ - \cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\ - \25c15342af52ae" + "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\ + \bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\ + \348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\ + \cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\ + \25c15342af52ae" s = - Script - [ OP_1 - , opPushData $ - d - "04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\ - \8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\ - \11fcdd0d348ac4" - , opPushData $ - d - "0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\ - \deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\ - \f58b25c15342af" - , OP_2 - , OP_CHECKMULTISIG - ] + Script + [ OP_1, + opPushData $ + d + "04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\ + \8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\ + \11fcdd0d348ac4", + opPushData $ + d + "0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\ + \deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\ + \f58b25c15342af", + OP_2, + OP_CHECKMULTISIG + ] d = fromJust . decodeHex diff --git a/test/Haskoin/Transaction/PartialSpec.hs b/test/Haskoin/Transaction/PartialSpec.hs index a1c92223..dbbcb4b4 100644 --- a/test/Haskoin/Transaction/PartialSpec.hs +++ b/test/Haskoin/Transaction/PartialSpec.hs @@ -1,513 +1,548 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Haskoin.Transaction.PartialSpec (spec) where +import Control.Monad ((<=<)) +import Data.Aeson (FromJSON, parseJSON, withObject, (.:)) +import Data.Bifunctor (first) import Data.ByteString (ByteString) +import Data.ByteString.Base64 (decodeBase64) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial import Data.Either (fromRight, isLeft, isRight) import Data.HashMap.Strict (fromList, singleton) import Data.Maybe (fromJust, isJust) -import Data.Serialize as S +import Data.Serialize import Data.Text (Text) -import Test.HUnit (Assertion, assertBool, assertEqual) -import Test.Hspec -import Test.QuickCheck - -import Control.Monad ((<=<)) -import Data.Aeson (FromJSON, parseJSON, withObject, (.:)) -import Data.Bifunctor (first) -import Data.ByteString.Base64 (decodeBase64) -import qualified Data.Text as Text +import Data.Text qualified as Text import Data.Text.Encoding (encodeUtf8) import Haskoin.Address -import Haskoin.Constants import Haskoin.Crypto -import Haskoin.Data -import Haskoin.Keys +import Haskoin.Network.Constants +import Haskoin.Network.Data import Haskoin.Script import Haskoin.Transaction import Haskoin.Util import Haskoin.Util.Arbitrary -import Haskoin.UtilSpec (readTestFile) +import Test.HUnit (Assertion, assertBool, assertEqual) +import Test.Hspec +import Test.QuickCheck spec :: Spec -spec = describe "partially signed bitcoin transaction unit tests" $ do - it "encodes trivial psbt" $ - encodeHex (S.encode trivialPSBT) == trivialPSBTHex - it "decodes trivial psbt" $ - decodeHexPSBT trivialPSBTHex == Right trivialPSBT +spec = prepareContext $ \ctx -> + describe "PSBT unit tests" $ do + it "encodes trivial PSBT" $ + (encodeHex . runPut . putPSBT ctx) trivialPSBT == trivialPSBTHex + it "decodes trivial PSBT" $ + decodeHexPSBT ctx trivialPSBTHex == Right trivialPSBT it "encodes and decodes non-empty transactions" $ - S.decode (S.encode nonEmptyTransactionPSBT) == Right nonEmptyTransactionPSBT - it "does not decode invalid bip vectors" $ - mapM_ invalidVecTest invalidVec - it "encodes valid bip vecs" $ - mapM_ (uncurry encodeVecTest) validEncodeVec - it "decodes valid bip vecs" $ - mapM_ (uncurry decodeVecTest) $ zip [1 ..] validVec - it "decodes vector 2" vec2Test - it "decodes vector 3" vec3Test - it "decodes vector 4" vec4Test - it "decodes vector 5" vec5Test - it "decodes vector 6" vec6Test - it "signed and finalized p2pkh PSBTs verify" $ - property $ - forAll arbitraryKeyPair $ verifyNonWitnessPSBT btc . unfinalizedPkhPSBT btc + (runGet (getPSBT ctx) . runPut . putPSBT ctx) nonEmptyTransactionPSBT == Right nonEmptyTransactionPSBT + it "does not decode invalid BIP test vectors" $ + mapM_ (invalidVecTest ctx) invalidVec + it "encodes valid BIP test vectors" $ + mapM_ (uncurry (encodeVecTest ctx)) validEncodeVec + it "decodes valid BIP test vectors" $ + mapM_ (uncurry (decodeVecTest ctx)) $ + zip [1 ..] validVec + it "decodes vector 2" $ vec2Test ctx + it "decodes vector 3" $ vec3Test ctx + it "decodes vector 4" $ vec4Test ctx + it "decodes vector 5" $ vec5Test ctx + it "decodes vector 6" $ vec6Test ctx + it "signed and finalized P2PKH PSBTs verify" $ + property $ + forAll (arbitraryKeyPair ctx) $ + verifyNonWitnessPSBT btc ctx . unfinalizedPkhPSBT btc ctx it "signed and finalized multisig PSBTs verify" $ - property $ - forAll arbitraryMultiSig $ verifyNonWitnessPSBT btc . unfinalizedMsPSBT btc - it "encodes and decodes psbt with final witness script" $ - (fmap (encodeHex . S.encode) . decodeHexPSBT) validVec7Hex == Right validVec7Hex - it "handles complex psbts correctly" complexPsbtTest - it "calculates keys properly" psbtSignerTest + property $ + forAll (arbitraryMultiSig ctx) $ + verifyNonWitnessPSBT btc ctx . unfinalizedMsPSBT btc ctx + it "encodes and decodes PSBT with final witness script" $ + (fmap (encodeHex . runPut . putPSBT ctx) . decodeHexPSBT ctx) validVec7Hex == Right validVec7Hex + it "handles complex PSBTs correctly" $ complexPsbtTest ctx + it "calculates keys properly" $ psbtSignerTest ctx -vec2Test :: Assertion -vec2Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec2" validVec2Hex - assertEqual "2 inputs" 2 (length $ inputs psbt) - assertEqual "2 outputs" 2 (length $ outputs psbt) - assertBool "final script sig" $ isJust (finalScriptSig . head $ inputs psbt) +vec2Test :: Ctx -> Assertion +vec2Test ctx = do + psbt <- decodeHexPSBTM ctx "Cannot parse validVec2" validVec2Hex + assertEqual "2 inputs" 2 (length psbt.inputs) + assertEqual "2 outputs" 2 (length psbt.outputs) + assertBool "final script sig" $ isJust (head psbt.inputs).finalScriptSig - let rdmScript = fromJust . inputRedeemScript $ inputs psbt !! 1 - assertBool "p2wpkh" $ (isPayWitnessPKHash <$> decodeOutput rdmScript) == Right True + let rdmScript = fromJust (psbt.inputs !! 1).inputRedeemScript + assertBool "p2wpkh" $ (isPayWitnessPKHash <$> decodeOutput ctx rdmScript) == Right True - let scrptPubKey = witnessScriptPubKey $ inputs psbt !! 1 - rdmScriptP2SH = toP2SH rdmScript - assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey - assertEqual "expected redeem script" expectedOut rdmScriptP2SH + let scrptPubKey = witnessScriptPubKey ctx (psbt.inputs !! 1) + rdmScriptP2SH = toP2SH rdmScript + assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey + assertEqual "expected redeem script" (expectedOut ctx) rdmScriptP2SH - mapM_ (assertEqual "outputs are empty" emptyOutput) (outputs psbt) + mapM_ (assertEqual "outputs are empty" emptyOutput) psbt.outputs -vec3Test :: Assertion -vec3Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec3" validVec3Hex - assertEqual "1 input" 1 (length $ inputs psbt) - assertEqual "2 outputs" 2 (length $ outputs psbt) - let txInput = head . txIn $ unsignedTransaction psbt - firstInput = head $ inputs psbt - Just utx = nonWitnessUtxo firstInput - OutPoint prevHash prevVOut = prevOutput txInput - assertEqual "txids of inputs match" prevHash (txHash utx) - let prevOutputKey = - fromRight (error "Could not decode key") - . decodeOutputBS - . scriptOutput - $ txOut utx !! fromIntegral prevVOut - assertBool "p2pkh" $ isPayPKHash prevOutputKey - assertEqual "sighash type" sigHashAll (fromJust $ sigHashType firstInput) +vec3Test :: Ctx -> Assertion +vec3Test ctx = do + psbt <- decodeHexPSBTM ctx "Cannot parse validVec3" validVec3Hex + assertEqual "1 input" 1 (length psbt.inputs) + assertEqual "2 outputs" 2 (length psbt.outputs) + let (txInput : _) = psbt.unsignedTransaction.inputs + (firstInput : _) = psbt.inputs + Just utx = firstInput.nonWitnessUtxo + OutPoint prevHash prevVOut = txInput.outpoint + assertEqual "txids of inputs match" prevHash (txHash utx) + let prevOutputKey = + fromRight (error "Could not decode key") + . unmarshal ctx + . (.script) + $ utx.outputs !! fromIntegral prevVOut + assertBool "p2pkh" $ isPayPKHash prevOutputKey + assertEqual "sighash type" sigHashAll (fromJust firstInput.sigHashType) -vec4Test :: Assertion -vec4Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec4" validVec4Hex - assertEqual "2 inputs" 2 (length $ inputs psbt) - assertEqual "2 outputs" 2 (length $ outputs psbt) - let firstInput = head $ inputs psbt - secondInput = inputs psbt !! 1 - assertEqual "first input not final script sig" Nothing (finalScriptSig firstInput) - assertEqual "second input not final script sig" Nothing (finalScriptSig secondInput) +vec4Test :: Ctx -> Assertion +vec4Test ctx = do + psbt <- decodeHexPSBTM ctx "Cannot parse validVec4" validVec4Hex + assertEqual "2 inputs" 2 (length psbt.inputs) + assertEqual "2 outputs" 2 (length psbt.outputs) + let (firstInput : _) = psbt.inputs + (_ : secondInput : _) = psbt.inputs + assertEqual "first input not final script sig" Nothing firstInput.finalScriptSig + assertEqual "second input not final script sig" Nothing secondInput.finalScriptSig - let rdmScript = fromJust $ inputRedeemScript secondInput - assertBool "p2wpkh" $ (isPayWitnessPKHash <$> decodeOutput rdmScript) == Right True + let Just rdmScript = secondInput.inputRedeemScript + assertBool "p2wpkh" $ (isPayWitnessPKHash <$> decodeOutput ctx rdmScript) == Right True - let scrptPubKey = witnessScriptPubKey secondInput - rdmScriptP2SH = toP2SH rdmScript - assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey - assertEqual "expected redeem script" expectedOut rdmScriptP2SH + let scrptPubKey = witnessScriptPubKey ctx secondInput + rdmScriptP2SH = toP2SH rdmScript + assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey + assertEqual "expected redeem script" (expectedOut ctx) rdmScriptP2SH - assertBool "all non-empty outputs" $ emptyOutput `notElem` outputs psbt + assertBool "all non-empty outputs" $ emptyOutput `notElem` psbt.outputs -vec5Test :: Assertion -vec5Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec5" validVec5Hex - assertEqual "Correctly decode PSBT" expectedPsbt psbt - let input = head $ inputs psbt +vec5Test :: Ctx -> Assertion +vec5Test ctx = do + psbt <- decodeHexPSBTM ctx "Cannot parse validVec5" validVec5Hex + assertEqual "Correctly decode PSBT" expectedPsbt psbt + let (input : _) = psbt.inputs - let rdmScript = fromJust $ inputRedeemScript input - assertBool "p2wsh" $ (isPayWitnessScriptHash <$> decodeOutput rdmScript) == Right True + let Just rdmScript = input.inputRedeemScript + assertBool "p2wsh" $ (isPayWitnessScriptHash <$> decodeOutput ctx rdmScript) == Right True - let scrptPubKey = witnessScriptPubKey input - rdmScriptP2SH = toP2SH rdmScript - assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey - assertEqual "expected redeem script" expectedOut2 rdmScriptP2SH + let scrptPubKey = witnessScriptPubKey ctx input + rdmScriptP2SH = toP2SH rdmScript + assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey + assertEqual "expected redeem script" expectedOut2 rdmScriptP2SH where expectedOut2 = - fromRight (error "could not decode expected output") - . decodeOutputBS - . fromJust - $ decodeHex "a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87" + fromRight (error "could not decode expected output") + . unmarshal ctx + . fromJust + $ decodeHex "a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87" -- From the bitcoind decodepsbt rpc call expectedPsbt = - PartiallySignedTransaction - { unsignedTransaction = - Tx - { txVersion = 2 - , txIn = - [ TxIn - { prevOutput = - OutPoint - { outPointHash = "39bc5c3b33d66ce3d7852a7942331e3ec10f8ba50f225fc41fb5dfa523239a27" - , outPointIndex = 0 - } - , scriptInput = "" - , txInSequence = 4294967295 - } - ] - , txOut = - [ TxOut - { outValue = 199908000 - , scriptOutput = (fromJust . decodeHex) "76a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac" - } - ] - , txWitness = mempty - , txLockTime = 0 - } - , globalUnknown = mempty - , inputs = - [ Input - { nonWitnessUtxo = Nothing - , witnessUtxo = - Just - ( TxOut - { outValue = 199909013 - , scriptOutput = (fromJust . decodeHex) "a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87" - } - ) - , partialSigs = - fromList - [ - ( PubKeyI - { pubKeyPoint = "03b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd46" - , pubKeyCompressed = True - } - , (fromJust . decodeHex) "304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a01" - ) - ] - , sigHashType = Nothing - , inputRedeemScript = - Just - . fromRight (error "vec5Test: Could not decode redeem script") - . decode - . fromJust - $ decodeHex "0020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681" - , inputWitnessScript = - Just - . fromRight (error "vec5Test: Could not decode witness script") - . decode - . fromJust - $ decodeHex "522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae" - , inputHDKeypaths = - fromList - [ - ( PubKeyI - { pubKeyPoint = "03b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd46" - , pubKeyCompressed = True - } - , ("b4a6ba67", [hardIndex 0, hardIndex 0, hardIndex 4]) - ) - , - ( PubKeyI - { pubKeyPoint = "03de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd" - , pubKeyCompressed = True - } - , ("b4a6ba67", [hardIndex 0, hardIndex 0, hardIndex 5]) - ) - ] - , finalScriptSig = Nothing - , finalScriptWitness = Nothing - , inputUnknown = mempty - } - ] - , outputs = - [ Output - { outputRedeemScript = Nothing - , outputWitnessScript = Nothing - , outputHDKeypaths = mempty - , outputUnknown = mempty - } - ] - } + PSBT + { unsignedTransaction = + Tx + { version = 2, + inputs = + [ TxIn + { outpoint = + OutPoint + { hash = "39bc5c3b33d66ce3d7852a7942331e3ec10f8ba50f225fc41fb5dfa523239a27", + index = 0 + }, + script = "", + sequence = 4294967295 + } + ], + outputs = + [ TxOut + { value = 199908000, + script = (fromJust . decodeHex) "76a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac" + } + ], + witness = mempty, + locktime = 0 + }, + globalUnknown = mempty, + inputs = + [ Input + { nonWitnessUtxo = Nothing, + witnessUtxo = + Just + ( TxOut + { value = 199909013, + script = (fromJust . decodeHex) "a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87" + } + ), + partialSigs = + fromList + [ ( PublicKey + { point = + fromJust $ + importPubKey ctx + =<< decodeHex + "03b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd46", + compress = True + }, + (fromJust . decodeHex) "304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a01" + ) + ], + sigHashType = Nothing, + inputRedeemScript = + Just + . fromRight (error "vec5Test: Could not decode redeem script") + . decode + . fromJust + $ decodeHex "0020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681", + inputWitnessScript = + Just + . fromRight (error "vec5Test: Could not decode witness script") + . decode + . fromJust + $ decodeHex "522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae", + inputHDKeypaths = + fromList + [ ( PublicKey + { point = + fromJust $ + importPubKey ctx + =<< decodeHex + "03b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd46", + compress = True + }, + ("b4a6ba67", [hardIndex 0, hardIndex 0, hardIndex 4]) + ), + ( PublicKey + { point = + fromJust $ + importPubKey ctx + =<< decodeHex + "03de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd", + compress = True + }, + ("b4a6ba67", [hardIndex 0, hardIndex 0, hardIndex 5]) + ) + ], + finalScriptSig = Nothing, + finalScriptWitness = Nothing, + inputUnknown = mempty + } + ], + outputs = + [ Output + { outputRedeemScript = Nothing, + outputWitnessScript = Nothing, + outputHDKeypaths = mempty, + outputUnknown = mempty + } + ] + } hardIndex = (+ 2 ^ 31) -vec6Test :: Assertion -vec6Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec6" validVec6Hex - assertEqual "1 input" 1 (length $ inputs psbt) - assertEqual "1 output" 1 (length $ outputs psbt) +vec6Test :: Ctx -> Assertion +vec6Test ctx = do + psbt <- decodeHexPSBTM ctx "Cannot parse validVec6" validVec6Hex + assertEqual "1 input" 1 (length psbt.inputs) + assertEqual "1 output" 1 (length psbt.outputs) - let tx = unsignedTransaction psbt - assertEqual "correct transaction" "75c5c9665a570569ad77dd1279e6fd4628a093c4dcbf8d41532614044c14c115" (txHash tx) + let tx = psbt.unsignedTransaction + assertEqual "correct transaction" "75c5c9665a570569ad77dd1279e6fd4628a093c4dcbf8d41532614044c14c115" (txHash tx) - assertEqual "correct unknowns" expectedUnknowns (inputUnknown . head $ inputs psbt) + assertEqual "correct unknowns" expectedUnknowns (head psbt.inputs).inputUnknown where expectedUnknowns = - UnknownMap $ - singleton - (Key 0x0f (fromJust $ decodeHex "010203040506070809")) - (fromJust $ decodeHex "0102030405060708090a0b0c0d0e0f") + UnknownMap $ + singleton + (Key 0x0f (fromJust $ decodeHex "010203040506070809")) + (fromJust $ decodeHex "0102030405060708090a0b0c0d0e0f") -complexPsbtTest :: Assertion -complexPsbtTest = do - complexPsbtData <- readTestFile "complex_psbt.json" +complexPsbtTest :: Ctx -> Assertion +complexPsbtTest ctx = do + complex <- readTestFileParser (parseComplexJSON ctx) "complex_psbt.json" - let computedCombinedPsbt = mergeMany $ complexSignedPsbts complexPsbtData - expectedCombinedPsbt = stripRedundantUtxos $ complexCombinedPsbt complexPsbtData - assertEqual "combined psbt" computedCombinedPsbt (Just expectedCombinedPsbt) + let computedCombinedPsbt = mergeMany $ complexSignedPsbts complex + expectedCombinedPsbt = stripRedundantUtxos $ complexCombinedPsbt complex + assertEqual "combined psbt" computedCombinedPsbt (Just expectedCombinedPsbt) - let computedCompletePsbt = complete $ complexCombinedPsbt complexPsbtData - expectedCompletePsbt = complexCompletePsbt complexPsbtData - assertEqual "complete psbt" computedCompletePsbt expectedCompletePsbt + let computedCompletePsbt = complete ctx $ complexCombinedPsbt complex + expectedCompletePsbt = complexCompletePsbt complex + assertEqual "complete psbt" computedCompletePsbt expectedCompletePsbt - let computedFinalTx = finalTransaction $ complexCompletePsbt complexPsbtData - assertEqual "final tx" computedFinalTx (complexFinalTx complexPsbtData) + let computedFinalTx = finalTransaction $ complexCompletePsbt complex + assertEqual "final tx" computedFinalTx (complexFinalTx complex) where - stripRedundantUtxos psbt = psbt{inputs = stripRedundantUtxo <$> inputs psbt} + stripRedundantUtxos PSBT {..} = PSBT {inputs = stripRedundantUtxo <$> inputs, ..} stripRedundantUtxo input - | Just{} <- witnessUtxo input = input{nonWitnessUtxo = Nothing} - | otherwise = input + | Just {} <- input.witnessUtxo = input {nonWitnessUtxo = Nothing} + | otherwise = input -psbtSignerTest :: Assertion -psbtSignerTest = do - assertEqual "recover explicit secret key" (Just theSecKey) (getSignerKey signer thePubKey Nothing) - assertEqual - "recover key for origin path" - (Just originPathSecKey) - (getSignerKey signer originPathPubKey (Just (rootFP, originKeyPath))) - assertEqual - "recover key for direct path" - (Just directPathSecKey) - (getSignerKey signer directPathPubKey (Just (keyFP, directPath))) +psbtSignerTest :: Ctx -> Assertion +psbtSignerTest ctx = do + assertEqual "recover explicit secret key" (Just theSecKey) (getSignerKey signer thePubKey Nothing) + assertEqual + "recover key for origin path" + (Just originPathSecKey) + (getSignerKey signer originPathPubKey (Just (rootFP, originKeyPath))) + assertEqual + "recover key for direct path" + (Just directPathSecKey) + (getSignerKey signer directPathPubKey (Just (keyFP, directPath))) where - signer = secKeySigner theSecKey <> xPrvSigner xprv (Just origin) + signer = secKeySigner ctx theSecKey <> xPrvSigner ctx xprv (Just origin) Just theSecKey = secKey "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" - thePubKey = PubKeyI{pubKeyPoint = derivePubKey theSecKey, pubKeyCompressed = True} + thePubKey = PublicKey {point = derivePubKey ctx theSecKey, compress = True} - rootXPrv = makeXPrvKey "psbtSignerTest" - rootFP = xPubFP $ deriveXPubKey rootXPrv - xprv = derivePath keyPath rootXPrv - keyFP = xPubFP $ deriveXPubKey xprv + rootXPrv = makeXPrvKey "PSBTSignerTest" + rootFP = xPubFP ctx $ deriveXPubKey ctx rootXPrv + xprv = derivePath ctx keyPath rootXPrv + keyFP = xPubFP ctx $ deriveXPubKey ctx xprv keyPath = Deriv :| 444 origin = (rootFP, keyPath) originKeyPath = Deriv :| 444 :/ 0 - originPathSecKey = xPrvKey $ derivePath originKeyPath rootXPrv - originPathPubKey = PubKeyI{pubKeyPoint = derivePubKey originPathSecKey, pubKeyCompressed = True} + originPathSecKey = (derivePath ctx originKeyPath rootXPrv).key + originPathPubKey = PublicKey {point = derivePubKey ctx originPathSecKey, compress = True} directPath = Deriv :/ 1 - directPathSecKey = xPrvKey $ derivePath directPath xprv - directPathPubKey = PubKeyI{pubKeyPoint = derivePubKey directPathSecKey, pubKeyCompressed = True} + directPathSecKey = (derivePath ctx directPath xprv).key + directPathPubKey = PublicKey {point = derivePubKey ctx directPathSecKey, compress = True} -expectedOut :: ScriptOutput -expectedOut = - fromRight (error "could not decode expected output") - . decodeOutputBS - . fromJust - $ decodeHex "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" +expectedOut :: Ctx -> ScriptOutput +expectedOut ctx = + fromRight (error "could not decode expected output") + . unmarshal ctx + . fromJust + $ decodeHex "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" -witnessScriptPubKey :: Input -> ScriptOutput -witnessScriptPubKey = - fromRight (error "could not decode witness utxo") - . decodeOutputBS - . scriptOutput - . fromJust - . witnessUtxo +witnessScriptPubKey :: Ctx -> Input -> ScriptOutput +witnessScriptPubKey ctx = + fromRight (error "could not decode witness utxo") + . unmarshal ctx + . (.script) + . fromJust + . (.witnessUtxo) -decodeHexPSBT :: Text -> Either String PartiallySignedTransaction -decodeHexPSBT = S.decode . fromJust . decodeHex +decodeHexPSBT :: Ctx -> Text -> Either String PSBT +decodeHexPSBT ctx = runGet (getPSBT ctx) . fromJust . decodeHex -decodeHexPSBTM :: (Monad m, MonadFail m) => String -> Text -> m PartiallySignedTransaction -decodeHexPSBTM errMsg = either (fail . (errMsg <>) . (": " <>)) return . decodeHexPSBT +decodeHexPSBTM :: (Monad m, MonadFail m) => Ctx -> String -> Text -> m PSBT +decodeHexPSBTM ctx errMsg = either (fail . (errMsg <>) . (": " <>)) return . decodeHexPSBT ctx hexScript :: Text -> ByteString hexScript = - either (error "Could not decode script") encodeScript - . runGetS deserialize - . fromJust - . decodeHex + either (error "Could not decode script") encodeScript + . runGetS deserialize + . fromJust + . decodeHex where encodeScript :: Script -> ByteString encodeScript = runPutS . serialize -invalidVecTest :: Text -> Assertion -invalidVecTest = assertBool "invalid psbt" . isLeft . decodeHexPSBT +invalidVecTest :: Ctx -> Text -> Assertion +invalidVecTest ctx = assertBool "invalid psbt" . isLeft . decodeHexPSBT ctx -decodeVecTest :: Int -> Text -> Assertion -decodeVecTest i = assertBool (show i <> " decodes correctly") . isRight . decodeHexPSBT +decodeVecTest :: Ctx -> Int -> Text -> Assertion +decodeVecTest ctx i = assertBool (show i <> " decodes correctly") . isRight . decodeHexPSBT ctx -encodeVecTest :: PartiallySignedTransaction -> Text -> Assertion -encodeVecTest psbt hex = assertEqual "encodes correctly" (S.encode psbt) (fromJust $ decodeHex hex) +encodeVecTest :: Ctx -> PSBT -> Text -> Assertion +encodeVecTest ctx psbt hex = + assertEqual + "encodes correctly" + ((runPut . putPSBT ctx) psbt) + ((fromJust . decodeHex) hex) -trivialPSBT :: PartiallySignedTransaction +trivialPSBT :: PSBT trivialPSBT = - PartiallySignedTransaction - { unsignedTransaction = Tx{txVersion = 2, txIn = [], txOut = [], txWitness = [], txLockTime = 0} - , globalUnknown = UnknownMap mempty - , inputs = [] - , outputs = [] - } + PSBT + { unsignedTransaction = Tx {version = 2, inputs = [], outputs = [], witness = [], locktime = 0}, + globalUnknown = UnknownMap mempty, + inputs = [], + outputs = [] + } trivialPSBTHex :: Text trivialPSBTHex = "70736274ff01000a0200000000000000000000" -nonEmptyTransactionPSBT :: PartiallySignedTransaction +nonEmptyTransactionPSBT :: PSBT nonEmptyTransactionPSBT = emptyPSBT testTx1 -verifyNonWitnessPSBT :: Network -> PartiallySignedTransaction -> Bool -verifyNonWitnessPSBT net psbt = verifyStdTx net (finalTransaction (complete psbt)) sigData +verifyNonWitnessPSBT :: Network -> Ctx -> PSBT -> Bool +verifyNonWitnessPSBT net ctx psbt = + verifyStdTx net ctx (finalTransaction (complete ctx psbt)) sigData where - sigData = inputSigData =<< zip (inputs psbt) (txIn $ unsignedTransaction psbt) - decodeOutScript = fromRight (error "Could not parse output script") . decodeOutputBS - inputSigData (input, txInput) = - map - (\(TxOut val script) -> (decodeOutScript script, val, prevOutput txInput)) - (txOut . fromJust $ nonWitnessUtxo input) + sigData = inputSigData =<< zip psbt.inputs psbt.unsignedTransaction.inputs + decodeOutScript = fromRight (error "Could not parse output script") . unmarshal ctx + inputSigData (input@Input {}, txInput@TxIn {}) = + map + (\(TxOut val script) -> (decodeOutScript script, val, txInput.outpoint)) + (fromJust input.nonWitnessUtxo).outputs -unfinalizedPkhPSBT :: Network -> (SecKeyI, PubKeyI) -> PartiallySignedTransaction -unfinalizedPkhPSBT net (prvKey, pubKey) = - (emptyPSBT currTx) - { inputs = [emptyInput{nonWitnessUtxo = Just prevTx, partialSigs = singleton pubKey sig}] - } +unfinalizedPkhPSBT :: Network -> Ctx -> (PrivateKey, PublicKey) -> PSBT +unfinalizedPkhPSBT net ctx (prvKey, pubKey) = + let PSBT {..} = emptyPSBT currTx + in PSBT {inputs = [input], ..} where - currTx = unfinalizedTx (txHash prevTx) - prevTx = testUtxo [prevOut] - prevOutScript = addressToScript (pubKeyAddr pubKey) + input = + emptyInput + { nonWitnessUtxo = Just prevTx, + partialSigs = singleton pubKey sig + } + currTx = + unfinalizedTx (txHash prevTx) + prevTx = + testUtxo [prevOut] + prevOutScript = + addressToScript ctx (pubKeyAddr ctx pubKey) prevOut = - TxOut - { outValue = 200000000 - , scriptOutput = runPutS (serialize prevOutScript) - } - h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll - sig = encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll - -arbitraryMultiSig :: Gen ([(SecKeyI, PubKeyI)], Int) -arbitraryMultiSig = do - (m, n) <- arbitraryMSParam - keys <- vectorOf n arbitraryKeyPair - return (keys, m) - -unfinalizedMsPSBT :: Network -> ([(SecKeyI, PubKeyI)], Int) -> PartiallySignedTransaction -unfinalizedMsPSBT net (keys, m) = - (emptyPSBT currTx) - { inputs = - [ emptyInput - { nonWitnessUtxo = Just prevTx - , partialSigs = sigs - , inputRedeemScript = Just prevOutScript - } - ] + TxOut + { value = 200000000, + script = runPutS (serialize prevOutScript) } + h = txSigHash net currTx prevOutScript prevOut.value 0 sigHashAll + sig = + encodeTxSig net ctx $ + TxSignature (signHash ctx prvKey.key h) sigHashAll + +arbitraryMultiSig :: Ctx -> Gen ([(PrivateKey, PublicKey)], Int) +arbitraryMultiSig ctx = do + (m, n) <- arbitraryMSParam + keys <- vectorOf n (arbitraryKeyPair ctx) + return (keys, m) + +unfinalizedMsPSBT :: Network -> Ctx -> ([(PrivateKey, PublicKey)], Int) -> PSBT +unfinalizedMsPSBT net ctx (keys, m) = + let PSBT {..} = emptyPSBT currTx + in PSBT {inputs = [input], ..} where + input = + emptyInput + { nonWitnessUtxo = Just prevTx, + partialSigs = sigs, + inputRedeemScript = Just prevOutScript + } currTx = unfinalizedTx (txHash prevTx) prevTx = testUtxo [prevOut] - prevOutScript = encodeOutput $ PayMulSig (map snd keys) m - prevOut = TxOut{outValue = 200000000, scriptOutput = encodeOutputBS (toP2SH prevOutScript)} - h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll + prevOutScript = encodeOutput ctx $ PayMulSig (map snd keys) m + prevOut = + TxOut + { value = 200000000, + script = marshal ctx (toP2SH prevOutScript) + } + h = txSigHash net currTx prevOutScript prevOut.value 0 sigHashAll sigs = fromList $ map sig keys - sig (prvKey, pubKey) = (pubKey, encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll) + sig (prvKey@PrivateKey {key}, pubKey) = + let sh = signHash ctx key h + ts = TxSignature sh sigHashAll + in (pubKey, encodeTxSig net ctx ts) unfinalizedTx :: TxHash -> Tx unfinalizedTx prevHash = - Tx - { txVersion = 2 - , txIn = - [ TxIn - { prevOutput = OutPoint prevHash 0 - , scriptInput = "" - , txInSequence = 4294967294 - } - ] - , txOut = - [ TxOut{outValue = 99999699, scriptOutput = hexScript "76a914d0c59903c5bac2868760e90fd521a4665aa7652088ac"} - , TxOut{outValue = 100000000, scriptOutput = hexScript "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787"} - ] - , txWitness = [] - , txLockTime = 1257139 - } + Tx + { version = 2, + inputs = + [ TxIn + { outpoint = OutPoint prevHash 0, + script = "", + sequence = 4294967294 + } + ], + outputs = + [ TxOut {value = 99999699, script = hexScript "76a914d0c59903c5bac2868760e90fd521a4665aa7652088ac"}, + TxOut {value = 100000000, script = hexScript "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787"} + ], + witness = [], + locktime = 1257139 + } invalidVec :: [Text] invalidVec = - [ "0200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf6000000006a473044022070b2245123e6bf474d60c5b50c043d4c691a5d2435f09a34a7662a9dc251790a022001329ca9dacf280bdf30740ec0390422422c81cb45839457aeb76fc12edd95b3012102657d118d3357b8e0f4c2cd46db7b39f6d9c38d9a70abcb9b2de5dc8dbfe4ce31feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300" - , "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000000" - , "70736274ff0100fd0a010200000002ab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be4000000006a47304402204759661797c01b036b25928948686218347d89864b719e1f7fcf57d1e511658702205309eabf56aa4d8891ffd111fdf1336f3a29da866d7f8486d75546ceedaf93190121035cdc61fc7ba971c0b501a646a2a83b102cb43881217ca682dc86e2d73fa88292feffffffab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be40100000000feffffff02603bea0b000000001976a914768a40bbd740cbe81d988e71de2a4d5c71396b1d88ac8e240000000000001976a9146f4620b553fa095e721b9ee0efe9fa039cca459788ac00000000000001012000e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787010416001485d13537f2e265405a34dbafa9e3dda01fb82308000000" - , "70736274ff000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000000" - , "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000001003f0200000001ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff0000000000ffffffff010000000000000000036a010000000000000000" - , "70736274ff020001550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac000000000002010020955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87210203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd46304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a01020400220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d568102050047522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae210603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd10b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f0000000000020000bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" - , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f618765000000020700da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" - , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b2028903020800da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" - , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00210203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca58710d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" - , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c0203000100000000010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a65010125512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" - , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c0002000016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a65010125512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" - , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c00010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a6521010025512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" - ] + [ "0200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf6000000006a473044022070b2245123e6bf474d60c5b50c043d4c691a5d2435f09a34a7662a9dc251790a022001329ca9dacf280bdf30740ec0390422422c81cb45839457aeb76fc12edd95b3012102657d118d3357b8e0f4c2cd46db7b39f6d9c38d9a70abcb9b2de5dc8dbfe4ce31feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300", + "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000000", + "70736274ff0100fd0a010200000002ab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be4000000006a47304402204759661797c01b036b25928948686218347d89864b719e1f7fcf57d1e511658702205309eabf56aa4d8891ffd111fdf1336f3a29da866d7f8486d75546ceedaf93190121035cdc61fc7ba971c0b501a646a2a83b102cb43881217ca682dc86e2d73fa88292feffffffab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be40100000000feffffff02603bea0b000000001976a914768a40bbd740cbe81d988e71de2a4d5c71396b1d88ac8e240000000000001976a9146f4620b553fa095e721b9ee0efe9fa039cca459788ac00000000000001012000e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787010416001485d13537f2e265405a34dbafa9e3dda01fb82308000000", + "70736274ff000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000000", + "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000001003f0200000001ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff0000000000ffffffff010000000000000000036a010000000000000000", + "70736274ff020001550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000", + "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac000000000002010020955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000", + "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87210203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd46304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000", + "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a01020400220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000", + "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d568102050047522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000", + "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae210603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd10b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000", + "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f0000000000020000bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000", + "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f618765000000020700da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000", + "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b2028903020800da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000", + "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00210203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca58710d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000", + "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c0203000100000000010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a65010125512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00", + "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c0002000016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a65010125512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00", + "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c00010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a6521010025512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" + ] -validEncodeVec :: [(PartiallySignedTransaction, Text)] +validEncodeVec :: [(PSBT, Text)] validEncodeVec = [(validVec1, validVec1Hex)] testTx1 :: Tx testTx1 = - Tx - { txVersion = 2 - , txIn = - [ TxIn - { prevOutput = OutPoint "f61b1742ca13176464adb3cb66050c00787bb3a4eead37e985f2df1e37718126" 0 - , scriptInput = "" - , txInSequence = 4294967294 - } - ] - , txOut = - [ TxOut{outValue = 99999699, scriptOutput = hexScript "76a914d0c59903c5bac2868760e90fd521a4665aa7652088ac"} - , TxOut{outValue = 100000000, scriptOutput = hexScript "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787"} - ] - , txWitness = [] - , txLockTime = 1257139 - } + Tx + { version = 2, + inputs = + [ TxIn + { outpoint = OutPoint "f61b1742ca13176464adb3cb66050c00787bb3a4eead37e985f2df1e37718126" 0, + script = "", + sequence = 4294967294 + } + ], + outputs = + [ TxOut {value = 99999699, script = hexScript "76a914d0c59903c5bac2868760e90fd521a4665aa7652088ac"}, + TxOut {value = 100000000, script = hexScript "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787"} + ], + witness = [], + locktime = 1257139 + } testUtxo :: [TxOut] -> Tx testUtxo prevOuts = - Tx - { txVersion = 1 - , txIn = - [ TxIn - { prevOutput = OutPoint "e567952fb6cc33857f392efa3a46c995a28f69cca4bb1b37e0204dab1ec7a389" 1 - , scriptInput = hexScript "160014be18d152a9b012039daf3da7de4f53349eecb985" - , txInSequence = 4294967295 - } - , TxIn - { prevOutput = OutPoint "b490486aec3ae671012dddb2bb08466bef37720a533a894814ff1da743aaf886" 1 - , scriptInput = hexScript "160014fe3e9ef1a745e974d902c4355943abcb34bd5353" - , txInSequence = 4294967295 - } - ] - , txOut = prevOuts - , txWitness = - [ - [ fromJust $ decodeHex "304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c01" - , fromJust $ decodeHex "03d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f2105" - ] - , - [ fromJust $ decodeHex "3045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01" - , fromJust $ decodeHex "0223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab3" - ] - ] - , txLockTime = 0 - } + Tx + { version = 1, + inputs = + [ TxIn + { outpoint = OutPoint "e567952fb6cc33857f392efa3a46c995a28f69cca4bb1b37e0204dab1ec7a389" 1, + script = hexScript "160014be18d152a9b012039daf3da7de4f53349eecb985", + sequence = 4294967295 + }, + TxIn + { outpoint = OutPoint "b490486aec3ae671012dddb2bb08466bef37720a533a894814ff1da743aaf886" 1, + script = hexScript "160014fe3e9ef1a745e974d902c4355943abcb34bd5353", + sequence = 4294967295 + } + ], + outputs = prevOuts, + witness = + [ [ fromJust $ decodeHex "304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c01", + fromJust $ decodeHex "03d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f2105" + ], + [ fromJust $ decodeHex "3045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01", + fromJust $ decodeHex "0223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab3" + ] + ], + locktime = 0 + } testUtxo1 :: Tx testUtxo1 = - testUtxo - [ TxOut{outValue = 200000000, scriptOutput = hexScript "76a91485cff1097fd9e008bb34af709c62197b38978a4888ac"} - , TxOut{outValue = 190303501938, scriptOutput = hexScript "a914339725ba21efd62ac753a9bcd067d6c7a6a39d0587"} - ] + testUtxo + [ TxOut {value = 200000000, script = hexScript "76a91485cff1097fd9e008bb34af709c62197b38978a4888ac"}, + TxOut {value = 190303501938, script = hexScript "a914339725ba21efd62ac753a9bcd067d6c7a6a39d0587"} + ] -validVec1 :: PartiallySignedTransaction -validVec1 = (emptyPSBT testTx1){inputs = [emptyInput{nonWitnessUtxo = Just testUtxo1}]} +validVec1 :: PSBT +validVec1 = + let PSBT {..} = emptyPSBT testTx1 + in PSBT {inputs = [emptyInput {nonWitnessUtxo = Just testUtxo1}], ..} validVec :: [Text] validVec = [validVec1Hex, validVec2Hex, validVec3Hex, validVec4Hex, validVec5Hex, validVec6Hex] @@ -534,35 +569,43 @@ validVec6Hex = "70736274ff01003f0200000001ffffffffffffffffffffffffffffffffffffff validVec7Hex :: Text validVec7Hex = "70736274ff0100520200000001815dd29e16fd2f567a040ce24f5337fb9cfd0c05bacd8890714a33edc7cbbc920000000000ffffffff0192f1052a01000000160014ef9ade26f63015d57f4ecdb268d1a9b8d6cd8872000000000001008402000000010000000000000000000000000000000000000000000000000000000000000000ffffffff03510101ffffffff0200f2052a010000001600145f4ffa19dbbe464561c50fc4d8d8ac0b41009dd20000000000000000266a24aa21a9ede2f61c3f71d1defd3fa999dfa36953755c690689799962b48bebd836974e8cf90000000001011f00f2052a010000001600145f4ffa19dbbe464561c50fc4d8d8ac0b41009dd201086b02473044022026a9f7afdb0128970bb3577e536ec3d3dc10c1e82650d11c9da1df9003b31d0202202258b11f962f12e0897c642cd6f38a0181db17197f3693a530c9431eb44dde7d0121033dc786e9628bb6c41c08fceb9b37458ad7a95e7e6b04e0bde45b6879398c3ac100220203a6affb58dda998a4ffdce652feb91038fdfc78c748ae687372e11292af8d312d101c4c5bfc00000080000000800100008000" -data ComplexPsbtData = ComplexPsbtData - { complexSignedPsbts :: [PartiallySignedTransaction] - , complexCombinedPsbt :: PartiallySignedTransaction - , complexCompletePsbt :: PartiallySignedTransaction - , complexFinalTx :: Tx - } - deriving (Eq, Show) +data ComplexPSBT = ComplexPSBT + { complexSignedPsbts :: [PSBT], + complexCombinedPsbt :: PSBT, + complexCompletePsbt :: PSBT, + complexFinalTx :: Tx + } + deriving (Eq, Show) -instance FromJSON ComplexPsbtData where - parseJSON = withObject "ComplexPsbtData" $ \obj -> do - ComplexPsbtData - <$> sequence - [ psbtField "miner_psbt" obj - , psbtField "p2pkh_psbt" obj - , psbtField "p2sh_ms_1_psbt" obj - , psbtField "p2sh_ms_2_psbt" obj - , psbtField "p2sh_pk_psbt" obj - , psbtField "p2sh_wsh_pk_psbt" obj - , psbtField "p2sh_wsh_ms_1_psbt" obj - , psbtField "p2sh_wsh_ms_2_psbt" obj - , psbtField "p2wpkh_psbt" obj - , psbtField "p2wsh_pk_psbt" obj - , psbtField "p2wsh_ms_1_psbt" obj - , psbtField "p2wsh_ms_2_psbt" obj - ] - <*> psbtField "combined_psbt" obj - <*> psbtField "complete_psbt" obj - <*> (obj .: "final_tx" >>= parseTx) - where - parseTx = either fail pure . (S.decode <=< maybe (Left "hex") Right . decodeHex) - parsePsbt = either fail pure . (S.decode <=< first Text.unpack . decodeBase64) . encodeUtf8 - psbtField fieldName obj = obj .: fieldName >>= parsePsbt +parseComplexJSON ctx = withObject "ComplexPSBT" $ \obj -> do + ComplexPSBT + <$> sequence + [ psbtField "miner_psbt" obj, + psbtField "p2pkh_psbt" obj, + psbtField "p2sh_ms_1_psbt" obj, + psbtField "p2sh_ms_2_psbt" obj, + psbtField "p2sh_pk_psbt" obj, + psbtField "p2sh_wsh_pk_psbt" obj, + psbtField "p2sh_wsh_ms_1_psbt" obj, + psbtField "p2sh_wsh_ms_2_psbt" obj, + psbtField "p2wpkh_psbt" obj, + psbtField "p2wsh_pk_psbt" obj, + psbtField "p2wsh_ms_1_psbt" obj, + psbtField "p2wsh_ms_2_psbt" obj + ] + <*> psbtField "combined_psbt" obj + <*> psbtField "complete_psbt" obj + <*> (obj .: "final_tx" >>= parseTx) + where + parseTx = + either fail pure + . ( decode + <=< maybe (Left "hex") Right + . decodeHex + ) + parsePsbt = + either fail pure + . (runGet (getPSBT ctx) <=< first Text.unpack . decodeBase64) + . encodeUtf8 + psbtField fieldName obj = + obj .: fieldName >>= parsePsbt diff --git a/test/Haskoin/Transaction/TaprootSpec.hs b/test/Haskoin/Transaction/TaprootSpec.hs index 3a85b472..43925fe0 100644 --- a/test/Haskoin/Transaction/TaprootSpec.hs +++ b/test/Haskoin/Transaction/TaprootSpec.hs @@ -1,189 +1,181 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module Haskoin.Transaction.TaprootSpec (spec) where import Control.Applicative ((<|>)) import Control.Monad (zipWithM, (<=<)) -import Data.Aeson (FromJSON (parseJSON), withObject, (.:), (.:?)) -import Data.Aeson.Types (Parser) -import qualified Data.ByteArray as BA +import Data.Aeson +import Data.Aeson.Types +import Data.ByteArray qualified as BA import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Bytes.Get (runGetS) import Data.Bytes.Put (runPutS) import Data.Bytes.Serial (deserialize, serialize) import Data.Text (Text) import Data.Word (Word8) -import Haskoin ( - MAST (..), - PubKey, - PubKeyI (PubKeyI), - ScriptOutput, - ScriptPathData (..), - TaprootOutput (TaprootOutput), - TaprootWitness (ScriptPathSpend), - XOnlyPubKey (..), - addrToText, - btc, - decodeHex, - encodeTaprootWitness, - getMerkleProofs, - mastCommitment, - outputAddress, - taprootInternalKey, - taprootMAST, - taprootOutputKey, - taprootScriptOutput, - verifyScriptPathData, - ) -import Haskoin.UtilSpec (readTestFile) +import Haskoin import Test.HUnit (assertBool, (@?=)) import Test.Hspec (Spec, describe, it, runIO) spec :: Spec -spec = do - TestVector{testScriptPubKey} <- runIO $ readTestFile "bip341.json" - describe "Taproot" $ do - it "should calculate the correct hashes" $ mapM_ testHashes testScriptPubKey - it "should build the correct output key" $ mapM_ testOutputKey testScriptPubKey - it "should build the correct script output" $ mapM_ testScriptOutput testScriptPubKey - it "should calculate the correct control blocks" $ mapM_ testControlBlocks testScriptPubKey - it "should arrive at the correct address" $ mapM_ testAddress testScriptPubKey +spec = prepareContext $ \ctx -> do + TestVector {testScriptPubKey} <- + runIO $ + readTestFileParser (testVectorParseJSON ctx) "bip341.json" + describe "Taproot" $ do + it "should calculate the correct hashes" $ + mapM_ testHashes testScriptPubKey + it "should build the correct output key" $ + mapM_ (testOutputKey ctx) testScriptPubKey + it "should build the correct script output" $ + mapM_ (testScriptOutput ctx) testScriptPubKey + it "should calculate the correct control blocks" $ + mapM_ (testControlBlocks ctx) testScriptPubKey + it "should arrive at the correct address" $ + mapM_ (testAddress ctx) testScriptPubKey testHashes :: TestScriptPubKey -> IO () testHashes testData = - mapM_ checkMASTDetails $ (taprootMAST . tspkGiven) testData + mapM_ checkMASTDetails $ ((.mast) . tspkGiven) testData where checkMASTDetails theMAST = do - -- Leaf hashes - (Just . getLeafHashes) theMAST @?= (spkiLeafHashes . tspkIntermediary) testData - -- Merkle root - (Just . BA.convert . mastCommitment) theMAST @?= (spkiMerkleRoot . tspkIntermediary) testData + -- Leaf hashes + (Just . getLeafHashes) theMAST @?= (spkiLeafHashes . tspkIntermediary) testData + -- Merkle root + (Just . BA.convert . mastCommitment) theMAST @?= (spkiMerkleRoot . tspkIntermediary) testData getLeafHashes = \case - MASTBranch branchL branchR -> getLeafHashes branchL <> getLeafHashes branchR - leaf@MASTLeaf{} -> [BA.convert $ mastCommitment leaf] - MASTCommitment{} -> mempty -- The test vectors have complete trees + MASTBranch branchL branchR -> getLeafHashes branchL <> getLeafHashes branchR + leaf@MASTLeaf {} -> [BA.convert $ mastCommitment leaf] + MASTCommitment {} -> mempty -- The test vectors have complete trees -testOutputKey :: TestScriptPubKey -> IO () -testOutputKey testData = do - XOnlyPubKey (taprootOutputKey theOutput) @?= theOutputKey +testOutputKey :: Ctx -> TestScriptPubKey -> IO () +testOutputKey ctx testData = do + XOnlyPubKey (taprootOutputKey ctx theOutput) @?= theOutputKey where theOutput = tspkGiven testData theOutputKey = XOnlyPubKey . spkiTweakedPubKey $ tspkIntermediary testData -testScriptOutput :: TestScriptPubKey -> IO () -testScriptOutput testData = - taprootScriptOutput (tspkGiven testData) @?= (spkeScriptPubKey . tspkExpected) testData +testScriptOutput :: Ctx -> TestScriptPubKey -> IO () +testScriptOutput ctx testData = + taprootScriptOutput ctx (tspkGiven testData) @?= (spkeScriptPubKey . tspkExpected) testData -testControlBlocks :: TestScriptPubKey -> IO () -testControlBlocks testData = do - mapM_ onExamples exampleControlBlocks - mapM_ checkVerification scriptPathSpends +testControlBlocks :: Ctx -> TestScriptPubKey -> IO () +testControlBlocks ctx testData = do + mapM_ onExamples exampleControlBlocks + mapM_ checkVerification scriptPathSpends where theOutput = tspkGiven testData - theOutputKey = taprootOutputKey theOutput + theOutputKey = taprootOutputKey ctx theOutput exampleControlBlocks = spkeControlBlocks $ tspkExpected testData calculatedControlBlocks = - (!! 1) . encodeTaprootWitness . ScriptPathSpend <$> scriptPathSpends + (!! 1) . encodeTaprootWitness ctx . ScriptPathSpend <$> scriptPathSpends scriptPathSpends = - fmap mkScriptPathSpend - . maybe mempty getMerkleProofs - $ taprootMAST theOutput - mkScriptPathSpend (scriptPathLeafVersion, scriptPathScript, proof) = - ScriptPathData - { scriptPathAnnex = Nothing - , scriptPathStack = mempty - , scriptPathScript - , scriptPathExternalIsOdd = odd $ keyParity theOutputKey - , scriptPathLeafVersion - , scriptPathInternalKey = taprootInternalKey theOutput - , scriptPathControl = BA.convert <$> proof - } + mkScriptPathSpend <$> maybe mempty getMerkleProofs theOutput.mast + mkScriptPathSpend (leafVersion, script, proof) = + ScriptPathData + { annex = Nothing, + stack = mempty, + script, + extIsOdd = odd $ keyParity ctx theOutputKey, + leafVersion, + internalKey = theOutput.internalKey, + control = BA.convert <$> proof + } onExamples = zipWithM (@?=) calculatedControlBlocks - checkVerification = assertBool "Script verifies" . verifyScriptPathData theOutputKey + checkVerification = assertBool "Script verifies" . verifyScriptPathData ctx theOutputKey -keyParity :: PubKey -> Word8 -keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of +keyParity :: Ctx -> PubKey -> Word8 +keyParity ctx key = + case BS.unpack . marshal ctx $ PublicKey key True of 0x02 : _ -> 0x00 _ -> 0x01 -testAddress :: TestScriptPubKey -> IO () -testAddress testData = computedAddress @?= (Just . spkeAddress . tspkExpected) testData +testAddress :: Ctx -> TestScriptPubKey -> IO () +testAddress ctx testData = + computedAddress @?= (Just . spkeAddress . tspkExpected) testData where - computedAddress = (addrToText btc <=< outputAddress) . taprootScriptOutput $ tspkGiven testData + computedAddress = + (addrToText btc <=< outputAddress ctx) + . taprootScriptOutput ctx + $ tspkGiven testData newtype SpkGiven = SpkGiven {unSpkGiven :: TaprootOutput} -instance FromJSON SpkGiven where - parseJSON = withObject "SpkGiven" $ \obj -> - fmap SpkGiven $ - TaprootOutput - <$> (xOnlyPubKey <$> obj .: "internalPubkey") - <*> (obj .:? "scriptTree" >>= traverse parseScriptTree) - where - parseScriptTree v = - parseScriptLeaf v - <|> parseScriptBranch v - <|> fail "Unable to parse scriptTree" - parseScriptLeaf = withObject "ScriptTree leaf" $ \obj -> - MASTLeaf - <$> obj .: "leafVersion" - <*> (obj .: "script" >>= hexScript) - parseScriptBranch v = - parseJSON v >>= \case - [v1, v2] -> MASTBranch <$> parseScriptTree v1 <*> parseScriptTree v2 - _ -> fail "ScriptTree branch" - hexScript = either fail pure . runGetS deserialize <=< jsonHex +spkGivenParseJSON :: Ctx -> Value -> Parser SpkGiven +spkGivenParseJSON ctx = withObject "SpkGiven" $ \obj -> do + pxopk@XOnlyPubKey {} <- unmarshalValue ctx =<< obj .: "internalPubkey" + tree <- traverse parseScriptTree =<< obj .:? "scriptTree" + return $ SpkGiven $ TaprootOutput pxopk.point tree + where + parseScriptTree v = + parseScriptLeaf v + <|> parseScriptBranch v + <|> fail "Unable to parse scriptTree" + parseScriptLeaf = withObject "ScriptTree leaf" $ \obj -> + MASTLeaf + <$> obj .: "leafVersion" + <*> (obj .: "script" >>= hexScript) + parseScriptBranch v = + parseJSON v >>= \case + [v1, v2] -> MASTBranch <$> parseScriptTree v1 <*> parseScriptTree v2 + _ -> fail "ScriptTree branch" + hexScript = either fail pure . runGetS deserialize <=< jsonHex data SpkIntermediary = SpkIntermediary - { spkiLeafHashes :: Maybe [ByteString] - , spkiMerkleRoot :: Maybe ByteString - , spkiTweakedPubKey :: PubKey - } + { spkiLeafHashes :: Maybe [ByteString], + spkiMerkleRoot :: Maybe ByteString, + spkiTweakedPubKey :: PubKey + } -instance FromJSON SpkIntermediary where - parseJSON = withObject "SpkIntermediary" $ \obj -> - SpkIntermediary - <$> (obj .:? "leafHashes" >>= (traverse . traverse) jsonHex) - <*> (obj .: "merkleRoot" >>= traverse jsonHex) - <*> (xOnlyPubKey <$> obj .: "tweakedPubkey") +spkIntermediaryParseJSON :: Ctx -> Value -> Parser SpkIntermediary +spkIntermediaryParseJSON ctx = withObject "SpkIntermediary" $ \obj -> + SpkIntermediary + <$> (obj .:? "leafHashes" >>= (traverse . traverse) jsonHex) + <*> (obj .: "merkleRoot" >>= traverse jsonHex) + <*> fmap + (\(XOnlyPubKey k) -> k) + (unmarshalValue ctx =<< obj .: "tweakedPubkey") data SpkExpected = SpkExpected - { spkeScriptPubKey :: ScriptOutput - , spkeControlBlocks :: Maybe [ByteString] - , spkeAddress :: Text - } + { spkeScriptPubKey :: ScriptOutput, + spkeControlBlocks :: Maybe [ByteString], + spkeAddress :: Text + } -instance FromJSON SpkExpected where - parseJSON = withObject "SpkExpected" $ \obj -> - SpkExpected - <$> obj .: "scriptPubKey" - <*> (obj .:? "scriptPathControlBlocks" >>= (traverse . traverse) jsonHex) - <*> obj .: "bip350Address" +spkExpectedParseJSON :: Ctx -> Value -> Parser SpkExpected +spkExpectedParseJSON ctx = withObject "SpkExpected" $ \obj -> + SpkExpected + <$> (unmarshalValue ctx =<< obj .: "scriptPubKey") + <*> ((traverse . traverse) jsonHex =<< obj .:? "scriptPathControlBlocks") + <*> obj .: "bip350Address" data TestScriptPubKey = TestScriptPubKey - { tspkGiven :: TaprootOutput - , tspkIntermediary :: SpkIntermediary - , tspkExpected :: SpkExpected - } + { tspkGiven :: TaprootOutput, + tspkIntermediary :: SpkIntermediary, + tspkExpected :: SpkExpected + } -instance FromJSON TestScriptPubKey where - parseJSON = withObject "TestScriptPubKey" $ \obj -> - TestScriptPubKey - <$> (unSpkGiven <$> obj .: "given") - <*> obj .: "intermediary" - <*> obj .: "expected" +testScriptPubKeyParseJSON :: Ctx -> Value -> Parser TestScriptPubKey +testScriptPubKeyParseJSON ctx = withObject "TestScriptPubKey" $ \obj -> do + given <- unSpkGiven <$> (spkGivenParseJSON ctx =<< obj .: "given") + inter <- spkIntermediaryParseJSON ctx =<< obj .: "intermediary" + expect <- spkExpectedParseJSON ctx =<< obj .: "expected" + return $ TestScriptPubKey given inter expect newtype TestVector = TestVector - { testScriptPubKey :: [TestScriptPubKey] - } + { testScriptPubKey :: [TestScriptPubKey] + } -instance FromJSON TestVector where - parseJSON = withObject "TestVector" $ \obj -> - TestVector <$> obj .: "scriptPubKey" +testVectorParseJSON :: Ctx -> Value -> Parser TestVector +testVectorParseJSON ctx = withObject "TestVector" $ \obj -> + TestVector <$> (mapM (testScriptPubKeyParseJSON ctx) =<< obj .: "scriptPubKey") jsonHex :: Text -> Parser ByteString jsonHex = maybe (fail "Unable to decode hex") pure . decodeHex diff --git a/test/Haskoin/TransactionSpec.hs b/test/Haskoin/TransactionSpec.hs index ac847828..c2400b0d 100644 --- a/test/Haskoin/TransactionSpec.hs +++ b/test/Haskoin/TransactionSpec.hs @@ -1,8 +1,14 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Haskoin.TransactionSpec (spec) where -import qualified Data.ByteString as B +import Control.Monad (unless) +import Data.ByteString qualified as B import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -13,9 +19,9 @@ import Data.String.Conversions import Data.Text (Text) import Data.Word (Word32, Word64) import Haskoin.Address -import Haskoin.Constants -import Haskoin.Data -import Haskoin.Keys +import Haskoin.Crypto +import Haskoin.Network.Constants +import Haskoin.Network.Data import Haskoin.Script import Haskoin.Transaction import Haskoin.Util @@ -25,345 +31,317 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck -serialVals :: [SerialBox] -serialVals = - [ SerialBox $ arbitraryTx =<< arbitraryNetwork - , SerialBox $ arbitraryWitnessTx =<< arbitraryNetwork - , SerialBox $ arbitraryLegacyTx =<< arbitraryNetwork - , SerialBox $ arbitraryTxIn =<< arbitraryNetwork - , SerialBox $ arbitraryTxOut =<< arbitraryNetwork - , SerialBox arbitraryOutPoint - ] +serialVals :: Ctx -> [SerialBox] +serialVals ctx = + [ SerialBox $ flip arbitraryTx ctx =<< arbitraryNetwork, + SerialBox $ flip arbitraryWitnessTx ctx =<< arbitraryNetwork, + SerialBox $ flip arbitraryLegacyTx ctx =<< arbitraryNetwork, + SerialBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork, + SerialBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork, + SerialBox arbitraryOutPoint + ] -readVals :: [ReadBox] -readVals = - [ ReadBox arbitraryTxHash - , ReadBox $ arbitraryTx =<< arbitraryNetwork - , ReadBox $ arbitraryTxIn =<< arbitraryNetwork - , ReadBox $ arbitraryTxOut =<< arbitraryNetwork - , ReadBox arbitraryOutPoint - ] +readVals :: Ctx -> [ReadBox] +readVals ctx = + [ ReadBox arbitraryTxHash, + ReadBox $ flip arbitraryTx ctx =<< arbitraryNetwork, + ReadBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork, + ReadBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork, + ReadBox arbitraryOutPoint + ] -jsonVals :: [JsonBox] -jsonVals = - [ JsonBox arbitraryTxHash - , JsonBox $ arbitraryTx =<< arbitraryNetwork - , JsonBox $ arbitraryWitnessTx =<< arbitraryNetwork - , JsonBox $ arbitraryLegacyTx =<< arbitraryNetwork - , JsonBox $ arbitraryTxIn =<< arbitraryNetwork - , JsonBox $ arbitraryTxOut =<< arbitraryNetwork - , JsonBox arbitraryOutPoint - ] +jsonVals :: Ctx -> [JsonBox] +jsonVals ctx = + [ JsonBox arbitraryTxHash, + JsonBox $ flip arbitraryTx ctx =<< arbitraryNetwork, + JsonBox $ flip arbitraryWitnessTx ctx =<< arbitraryNetwork, + JsonBox $ flip arbitraryLegacyTx ctx =<< arbitraryNetwork, + JsonBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork, + JsonBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork, + JsonBox arbitraryOutPoint + ] spec :: Spec -spec = do - testIdentity serialVals readVals jsonVals [] - describe "Transaction properties" $ do - prop "decode and encode txid" $ - forAll arbitraryTxHash $ \h -> hexToTxHash (txHashToHex h) == Just h - prop "from string transaction id" $ - forAll arbitraryTxHash $ \h -> fromString (cs $ txHashToHex h) == h - prop "building address tx" $ - forAll arbitraryNetwork $ \net -> - forAll arbitraryAddress $ - forAll (arbitrarySatoshi net) . testBuildAddrTx net - prop "guess transaction size" $ - forAll arbitraryNetwork $ \net -> - forAll (arbitraryAddrOnlyTxFull net) (testGuessSize net) - prop "choose coins" $ - forAll arbitraryNetwork $ \net -> - forAll (listOf (arbitrarySatoshi net)) testChooseCoins - prop "choose multisig coins" $ - forAll arbitraryNetwork $ \net -> - forAll arbitraryMSParam $ - forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins - prop "sign and validate transaction" $ - forAll arbitraryNetwork $ \net -> - forAll (arbitrarySigningData net) (testDetSignTx net) - prop "sign and validate (nested) transaction" $ - forAll arbitraryNetwork $ \net -> - forAll (arbitrarySigningData net) (testDetSignNestedTx net) - prop "merge partially signed transactions" $ - forAll arbitraryNetwork $ \net -> - property $ forAll (arbitraryPartialTxs net) (testMergeTx net) - describe "Transaction vectors" $ do - it "compute txid from tx" $ mapM_ testTxidVector txidVectors - it "build pkhash transaction (generated from bitcoind)" $ - mapM_ testPKHashVector pkHashVectors +spec = prepareContext $ \ctx -> do + testIdentity (serialVals ctx) (readVals ctx) (jsonVals ctx) [] + describe "Transaction properties" $ do + prop "decode and encode txid" $ + forAll arbitraryTxHash $ + \h -> hexToTxHash (txHashToHex h) == Just h + prop "from string transaction id" $ + forAll arbitraryTxHash $ + \h -> fromString (cs $ txHashToHex h) == h + prop "building address tx" $ + forAll arbitraryNetwork $ \net -> + forAll arbitraryAddress $ + forAll (arbitrarySatoshi net) . testBuildAddrTx net ctx + prop "guess transaction size" $ + forAll arbitraryNetwork $ \net -> + forAll (arbitraryAddrOnlyTxFull net ctx) (testGuessSize net ctx) + prop "choose coins" $ + forAll arbitraryNetwork $ \net -> + forAll (listOf (arbitrarySatoshi net)) testChooseCoins + prop "choose multisig coins" $ + forAll arbitraryNetwork $ \net -> + forAll arbitraryMSParam $ + forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins + prop "sign and validate transaction" $ + forAll arbitraryNetwork $ \net -> + forAll (arbitrarySigningData net ctx) (testDetSignTx net ctx) + prop "sign and validate (nested) transaction" $ + forAll arbitraryNetwork $ \net -> + forAll (arbitrarySigningData net ctx) (testDetSignNestedTx net ctx) + prop "merge partially signed transactions" $ + forAll arbitraryNetwork $ \net -> + property $ forAll (arbitraryPartialTxs net ctx) (testMergeTx net ctx) + describe "Transaction vectors" $ do + it "compute txid from tx" $ mapM_ testTxidVector txidVectors + it "build pkhash transaction (generated from bitcoind)" $ + mapM_ (testPKHashVector ctx) pkHashVectors -- Txid Vectors testTxidVector :: (Text, Text) -> Assertion testTxidVector (tid, tx) = - assertEqual "txid" (Just tid) (txHashToHex . txHash <$> txM) + assertEqual "txid" (Just tid) (txHashToHex . txHash <$> txM) where txM = eitherToMaybe . runGetS deserialize =<< decodeHex tx txidVectors :: [(Text, Text)] txidVectors = - [ - ( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63" - , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa4\ - \3ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75\ - \418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb\ - \60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f0000000000\ - \1976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000" - ) - , - ( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73" - , "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3\ - \bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a\ - \04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7\ - \d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68\ - \350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b\ - \2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d0000\ - \0000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac000000\ - \00" - ) - , - ( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb" - , "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2\ - \f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332ad\ - \fca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c\ - \70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f\ - \09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919a\ - \d1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737\ - \864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a473044\ - \0220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa\ - \2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f8\ - \1e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc8\ - \0a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd32273276\ - \94c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df3\ - \2949d4646dfa10a92458cfaa88ac00000000" - ) - , - ( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae" - , "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c5\ - \9da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678\ - \fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab\ - \486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b\ - \52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbe\ - \a097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045\ - \022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf9506\ - \50802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f\ - \68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e3\ - \77c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e1\ - \8217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a378\ - \8dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972\ - \d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2\ - \e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffff\ - \ff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9c\ - \fdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675\ - \d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa\ - \34b26f62db4a88ac00000000" - ) - ] + [ ( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63", + "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa4\ + \3ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75\ + \418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb\ + \60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f0000000000\ + \1976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000" + ), + ( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73", + "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3\ + \bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a\ + \04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7\ + \d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68\ + \350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b\ + \2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d0000\ + \0000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac000000\ + \00" + ), + ( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb", + "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2\ + \f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332ad\ + \fca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c\ + \70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f\ + \09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919a\ + \d1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737\ + \864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a473044\ + \0220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa\ + \2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f8\ + \1e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc8\ + \0a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd32273276\ + \94c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df3\ + \2949d4646dfa10a92458cfaa88ac00000000" + ), + ( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae", + "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c5\ + \9da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678\ + \fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab\ + \486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b\ + \52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbe\ + \a097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045\ + \022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf9506\ + \50802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f\ + \68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e3\ + \77c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e1\ + \8217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a378\ + \8dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972\ + \d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2\ + \e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffff\ + \ff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9c\ + \fdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675\ + \d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa\ + \34b26f62db4a88ac00000000" + ) + ] -- Build address transactions vectors generated from bitcoin-core raw tx API -testPKHashVector :: ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion -testPKHashVector (is, os, res) = - assertEqual - "Build PKHash Tx" - (Right res) - (encodeHex . runPutS . serialize <$> txE) +testPKHashVector :: Ctx -> ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion +testPKHashVector ctx (is, os, res) = + assertEqual + "Build PKHash Tx" + (Right res) + (encodeHex . runPutS . serialize <$> txE) where - txE = buildAddrTx btc (map f is) os + txE = buildAddrTx btc ctx (map f is) os f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix pkHashVectors :: [([(Text, Word32)], [(Text, Word64)], Text)] pkHashVectors = - [ - ( - [ - ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db" - , 14 - ) - ] - , [("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 90000000)] - , "0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\ - \a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc58\ - \2292b97668bedd91dd5bf9374c88ac00000000" + [ ( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db", + 14 ) - , - ( - [ - ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db" - , 0 - ) - , - ( "0001000000000000000000000000000000000000000000000000000000000000" - , 2147483647 - ) - ] - , - [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1) - , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000) - ] - , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\ - \a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000\ - \000000000000000000000100ffffff7f00ffffffff0201000000000000001976a9\ - \1424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976\ - \a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000" + ], + [("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 90000000)], + "0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\ + \a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc58\ + \2292b97668bedd91dd5bf9374c88ac00000000" + ), + ( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db", + 0 + ), + ( "0001000000000000000000000000000000000000000000000000000000000000", + 2147483647 ) - , - ( - [ - ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db" - , 0 - ) - , - ( "0001000000000000000000000000000000000000000000000000000000000000" - , 2147483647 - ) - ] - , [] - , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a\ - \1eb29eb0000000000ffffffff000000000000000000000000000000000000000000\ - \0000000000000000000100ffffff7f00ffffffff0000000000" + ], + [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1), + ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000) + ], + "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\ + \a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000\ + \000000000000000000000100ffffff7f00ffffffff0201000000000000001976a9\ + \1424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976\ + \a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000" + ), + ( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db", + 0 + ), + ( "0001000000000000000000000000000000000000000000000000000000000000", + 2147483647 ) - , - ( [] - , - [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1) - , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000) - ] - , "01000000000201000000000000001976a91424aa604689cc582292b97668bedd91d\ - \d5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954\ - \993cbca54f88ac00000000" - ) - ] + ], + [], + "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a\ + \1eb29eb0000000000ffffffff000000000000000000000000000000000000000000\ + \0000000000000000000100ffffff7f00ffffffff0000000000" + ), + ( [], + [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1), + ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000) + ], + "01000000000201000000000000001976a91424aa604689cc582292b97668bedd91d\ + \d5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954\ + \993cbca54f88ac00000000" + ) + ] -- Transaction Properties -- -testBuildAddrTx :: Network -> Address -> TestCoin -> Bool -testBuildAddrTx net a (TestCoin v) - | isPubKeyAddress a = Right (PayPKHash (getAddrHash160 a)) == out - | isScriptAddress a = Right (PayScriptHash (getAddrHash160 a)) == out - | otherwise = undefined +testBuildAddrTx :: Network -> Ctx -> Address -> TestCoin -> Bool +testBuildAddrTx net ctx a (TestCoin v) + | isPubKeyAddress a = PayPKHash a.hash160 == out + | isScriptAddress a = PayScriptHash a.hash160 == out + | otherwise = undefined where - tx = buildAddrTx net [] [(fromJust (addrToText net a), v)] - out = - decodeOutputBS $ - scriptOutput $ - head $ txOut (fromRight (error "Could not build transaction") tx) + out = either error id $ do + tx <- buildAddrTx net ctx [] [(fromJust (addrToText net a), v)] + unmarshal ctx (head tx.outputs).script -- We compute an upper bound but it should be close enough to the real size -- We give 2 bytes of slack on every signature (1 on r and 1 on s) -testGuessSize :: Network -> Tx -> Bool -testGuessSize net tx = - guess >= len && guess <= len + 2 * delta +testGuessSize :: Network -> Ctx -> Tx -> Bool +testGuessSize net ctx tx = + guess >= len && guess <= len + 2 * delta where delta = pki + sum (map fst msi) guess = guessTxSize pki msi pkout msout len = B.length $ runPutS $ serialize tx - ins = map f $ txIn tx - f i = - fromRight (error "Could not decode input") $ - decodeInputBS net $ scriptInput i + ins = map f tx.inputs + f i = either error id $ unmarshal (net, ctx) i.script pki = length $ filter isSpendPKHash ins msi = concatMap shData ins shData (ScriptHashInput _ (PayMulSig keys r)) = [(r, length keys)] shData _ = [] - out = - map - ( fromRight (error "Could not decode transaction output") - . decodeOutputBS - . scriptOutput - ) - $ txOut tx + out = map (either error id . unmarshal ctx . (.script)) tx.outputs pkout = length $ filter isPayPKHash out msout = length $ filter isPayScriptHash out testChooseCoins :: [TestCoin] -> Word64 -> Word64 -> Int -> Property testChooseCoins coins target byteFee nOut = - nOut >= 0 - ==> case chooseCoins target byteFee nOut True coins of - Right (chosen, change) -> - let outSum = sum $ map coinValue chosen - fee = guessTxFee byteFee nOut (length chosen) - in outSum == target + change + fee - Left _ -> - let fee = guessTxFee byteFee nOut (length coins) - in target == 0 || s < target + fee + nOut >= 0 ==> + case chooseCoins target byteFee nOut True coins of + Right (chosen, change) -> + let outSum = sum $ map coinValue chosen + fee = guessTxFee byteFee nOut (length chosen) + in outSum == target + change + fee + Left _ -> + let fee = guessTxFee byteFee nOut (length coins) + in target == 0 || s < target + fee where s = sum $ map coinValue coins testChooseMSCoins :: - (Int, Int) -> - [TestCoin] -> - Word64 -> - Word64 -> - Int -> - Property + (Int, Int) -> + [TestCoin] -> + Word64 -> + Word64 -> + Int -> + Property testChooseMSCoins (m, n) coins target byteFee nOut = - nOut >= 0 - ==> case chooseMSCoins target byteFee (m, n) nOut True coins of - Right (chosen, change) -> - let outSum = sum $ map coinValue chosen - fee = guessMSTxFee byteFee (m, n) nOut (length chosen) - in outSum == target + change + fee - Left _ -> - let fee = guessMSTxFee byteFee (m, n) nOut (length coins) - in target == 0 || s < target + fee + nOut >= 0 ==> + case chooseMSCoins target byteFee (m, n) nOut True coins of + Right (chosen, change) -> + let outSum = sum $ map coinValue chosen + fee = guessMSTxFee byteFee (m, n) nOut (length chosen) + in outSum == target + change + fee + Left _ -> + let fee = guessMSTxFee byteFee (m, n) nOut (length coins) + in target == 0 || s < target + fee where s = sum $ map coinValue coins {- Signing Transactions -} -testDetSignTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool -testDetSignTx net (tx, sigis, prv) = - not (verifyStdTx net tx verData) - && not (verifyStdTx net txSigP verData) - && verifyStdTx net txSigC verData +testDetSignTx :: Network -> Ctx -> (Tx, [SigInput], [PrivateKey]) -> Bool +testDetSignTx net ctx (tx, sigis, prv) = + not verify1 && not verify2 && verify3 where - txSigP = - fromRight (error "Could not decode transaction") $ - signTx net tx sigis (map secKeyData (tail prv)) - txSigC = - fromRight (error "Could not decode transaction") $ - signTx net txSigP sigis [secKeyData (head prv)] - verData = map (\(SigInput s v o _ _) -> (s, v, o)) sigis + verify1 = verifyStdTx net ctx tx verData + verify2 = verifyStdTx net ctx txSigP verData + verify3 = verifyStdTx net ctx txSigC verData + txSigP = either error id $ signTx net ctx tx sigis (map (.key) (tail prv)) + txSigC = either error id $ signTx net ctx txSigP sigis [(head prv).key] + sigData SigInput {..} = (script, value, outpoint) + verData = map sigData sigis -testDetSignNestedTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool -testDetSignNestedTx net (tx, sigis, prv) = - not (verifyStdTx net tx verData) - && not (verifyStdTx net txSigP verData) - && verifyStdTx net txSigC verData +testDetSignNestedTx :: Network -> Ctx -> (Tx, [SigInput], [PrivateKey]) -> Bool +testDetSignNestedTx net ctx (tx, sigis, prv) = + not verify1 && not verify2 && verify3 where + verify1 = verifyStdTx net ctx tx verData + verify2 = verifyStdTx net ctx txSigP verData + verify3 = verifyStdTx net ctx txSigC verData txSigP = - fromRight (error "Could not decode transaction") $ - signNestedWitnessTx net tx sigis (secKeyData <$> tail prv) + either error id $ + signNestedWitnessTx net ctx tx sigis ((.key) <$> tail prv) txSigC = - fromRight (error "Could not decode transaction") $ - signNestedWitnessTx net txSigP sigis [secKeyData (head prv)] + either error id $ + signNestedWitnessTx net ctx txSigP sigis [(head prv).key] verData = handleSegwit <$> sigis handleSegwit (SigInput s v o _ _) - | isSegwit s = (toP2SH $ encodeOutput s, v, o) - | otherwise = (s, v, o) + | isSegwit s = (toP2SH (encodeOutput ctx s), v, o) + | otherwise = (s, v, o) -testMergeTx :: Network -> ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool -testMergeTx net (txs, os) = - and - [ isRight mergeRes - , length (txIn mergedTx) == length os - , if enoughSigs - then isValid - else not isValid - , -- Signature count == min (length txs) (sum required signatures) - sum (map snd sigMap) == min (length txs) (sum (map fst sigMap)) - ] +testMergeTx :: Network -> Ctx -> ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool +testMergeTx net ctx (txs, os) = + and + [ isRight mergeRes, + length mergedTx.inputs == length os, + if enoughSigs + then isValid + else not isValid, + -- Signature count == min (length txs) (sum required signatures) + sum (map snd sigMap) == min (length txs) (sum (map fst sigMap)) + ] where outs = map (\(so, val, op, _, _) -> (so, val, op)) os - mergeRes = mergeTxs net txs outs + mergeRes = mergeTxs net ctx txs outs mergedTx = fromRight (error "Could not merge") mergeRes - isValid = verifyStdTx net mergedTx outs + isValid = verifyStdTx net ctx mergedTx outs enoughSigs = all (\(m, c) -> c >= m) sigMap - sigMap = - map (\((_, _, _, m, _), inp) -> (m, sigCnt inp)) $ - zip os $ txIn mergedTx + sigFun (_, _, _, m, _) inp = (m, sigCnt inp) + sigMap = zipWith sigFun os mergedTx.inputs sigCnt inp = - case decodeInputBS net $ scriptInput inp of - Right (RegularInput (SpendMulSig sigs)) -> length sigs - Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs - _ -> error "Invalid input script type" + case unmarshal (net, ctx) inp.script of + Right (RegularInput (SpendMulSig sigs)) -> length sigs + Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs + _ -> error "Invalid input script type" diff --git a/test/Haskoin/UtilSpec.hs b/test/Haskoin/UtilSpec.hs index 039a22b8..f0a3896c 100644 --- a/test/Haskoin/UtilSpec.hs +++ b/test/Haskoin/UtilSpec.hs @@ -1,58 +1,57 @@ -module Haskoin.UtilSpec ( - spec, - customCerealID, - readTestFile, -) where +{-# LANGUAGE ImportQualifiedPost #-} -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as A +module Haskoin.UtilSpec (spec) where + +import Data.Aeson import Data.Aeson.Encoding (encodingToLazyByteString) -import Data.Aeson.Types (Parser, parseMaybe) -import qualified Data.ByteString as BS +import Data.Aeson.Types (Parser, parse) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B import Data.Either (fromLeft, fromRight, isLeft, isRight) import Data.Foldable (toList) import Data.List (permutations) import Data.Map.Strict (singleton) import Data.Maybe -import qualified Data.Sequence as Seq +import Data.Sequence qualified as Seq import Data.Serialize as S +import Haskoin.Crypto import Haskoin.Util import Haskoin.Util.Arbitrary import Test.Hspec import Test.Hspec.QuickCheck -import Test.QuickCheck +import Test.QuickCheck (forAll) spec :: Spec spec = - describe "utility functions" $ do - prop "bsToInteger . integerToBS" getPutInteger - prop "decodeHex . encodeHex" $ forAll arbitraryBS fromToHex - prop "compare updateIndex with Data.Sequence" testUpdateIndex - prop "matchTemplate" testMatchTemplate - prop "testing matchTemplate with two lists" testMatchTemplateLen - prop "test eitherToMaybe" testEitherToMaybe - prop "test maybeToEither" testMaybeToEither + describe "utility functions" $ do + prop "bsToInteger . integerToBS" getPutInteger + prop "decodeHex . encodeHex" $ forAll arbitraryBS fromToHex + prop "compare updateIndex with Data.Sequence" testUpdateIndex + prop "matchTemplate" testMatchTemplate + prop "testing matchTemplate with two lists" testMatchTemplateLen + prop "test eitherToMaybe" testEitherToMaybe + prop "test maybeToEither" testMaybeToEither {- Various utilities -} getPutInteger :: Integer -> Bool getPutInteger i = bsToInteger (integerToBS $ abs i) == abs i -fromToHex :: BS.ByteString -> Bool +fromToHex :: ByteString -> Bool fromToHex bs = decodeHex (encodeHex bs) == Just bs testUpdateIndex :: [Int] -> Int -> Int -> Bool testUpdateIndex xs v i = - updateIndex i xs (const v) == toList (Seq.update i v $ Seq.fromList xs) + updateIndex i xs (const v) == toList (Seq.update i v $ Seq.fromList xs) testMatchTemplate :: [Int] -> Int -> Bool testMatchTemplate as i = catMaybes res == bs where res = matchTemplate as bs (==) idx = - if null as - then 0 - else i `mod` length as + if null as + then 0 + else i `mod` length as bs = permutations as !! idx testMatchTemplateLen :: [Int] -> [Int] -> Bool @@ -67,14 +66,3 @@ testEitherToMaybe e = isNothing (eitherToMaybe e) testMaybeToEither :: Maybe Int -> String -> Bool testMaybeToEither (Just v) str = maybeToEither str (Just v) == Right v testMaybeToEither m str = maybeToEither str m == Left str - -{-- Test Utilities --} - -customCerealID :: Eq a => Get a -> Putter a -> a -> Bool -customCerealID g p a = runGet g (runPut (p a)) == Right a - -readTestFile :: A.FromJSON a => FilePath -> IO a -readTestFile fp = - A.eitherDecodeFileStrict ("data/" <> fp) >>= either (error . message) return - where - message aesonErr = "Could not read test file " <> fp <> ": " <> aesonErr