mirror of
https://github.com/haskoin/haskoin-core.git
synced 2024-08-16 21:41:22 +03:00
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.
This commit is contained in:
parent
64ceb860e1
commit
8fb472f60d
261
CHANGELOG.md
261
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.
|
||||
|
@ -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)
|
||||
|
@ -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 <https://github.com/haskoin/haskoin-core#readme>
|
||||
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
|
||||
|
6
hie.yaml
Normal file
6
hie.yaml
Normal file
@ -0,0 +1,6 @@
|
||||
cradle:
|
||||
stack:
|
||||
- path: "./src"
|
||||
component: haskoin-core:lib
|
||||
- path: "./test"
|
||||
component: haskoin-core:test:spec
|
@ -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 <https://github.com/haskoin/haskoin-core#readme>
|
||||
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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]
|
@ -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
|
||||
|
@ -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
|
||||
|
20
src/Haskoin/Crypto/Keys.hs
Normal file
20
src/Haskoin/Crypto/Keys.hs
Normal file
@ -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
|
185
src/Haskoin/Crypto/Keys/Common.hs
Normal file
185
src/Haskoin/Crypto/Keys/Common.hs
Normal file
@ -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
|
1057
src/Haskoin/Crypto/Keys/Extended.hs
Normal file
1057
src/Haskoin/Crypto/Keys/Extended.hs
Normal file
File diff suppressed because it is too large
Load Diff
88
src/Haskoin/Crypto/Keys/Extended/Internal.hs
Normal file
88
src/Haskoin/Crypto/Keys/Extended/Internal.hs
Normal file
@ -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
|
2233
src/Haskoin/Crypto/Keys/Mnemonic.hs
Normal file
2233
src/Haskoin/Crypto/Keys/Mnemonic.hs
Normal file
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
-- <http://www.secg.org/sec1-v2.pdf Section 4.1.4>
|
||||
-- 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
|
||||
-- <http://www.secg.org/sec1-v2.pdf Section 4.1.4>
|
||||
-- 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
|
||||
|
@ -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)
|
@ -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
|
@ -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
|
File diff suppressed because it is too large
Load Diff
@ -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
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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
|
||||
|
File diff suppressed because it is too large
Load Diff
582
src/Haskoin/Network/Constants.hs
Normal file
582
src/Haskoin/Network/Constants.hs
Normal file
@ -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]
|
89
src/Haskoin/Network/Data.hs
Normal file
89
src/Haskoin/Network/Data.hs
Normal file
@ -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)
|
@ -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
|
||||
|
@ -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
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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"
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
]
|
||||
|
@ -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)))
|
||||
]
|
||||
|
@ -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
|
||||
|
@ -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])
|
||||
|
@ -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"
|
||||
|
426
src/Haskoin/Util/Helpers.hs
Normal file
426
src/Haskoin/Util/Helpers.hs
Normal file
@ -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
|
44
src/Haskoin/Util/Marshal.hs
Normal file
44
src/Haskoin/Util/Marshal.hs
Normal file
@ -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
|
@ -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
|
||||
- secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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"
|
||||
)
|
||||
]
|
||||
|
@ -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"
|
||||
)
|
||||
]
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
)
|
||||
]
|
||||
|
608
test/Haskoin/Crypto/Keys/ExtendedSpec.hs
Normal file
608
test/Haskoin/Crypto/Keys/ExtendedSpec.hs
Normal file
@ -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"
|
||||
]
|
||||
]
|
500
test/Haskoin/Crypto/Keys/MnemonicSpec.hs
Normal file
500
test/Haskoin/Crypto/Keys/MnemonicSpec.hs
Normal file
@ -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
|
261
test/Haskoin/Crypto/KeysSpec.hs
Normal file
261
test/Haskoin/Crypto/KeysSpec.hs
Normal file
@ -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
|
@ -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
|
||||
|
@ -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"
|
||||
]
|
||||
]
|
@ -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
|
@ -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
|
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user